Index: Makefile
==================================================================
--- Makefile
+++ Makefile
@@ -20,21 +20,24 @@
SHELL=/bin/bash
PREFIX=$(PWD)
CSCOPTS=
INSTALL=install
SRCFILES = common.scm items.scm launch.scm \
- ods.scm runconfig.scm server.scm configf.scm \
- db.scm keys.scm margs.scm megatest-version.scm \
+ ods.scm runconfig.scm configf.scm \
+ keys.scm margs.scm server.o megatest-version.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 subrun.scm \
- portlogger.scm archive.scm env.scm diff-report.scm cgisetup/models/pgdb.scm
+ ezsteps.scm lock-queue.scm \
+ rmt.scm subrun.scm \
+ archive.scm env.scm diff-report.scm cgisetup/models/pgdb.scm
# module source files
-MSRCFILES = ftail.scm
+MSRCFILES = ftail.scm portlogger.scm nmsg-transport.scm db.scm api.scm
+
+# files needed for mtserve
+MTSERVEFILES = common.scm megatest-version.scm margs.scm server.scm keys.scm ods.scm rmt.scm
# Eggs to install (straightforward ones)
EGGS=matchable readline apropos base64 regex-literals format regex-case test coops trace csv \
dot-locking posix-utils posix-extras directory-utils hostinfo tcp-server rpc csv-xml fmt \
json md5 awful http-client spiffy uri-common intarweb spiffy-request-vars \
@@ -42,10 +45,11 @@
GUISRCF = dashboard-context-menu.scm dashboard-tests.scm dashboard-guimonitor.scm gutils.scm dcommon.scm tree.scm vg.scm
OFILES = $(SRCFILES:%.scm=%.o)
GOFILES = $(GUISRCF:%.scm=%.o)
+MTSERVEOFILES = $(MTSERVEFILES:%.scm=%.o)
MOFILES = $(addprefix mofiles/,$(MSRCFILES:%.scm=%.o))
mofiles/%.o : %.scm
mkdir -p mofiles
@@ -68,36 +72,36 @@
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
+all : $(PREFIX)/bin/.$(ARCHSTR) mtest dboard mtut mtserve
-mtest: $(OFILES) readline-fix.scm megatest.o $(MOFILES) mofiles/ftail.o
+mtest: $(OFILES) readline-fix.scm megatest.o $(MOFILES)
csc $(CSCOPTS) $(OFILES) $(MOFILES) megatest.o -o mtest
+mtserve: $(MTSERVEOFILES) readline-fix.scm mtserve.o $(MOFILES)
+ csc $(CSCOPTS) $(MTSERVEOFILES) $(MOFILES) mtserve.o -o mtserve
+
showmtesthash:
@echo $(MTESTHASH)
dboard : $(OFILES) $(GOFILES) dashboard.scm $(MOFILES)
csc $(CSCOPTS) $(OFILES) dashboard.scm $(GOFILES) $(MOFILES) -o dboard
ndboard : newdashboard.scm $(OFILES) $(GOFILES)
csc $(CSCOPTS) $(OFILES) $(GOFILES) newdashboard.scm -o ndboard
-mtut: $(OFILES) megatest-fossil-hash.scm mtut.scm
- csc $(CSCOPTS) $(OFILES) mtut.scm -o mtut
+mtut: $(OFILES) megatest-fossil-hash.scm mtut.scm $(MOFILES)
+ csc $(CSCOPTS) $(OFILES) $(MOFILES) mtut.scm -o mtut
TCMTOBJS = \
- api.o \
archive.o \
cgisetup/models/pgdb.o \
client.o \
common.o \
configf.o \
- db.o \
env.o \
http-transport.o \
items.o \
keys.o \
launch.o \
@@ -104,25 +108,27 @@
lock-queue.o \
margs.o \
mt.o \
megatest-version.o \
ods.o \
- portlogger.o \
process.o \
rmt.o \
- rpc-transport.o \
runconfig.o \
runs.o \
server.o \
tasks.o \
tdb.o \
tests.o \
subrun.o \
+
+# api.o \
+# db.o \
+# rpc-transport.o \
+# portlogger.o \
-
-tcmt : $(TCMTOBJS) tcmt.scm
- csc $(CSCOPTS) $(TCMTOBJS) tcmt.scm -o tcmt
+tcmt : $(TCMTOBJS) tcmt.scm $(MOFILES)
+ csc $(CSCOPTS) $(TCMTOBJS) $(MOFILES) tcmt.scm -o tcmt
# install documentation to $(PREFIX)/docs
# DOES NOT REBUILD DOCS
#
$(PREFIX)/share/docs/megatest_manual.html : docs/manual/megatest_manual.html
@@ -156,27 +162,45 @@
megatest.o : megatest-fossil-hash.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
common_records.scm : altdb.scm
vg.o dashboard.o : vg_records.scm
dcommon.o : run_records.scm
+
+# module deps
+http-transport.o : mofiles/portlogger.o
+megatest.o rnt.o : mofiles/nmsg-transport.o
+
# Temporary while transitioning to new routine
# runs.o : run-tests-queue-classic.scm run-tests-queue-new.scm
megatest-fossil-hash.scm : $(SRCFILES) megatest.scm *_records.scm
echo "(define megatest-fossil-hash \"$(MTESTHASH)\")" > megatest-fossil-hash.new
if ! diff -q megatest-fossil-hash.new megatest-fossil-hash.scm ; then echo copying .new to .scm;cp -f megatest-fossil-hash.new megatest-fossil-hash.scm;fi
$(OFILES) $(GOFILES) : common_records.scm
-%.o : %.scm $(MOFILES)
- csc $(CSCOPTS) -c $< $(MOFILES)
+# %.o : %.scm $(MOFILES)
+# csc $(CSCOPTS) -c $< $(MOFILES)
+
+%.o : %.scm
+ csc $(CSCOPTS) -c $<
$(PREFIX)/bin/.$(ARCHSTR)/mtest : mtest utils/mk_wrapper
@echo Installing to PREFIX=$(PREFIX)
$(INSTALL) mtest $(PREFIX)/bin/.$(ARCHSTR)/mtest
utils/mk_wrapper $(PREFIX) mtest $(PREFIX)/bin/megatest
chmod a+x $(PREFIX)/bin/megatest
+
+$(PREFIX)/bin/.$(ARCHSTR)/mtserve : mtserve utils/mk_wrapper
+ @echo Installing to PREFIX=$(PREFIX)
+ $(INSTALL) mtserve $(PREFIX)/bin/.$(ARCHSTR)/mtserve
+ utils/mk_wrapper $(PREFIX) mtserve $(PREFIX)/bin/mtserver
+ chmod a+x $(PREFIX)/bin/mtserver
+
+$(PREFIX)/bin/mtserver : $(PREFIX)/bin/.$(ARCHSTR)/mtserve utils/mk_wrapper
+ utils/mk_wrapper $(PREFIX) mtserve $(PREFIX)/bin/mtserver
+ chmod a+x $(PREFIX)/bin/mtserver
$(PREFIX)/bin/.$(ARCHSTR)/ndboard : ndboard
$(INSTALL) ndboard $(PREFIX)/bin/.$(ARCHSTR)/ndboard
$(PREFIX)/bin/newdashboard : $(PREFIX)/bin/.$(ARCHSTR)/ndboard utils/mk_wrapper
@@ -278,11 +302,11 @@
chmod a+x $(PREFIX)/bin/dashboard
$(INSTALL) dboard $(PREFIX)/bin/.$(ARCHSTR)/dboard
install : $(PREFIX)/bin/.$(ARCHSTR) $(PREFIX)/bin/.$(ARCHSTR)/mtest $(PREFIX)/bin/megatest \
$(PREFIX)/bin/.$(ARCHSTR)/dboard $(PREFIX)/bin/dashboard $(HELPERS) $(PREFIX)/bin/nbfake \
- $(PREFIX)/bin/serialize-env \
+ $(PREFIX)/bin/serialize-env $(PREFIX)/bin/mtserver \
$(PREFIX)/bin/nbfind $(PREFIX)/bin/loadrunner $(PREFIX)/bin/viewscreen $(PREFIX)/bin/mt_xterm \
$(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
@@ -303,11 +327,11 @@
$(MTQA_FOSSIL) :
fossil clone https://www.kiatoa.com/fossils/megatest_qa $(MTQA_FOSSIL)
clean :
- rm -f $(OFILES) $(GOFILES) $(MOFILES) $(TCMTOBJS) $(PREFIX)/megatest $(PREFIX)/dashboard mtest mtutil dboard dboard.o megatest.o dashboard.o megatest-fossil-hash.* altdb.scm mofiles/*.o vg.o
+ rm -f $(OFILES) $(GOFILES) $(MOFILES) $(TCMTOBJS) $(PREFIX)/megatest $(PREFIX)/dashboard mtest mtutil dboard dboard.o megatest.o dashboard.o megatest-fossil-hash.* altdb.scm mofiles/*.o vg.o *import.scm
#======================================================================
# Make the records files
#======================================================================
@@ -402,12 +426,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 megatest-version.o mt.o ods.o portlogger.o process.o rmt.o rpc-transport.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 megatest-version.o mt.o ods.o portlogger.o process.o rmt.o rpc-transport.o runconfig.o runs.o sdb.o server.o synchash.o tasks.o tdb.o tests.o tree.o
+portlogger-example : portlogger-example.scm portlogger.o
+ csc $(CSCOPTS) portlogger-example.scm portlogger.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
@@ -16,355 +16,20 @@
;; You should have received a copy of the GNU General Public License
;; along with Megatest. If not, see .
;;
;;======================================================================
-(use srfi-69 posix)
-
-(declare (unit api))
-(declare (uses rmt))
-(declare (uses db))
-(declare (uses tasks))
-
-;; allow these queries through without starting a server
-;;
-(define api:read-only-queries
- '(get-key-val-pairs
- get-var
- get-keys
- get-key-vals
- test-toplevel-num-items
- get-test-info-by-id
- get-steps-info-by-id
- get-data-info-by-id
- test-get-rundir-from-test-id
- get-count-tests-running-for-testname
- get-count-tests-running
- get-count-tests-running-in-jobgroup
- get-previous-test-run-record
- get-matching-previous-test-run-records
- test-get-logfile-info
- test-get-records-for-index-file
- get-testinfo-state-status
- test-get-top-process-pid
- test-get-paths-matching-keynames-target-new
- get-prereqs-not-met
- get-count-tests-running-for-run-id
- get-run-info
- get-run-status
- get-run-stats
- get-run-times
- get-targets
- get-target
- ;; register-run
- get-tests-tags
- get-test-times
- get-tests-for-run
- get-test-id
- get-tests-for-runs-mindata
- get-tests-for-run-mindata
- get-run-name-from-id
- get-runs
- simple-get-runs
- get-num-runs
- get-runs-cnt-by-patt
- get-all-run-ids
- get-prev-run-ids
- get-run-ids-matching-target
- get-runs-by-patt
- get-steps-data
- get-steps-for-test
- read-test-data
- read-test-data*
- login
- tasks-get-last
- testmeta-get-record
- have-incompletes?
- synchash-get
- get-changed-record-ids
- get-run-record-ids
- ))
-
-(define api:write-queries
- '(
- get-keys-write ;; dummy "write" query to force server start
-
- ;; SERVERS
- start-server
- kill-server
-
- ;; TESTS
- test-set-state-status-by-id
- delete-test-records
- delete-old-deleted-test-records
- test-set-state-status
- test-set-top-process-pid
- set-state-status-and-roll-up-items
- update-pass-fail-counts
- top-test-set-per-pf-counts ;; (db:top-test-set-per-pf-counts (db:get-db *db* 5) 5 "runfirst")
-
- ;; RUNS
- register-run
- set-tests-state-status
- delete-run
- lock/unlock-run
- update-run-event_time
- mark-incomplete
-
- ;; STEPS
- teststep-set-status!
-
- ;; TEST DATA
- test-data-rollup
- csv->test-data
-
- ;; MISC
- sync-inmem->db
-
- ;; TESTMETA
- testmeta-add-record
- testmeta-update-field
-
- ;; TASKS
- tasks-add
- tasks-set-state-given-param-key
- ))
-
-;; These are called by the server on recipt of /api calls
-;; - 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)
- (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
- (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)
- (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))
- (cmd (if (symbol? cmd-in)
- cmd-in
- (string->symbol cmd-in)))
- (params (vector-ref dat 1))
- (start-t (current-milliseconds))
- (readonly-mode (dbr:dbstruct-read-only dbstruct))
- (readonly-command (member cmd api:read-only-queries))
- (writecmd-in-readonly-mode (and readonly-mode (not readonly-command)))
- (res
- (if writecmd-in-readonly-mode
- (conc "attempt to run write command "cmd" on a read-only database")
- (case cmd
- ;;===============================================
- ;; READ/WRITE QUERIES
- ;;===============================================
-
- ((get-keys-write) (db:get-keys dbstruct)) ;; force a dummy "write" query to force server; for debug in -repl
-
- ;; SERVERS
- ((start-server) (apply server:kind-run params))
- ((kill-server) (set! *server-run* #f))
-
- ;; TESTS
-
- ;;((test-set-state-status-by-id) (apply mt:test-set-state-status-by-id dbstruct params))
- ;;BB - commented out above because it was calling below, eventually, incorrectly (dbstruct passed to mt:test-set-state-status-by-id, which previosly did more, but now only passes thru to db:set-state-status-and-roll-up-items.
- ((test-set-state-status-by-id)
-
- ;; (define (db:set-state-status-and-roll-up-items dbstruct run-id test-name item-path state status comment)
- (db:set-state-status-and-roll-up-items
- dbstruct
- (list-ref params 0) ; run-id
- (list-ref params 1) ; test-name
- #f ; item-path
- (list-ref params 2) ; state
- (list-ref params 3) ; status
- (list-ref params 4) ; comment
- ))
-
- ((delete-test-records) (apply db:delete-test-records dbstruct params))
- ((delete-old-deleted-test-records) (apply db:delete-old-deleted-test-records dbstruct params))
- ((test-set-state-status) (apply db:test-set-state-status dbstruct params))
- ((test-set-top-process-pid) (apply db:test-set-top-process-pid dbstruct params))
- ((set-state-status-and-roll-up-items) (apply db:set-state-status-and-roll-up-items dbstruct params))
- ((top-test-set-per-pf-counts) (apply db:top-test-set-per-pf-counts dbstruct params))
- ((test-set-archive-block-id) (apply db:test-set-archive-block-id dbstruct params))
-
- ;; RUNS
- ((register-run) (apply db:register-run dbstruct params))
- ((set-tests-state-status) (apply db:set-tests-state-status dbstruct params))
- ((delete-run) (apply db:delete-run dbstruct params))
- ((lock/unlock-run) (apply db:lock/unlock-run dbstruct params))
- ((update-run-event_time) (apply db:update-run-event_time dbstruct params))
- ((update-run-stats) (apply db:update-run-stats dbstruct params))
- ((set-var) (apply db:set-var dbstruct params))
- ((del-var) (apply db:del-var dbstruct params))
-
- ;; STEPS
- ((teststep-set-status!) (apply db:teststep-set-status! 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)))
- ((mark-incomplete) (apply db:find-and-mark-incomplete dbstruct params))
-
- ;; TESTMETA
- ((testmeta-add-record) (apply db:testmeta-add-record dbstruct params))
- ((testmeta-update-field) (apply db:testmeta-update-field dbstruct params))
- ((get-tests-tags) (db:get-tests-tags dbstruct))
-
- ;; TASKS
- ((tasks-add) (apply tasks:add dbstruct params))
- ((tasks-set-state-given-param-key) (apply tasks:set-state-given-param-key dbstruct params))
- ((tasks-get-last) (apply tasks:get-last dbstruct params))
-
- ;; NO SYNC DB
- ((no-sync-set) (apply db:no-sync-set *no-sync-db* params))
- ((no-sync-get/default) (apply db:no-sync-get/default *no-sync-db* params))
- ((no-sync-del!) (apply db:no-sync-del! *no-sync-db* params))
- ((no-sync-get-lock) (apply db:no-sync-get-lock *no-sync-db* params))
-
- ;; ARCHIVES
- ;; ((archive-get-allocations)
- ((archive-register-disk) (apply db:archive-register-disk dbstruct params))
- ((archive-register-block-name)(apply db:archive-register-block-name dbstruct params))
- ((archive-allocate-testsuite/area-to-block)(apply db:archive-allocate-testsuite/area-to-block dbstruct block-id testsuite-name areakey))
-
- ;;======================================================================
- ;; READ ONLY QUERIES
- ;;======================================================================
-
- ;; KEYS
- ((get-key-val-pairs) (apply db:get-key-val-pairs dbstruct params))
- ((get-keys) (db:get-keys dbstruct))
- ((get-key-vals) (apply db:get-key-vals dbstruct params))
- ((get-target) (apply db:get-target dbstruct params))
- ((get-targets) (db:get-targets dbstruct))
-
- ;; ARCHIVES
- ((test-get-archive-block-info) (apply db:test-get-archive-block-info dbstruct params))
-
- ;; TESTS
- ((test-toplevel-num-items) (apply db:test-toplevel-num-items dbstruct params))
- ((get-test-info-by-id) (apply db:get-test-info-by-id dbstruct params))
- ((test-get-rundir-from-test-id) (apply db:test-get-rundir-from-test-id dbstruct params))
- ((get-count-tests-running-for-testname) (apply db:get-count-tests-running-for-testname dbstruct params))
- ((get-count-tests-running) (apply db:get-count-tests-running dbstruct params))
- ((get-count-tests-running-in-jobgroup) (apply db:get-count-tests-running-in-jobgroup dbstruct params))
- ;; ((delete-test-step-records) (apply db:delete-test-step-records dbstruct params))
- ((get-previous-test-run-record) (apply db:get-previous-test-run-record dbstruct params))
- ((get-matching-previous-test-run-records)(apply db:get-matching-previous-test-run-records dbstruct params))
- ((test-get-logfile-info) (apply db:test-get-logfile-info dbstruct params))
- ((test-get-records-for-index-file) (apply db:test-get-records-for-index-file dbstruct params))
- ((get-testinfo-state-status) (apply db:get-testinfo-state-status dbstruct params))
- ((test-get-top-process-pid) (apply db:test-get-top-process-pid dbstruct params))
- ((test-get-paths-matching-keynames-target-new) (apply db:test-get-paths-matching-keynames-target-new dbstruct params))
- ((get-prereqs-not-met) (apply db:get-prereqs-not-met dbstruct params))
- ((get-count-tests-running-for-run-id) (apply db:get-count-tests-running-for-run-id dbstruct params))
- ((synchash-get) (apply synchash:server-get dbstruct params))
- ((get-raw-run-stats) (apply db:get-raw-run-stats dbstruct params))
- ((get-test-times) (apply db:get-test-times dbstruct params))
-
- ;; RUNS
- ((get-run-info) (apply db:get-run-info dbstruct params))
- ((get-run-status) (apply db:get-run-status dbstruct params))
- ((set-run-status) (apply db:set-run-status dbstruct params))
- ((get-tests-for-run) (apply db:get-tests-for-run dbstruct params))
- ((get-test-id) (apply db:get-test-id dbstruct params))
- ((get-tests-for-run-mindata) (apply db:get-tests-for-run-mindata dbstruct params))
- ((get-tests-for-runs-mindata) (apply db:get-tests-for-runs-mindata dbstruct params))
- ((get-runs) (apply db:get-runs dbstruct params))
- ((simple-get-runs) (apply db:simple-get-runs dbstruct params))
- ((get-num-runs) (apply db:get-num-runs dbstruct params))
- ((get-runs-cnt-by-patt) (apply db:get-runs-cnt-by-patt dbstruct params))
- ((get-all-run-ids) (db:get-all-run-ids dbstruct))
- ((get-prev-run-ids) (apply db:get-prev-run-ids dbstruct params))
- ((get-run-ids-matching-target) (apply db:get-run-ids-matching-target dbstruct params))
- ((get-runs-by-patt) (apply db:get-runs-by-patt dbstruct params))
- ((get-run-name-from-id) (apply db:get-run-name-from-id dbstruct params))
- ((get-main-run-stats) (apply db:get-main-run-stats dbstruct params))
- ((get-var) (apply db:get-var dbstruct params))
- ((get-run-stats) (apply db:get-run-stats dbstruct params))
- ((get-run-times) (apply db:get-run-times dbstruct params))
-
- ;; STEPS
- ((get-steps-data) (apply db:get-steps-data dbstruct params))
- ((get-steps-for-test) (apply db:get-steps-for-test dbstruct params))
- ((get-steps-info-by-id) (apply db:get-steps-info-by-id dbstruct params))
-
- ;; TEST DATA
- ((read-test-data) (apply db:read-test-data dbstruct params))
- ((read-test-data*) (apply db:read-test-data* dbstruct params))
- ((get-data-info-by-id) (apply db:get-data-info-by-id dbstruct params))
-
- ;; MISC
- ((get-latest-host-load) (apply db:get-latest-host-load dbstruct params))
- ((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)))
- ((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
- ((testmeta-get-record) (apply db:testmeta-get-record dbstruct params))
-
- ;; TASKS
- ((find-task-queue-records) (apply tasks:find-task-queue-records dbstruct params))
- (else
- (debug:print 0 *default-log-port* "ERROR: bad api call " cmd)
- (conc "ERROR: BAD api call " cmd))))))
-
- ;; save all stats
- (let ((delta-t (- (current-milliseconds)
- start-t)))
- (hash-table-set! *db-api-call-time* cmd
- (cons delta-t (hash-table-ref/default *db-api-call-time* cmd '()))))
- (if writecmd-in-readonly-mode
- (vector #f res)
- (vector #t res)))))))
-
-;; http-server send-response
-;; api:process-request
-;; db:*
-;;
-;; NB// Runs on the server as part of the server loop
-;;
-(define (api:process-request dbstruct $) ;; the $ is the request vars proc
- (set! *api-process-request-count* (+ *api-process-request-count* 1))
- (let* ((cmd ($ 'cmd))
- (paramsj ($ 'params))
- (params (db:string->obj paramsj transport: 'http)) ;; incoming data from the POST (or is it a GET?)
- (resdat (api:execute-requests dbstruct (vector cmd params))) ;; process the request, resdat = #( flag result )
- (success (vector-ref resdat 0))
- (res (vector-ref resdat 1))) ;; (vector flag payload), get the payload, ignore the flag (why?)
- (if (not success)
- (debug:print 0 *default-log-port* "ERROR: success flag is #f for " cmd " with params " params))
- (if (> *api-process-request-count* *max-api-process-requests*)
- (set! *max-api-process-requests* *api-process-request-count*))
- (set! *api-process-request-count* (- *api-process-request-count* 1))
- ;; This can be here but needs controls to ensure it doesn't run more than every 4 seconds
- ;; (rmt:dat->json-str
- ;; (if (or (string? res)
- ;; (list? res)
- ;; (number? res)
- ;; (boolean? res))
- ;; res
- ;; (list "ERROR, not string, list, number or boolean" 1 cmd params res)))))
- (db:obj->string res transport: 'http)))
-
+(declare (unit api))
+
+(module
+ api
+ (
+ *
+ )
+
+(import scheme posix chicken data-structures ports)
+
+
+(define (api:execute-requests . args) #t)
+(define (api:process-request . args) #t)
+
+)
Index: client.scm
==================================================================
--- client.scm
+++ client.scm
@@ -31,91 +31,86 @@
(declare (uses tasks)) ;; tasks are where stuff is maintained about what is running.
(include "common_records.scm")
(include "db_records.scm")
-;; client:get-signature
-(define (client:get-signature)
- (if *my-client-signature* *my-client-signature*
- (let ((sig (conc (get-host-name) " " (current-process-id))))
- (set! *my-client-signature* sig)
- *my-client-signature*)))
-
-;; Not currently used! But, I think it *should* be used!!!
-(define (client:logout serverdat)
- (let ((ok (and (socket? serverdat)
- (cdb:logout serverdat *toppath* (client:get-signature)))))
- ok))
-
-(define (client:connect iface port)
- (case (server:get-transport)
- ((rpc) (rpc:client-connect iface port))
- ((http) (http:client-connect iface port))
- ((zmq) (zmq:client-connect iface port))
- (else (rpc:client-connect iface port))))
-
-(define (client:setup areapath #!key (remaining-tries 100) (failed-connects 0))
- (case (server:get-transport)
- ((rpc) (rpc-transport:client-setup remaining-tries: remaining-tries failed-connects: failed-connects)) ;;(client:setup-rpc run-id))
- ((http)(client:setup-http areapath remaining-tries: remaining-tries failed-connects: failed-connects))
- (else (rpc-transport:client-setup remaining-tries: remaining-tries failed-connects: failed-connects)))) ;; (client:setup-rpc run-id))))
-
-;; Do all the connection work, look up the transport type and set up the
-;; connection if required.
-;;
-;; There are two scenarios.
-;; 1. We are a test manager and we received *transport-type* and *runremote* via cmdline
-;; 2. We are a run tests, list runs or other interactive process and we must figure out
-;; *transport-type* and *runremote* from the monitor.db
-;;
-;; client:setup
-;;
-;; lookup_server, need to remove *runremote* stuff
-;;
-
-(define (client:setup-http 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")
- (exit 1))
- ;;
- ;; Alternatively here, we can get the list of candidate servers and work our way
- ;; 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))
- (let ((host (cadr server-dat))
- (port (caddr server-dat)))
- (debug:print-info 4 *default-log-port* "client:setup server-dat=" server-dat ", remaining-tries=" remaining-tries)
- (if (and (not area-dat)
- (not *runremote*))
- (set! *runremote* (make-remote)))
- (if (and host port)
- (let* ((start-res (case *transport-type*
- ((http)(http-transport:client-connect host port))))
- (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)
- (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 failed, 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)
- (thread-sleep! 1)
- (client:setup-http 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)))))))))
-
+;; ;; Not currently used! But, I think it *should* be used!!!
+;; (define (client:logout serverdat)
+;; (let ((ok (and (socket? serverdat)
+;; (cdb:logout serverdat *toppath* (client:get-signature)))))
+;; ok))
+;;
+;; (define (client:connect iface port)
+;; (case (server:get-transport)
+;; ((http) (http:client-connect iface port))
+;; ((zmq) (zmq:client-connect iface port))
+;; (else (begin
+;; (debug:print 0 *default-log-port* "ERROR: no such transport " (server:get-transport) ", exiting now.")
+;; (exit 1)))))
+;;
+;; (define (client:setup areapath #!key (remaining-tries 100) (failed-connects 0))
+;; (case (server:get-transport)
+;; ((http)(client:setup-http areapath remaining-tries: remaining-tries failed-connects: failed-connects))
+;; (else (begin
+;; (debug:print 0 *default-log-port* "ERROR: no such transport " (server:get-transport) ", exiting now.")
+;; (exit 1)))))
+;;
+;; ;; Do all the connection work, look up the transport type and set up the
+;; ;; connection if required.
+;; ;;
+;; ;; There are two scenarios.
+;; ;; 1. We are a test manager and we received *transport-type* and *runremote* via cmdline
+;; ;; 2. We are a run tests, list runs or other interactive process and we must figure out
+;; ;; *transport-type* and *runremote* from the monitor.db
+;; ;;
+;; ;; client:setup
+;; ;;
+;; ;; lookup_server, need to remove *runremote* stuff
+;; ;;
+;;
+;; (define (client:setup-http 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")
+;; (exit 1))
+;; ;;
+;; ;; Alternatively here, we can get the list of candidate servers and work our way
+;; ;; 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))
+;; (let ((host (cadr server-dat))
+;; (port (caddr server-dat)))
+;; (debug:print-info 4 *default-log-port* "client:setup server-dat=" server-dat ", remaining-tries=" remaining-tries)
+;; (if (and (not area-dat)
+;; (not *runremote*))
+;; (set! *runremote* (make-remote)))
+;; (if (and host port)
+;; (let* ((start-res (case *transport-type*
+;; ((http)(http-transport:client-connect host port))))
+;; (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)
+;; (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 failed, 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)
+;; (thread-sleep! 1)
+;; (client:setup-http 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)))))))))
+;;
Index: common.scm
==================================================================
--- common.scm
+++ common.scm
@@ -1135,11 +1135,11 @@
;; logic for getting homehost. Returns (host . at-home)
;; IF *toppath* is not set, wait up to five seconds trying every two seconds
;; (this is to accomodate the watchdog)
;;
-(define (common:get-homehost #!key (trynum 5))
+#;(define (common:get-homehost #!key (trynum 5))
;; called often especially at start up. use mutex to eliminate collisions
(mutex-lock! *homehost-mutex*)
(cond
(*home-host*
(mutex-unlock! *homehost-mutex*)
@@ -1187,11 +1187,11 @@
(mutex-unlock! *homehost-mutex*)
*home-host*))))
;; am I on the homehost?
;;
-(define (common:on-homehost?)
+#;(define (common:on-homehost?)
(let ((hh (common:get-homehost)))
(if hh
(cdr hh)
#f)))
Index: db.scm
==================================================================
--- db.scm
+++ db.scm
@@ -22,136 +22,94 @@
;; 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:))
-
-(declare (unit db))
-(declare (uses common))
-(declare (uses keys))
-(declare (uses ods))
-(declare (uses client))
-(declare (uses mt))
-
-(include "common_records.scm")
-(include "db_records.scm")
-(include "key_records.scm")
-(include "run_records.scm")
-
-(define *rundb-mutex* (make-mutex)) ;; prevent problems opening/closing rundb's
-(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)
- ) ;; goal is to converge on one struct for an area but for now it is too confusing
-
-
-;; record for keeping state,status and count for doing roll-ups in
-;; iterated tests
-;;
-(defstruct dbr:counts
- (state #f)
- (status #f)
- (count 0))
-
-;;======================================================================
-;; SQLITE3 HELPERS
-;;======================================================================
-
-(define (db:general-sqlite-error-dump exn stmt . params)
- (let ((err-status ((condition-property-accessor 'sqlite3 'status #f) exn))) ;; RADT ... how does this work?
- ;; check for (exn sqlite3) ((condition-property-accessor 'exn 'message) exn)
- (print "err-status: " err-status)
- (debug:print-error 0 *default-log-port* " query " stmt " failed, params: " params ", error: " ((condition-property-accessor 'exn 'message) exn))
- (print-call-chain (current-error-port))))
-
-;; convert to -inline
-;;
-(define (db:first-result-default db stmt default . params)
- (handle-exceptions
- exn
- (let ((err-status ((condition-property-accessor 'sqlite3 'status #f) exn)))
- ;; check for (exn sqlite3) ((condition-property-accessor 'exn 'message) exn)
- (if (eq? err-status 'done)
- default
- (begin
- (debug:print-error 0 *default-log-port* " query " stmt " failed, params: " params ", error: " ((condition-property-accessor 'exn 'message) exn))
- (print-call-chain (current-error-port))
- default)))
- (apply sqlite3:first-result db stmt params)))
-
-;; Get/open a database
-;; if run-id => get run specific db
-;; if #f => get main db
-;; if db already open - return inmem
-;; if db not open, open inmem, rundb and sync then return inmem
-;; inuse gets set automatically for rundb's
-;;
-(define (db:get-db dbstruct) ;; run-id)
- (if (stack? (dbr:dbstruct-dbstack dbstruct))
- (if (stack-empty? (dbr:dbstruct-dbstack dbstruct))
- (let ((newdb (db:open-megatest-db path: (db:dbfile-path))))
- ;; (stack-push! (dbr:dbstruct-dbstack dbstruct) newdb)
- newdb)
- (stack-pop! (dbr:dbstruct-dbstack dbstruct)))
- (db:open-db dbstruct)))
-
-;; ;; legacy handling of structure for managing db's. Refactor this into dbr:?
-(define (db:dbdat-get-db dbdat)
- (if (pair? dbdat)
- (car dbdat)
- dbdat))
-
-(define (db:dbdat-get-path dbdat)
- (if (pair? dbdat)
- (cdr dbdat)
- #f))
-
-;; mod-read:
-;; 'mod modified data
-;; 'read read data
-;; Locks the mutex and depending on 'mod or 'read passed, sets the last timestamp in dbstruct
-;;
-;; (define (db:done-with dbstruct run-id mod-read)
-;; (if (not (sqlite3:database? dbstruct))
-;; (begin
-;; (mutex-lock! *rundb-mutex*)
-;; (if (eq? mod-read 'mod)
-;; (dbr:dbstruct-mtime-set! dbstruct (current-milliseconds))
-;; (dbr:dbstruct-rtime-set! dbstruct (current-milliseconds)))
-;; (dbr:dbstruct-inuse-set! dbstruct #f)
-;; (mutex-unlock! *rundb-mutex*))))
-
-;; (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))
+(declare (unit db))
+
+(module db
+ (
+ *
+ )
+
+(import scheme posix chicken data-structures ports)
+
+(use (prefix sqlite3 sqlite3:)
+ (srfi 18) extras tcp stack srfi-1 posix regex regex-case srfi-69
+ csv-xml s11n md5 message-digest base64 format dot-locking z3
+ typed-records matchable
+ (prefix base64 base64:))
+
+;;======================================================================
+;;
+;;======================================================================
+
+(defstruct dbinfo
+ (mtrah #f)
+ (dbpath #f)
+ (maindb #f)
+ (dbfile #f)
+ (writeable #f)
+ (rundbs (make-hash-table)) ;; id => #(dbhandle readq writeq)
+ (stats (make-hash-table))
+ (mreadq (make-queue)) ;; read queue for main.db
+ (mwriteq (make-queue)) ;; write queue for main.db
+ (localq (make-queue)) ;; queue for cpuload, numcores and other OS requests
+ (respq (make-queue)) ;; queue for responses
+ )
+
+(defstruct rundbinfo
+ (rundb #f) ;; db handle
+ (dbfile #f)
+ (readq (make-queue))
+ (writeq (make-queue))
+ (sdbcache (make-hash-table)) ;; cache the id => strings as we read them
+ (stats (make-hash-table))
+ )
+
+(defstruct request
+ (srchost #f)
+ (srcport #f)
+ (reqtype #f) ;; read, write, local
+ (response #f)
+ (status 'new)
+ (start (current-milliseconds)))
+
+;; create a dbinfo record initialized to a specific Megatest area
+;;
+(define (db:create-dbinfo mtrah)
+ (make-dbinfo mtrah: mtrah dbpath: (conc mtrah "/.mtdb")))
+
+(define (db:get-open-db dbinfo run-id #!key (dbpath #f))
+ (let* ((dbpath (dbinfo-dbpath dbinfo))
+ (ismain (if (number? run-id) #f #t))
+ (dbname (if run-id (conc run-id ".db") "main.db")) ;; can use string for run-id
+ (dbfile (conc dbpath "/" dbname))
+ (dbexists (file-exists? dbfile))
+ (readable (file-read-access? dbpath)) ;; should be safe to assume can read db file
+ (writeable (file-write-access? dbpath)))
+ ;; handle error conditions
+ (cond
+ ((and (not dbexists) (not writeable))(values #f "No db file and no write access"))
+ ((not readable) (values #f "No read access"))
+ (else
+ ;; TODO - transfer over the error handling from MT1.65 db:lock-create-open
+ (let ((db (sqlite3:open-database dbfile)))
+ (if (not dbexists)(db:initialize-db db))
+ ;; now deal with the added structure for run-id based db if needed
+ (if ismain
+ (begin
+ (dbinfo-maindb-set! dbinfo db)
+ (dbinfo-writeable-set! dbinfo writeable))
+ (let ((runrec (or (hash-table-ref/default (dbinfo-rundbs dbinfo) run-id (make-rundbinfo rundb: db dbfile: dbfile)))))
+ (hash-table-set! (dbinfo-rundbs dbinfo) run-id runrec)))
+ (values #t "Success"))))))
+
+;; dbinfo must have been initiatized with the dbpath
+;;
+#;(define (db:with-db dbinfo run-id proc . params)
+ (let* ((db (db:get-open-db dbinfo run-id))
(use-mutex (> *api-process-request-count* 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*))
@@ -168,1081 +126,52 @@
(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))))
-;;======================================================================
-;; 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.
-;;
-(define db:dbfile-path common:get-db-tmp-area)
-
-(define (db:set-sync db)
- (let ((syncprag (configf:lookup *configdat* "setup" "sychronous")))
- (sqlite3:execute db (conc "PRAGMA synchronous = " (or syncprag 0) ";"))))
-
-;; open an sql database inside a file lock
-;; returns: db existed-prior-to-opening
-;; RA => Returns a db handler; sets the lock if opened in writable mode
-;;
-;; (define *db-open-mutex* (make-mutex))
-
-(define (db:lock-create-open fname initproc)
- (let* ((parent-dir (or (pathname-directory fname)(current-directory))) ;; no parent? go local
- (raw-fname (pathname-file fname))
- (dir-writable (file-write-access? parent-dir))
- (file-exists (common:file-exists? fname))
- (file-write (if file-exists
- (file-write-access? fname)
- dir-writable )))
- ;; (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 (make-busy-timeout 136000))
- (sqlite3:execute db "PRAGMA synchronous = 0;")
- (if (not file-exists)
- (begin
-
- (if (and (configf:lookup *configdat* "setup" "use-wal")
- (string-match "^/tmp/.*" fname)) ;; this is a file in /tmp
- (sqlite3:execute db "PRAGMA journal_mode=WAL;")
- (debug:print 2 *default-log-port* "Creating " fname " in NON-WAL mode."))
- (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) (debug:print 0 *default-log-port* "ERROR: i/o error with " fname ". Check permissions, disk space etc. and try again."))
- (exn (corrupt) (debug:print 0 *default-log-port* "ERROR: database " fname " is corrupt. Repair it to proceed."))
- (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))))
-
- (condition-case
- (begin
- (debug:print 2 *default-log-port* "WARNING: opening db in non-writable dir " fname)
- (let ((db (sqlite3:open-database fname)))
- ;; (mutex-unlock! *db-open-mutex*)
- db))
- (exn (io-error) (debug:print 0 *default-log-port* "ERROR: i/o error with " fname ". Check permissions, disk space etc. and try again."))
- (exn (corrupt) (debug:print 0 *default-log-port* "ERROR: database " fname " is corrupt. Repair it to proceed."))
- (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. It is only called if the db is not already opened
-;; ;;
-;; (define (db:open-rundb dbstruct run-id #!key (attemptnum 0)(do-not-open #f)) ;; (conc *toppath* "/megatest.db") (car *configinfo*)))
-;; (let* ((dbfile (db:dbfile-path run-id)) ;; (conc toppath "/db/" run-id ".db"))
-;; (dbexists (common:file-exists? dbfile))
-;; (db (db:lock-create-open dbfile (lambda (db)
-;; (handle-exceptions
-;; exn
-;; (begin
-;; ;; (release-dot-lock dbpath)
-;; (if (> attemptnum 2)
-;; (debug:print-error 0 *default-log-port* "tried twice, cannot create/initialize db for run-id " run-id ", at path " dbpath)
-;; (db:open-rundb dbstruct run-id attemptnum (+ attemptnum 1))))
-;; (db:initialize-run-id-db db)
-;; (sqlite3:execute
-;; db
-;; "INSERT OR IGNORE INTO tests (id,run_id,testname,event_time,item_path,state,status) VALUES (?,?,'bogustest',strftime('%s','now'),'nowherepath','DELETED','n/a');"
-;; (* run-id 30000) ;; allow for up to 30k tests per run
-;; run-id)
-;; ;; do a dummy query to test that the table exists and the db is truly readable
-;; (sqlite3:execute db "SELECT * FROM tests WHERE id=?;" (* run-id 30000))
-;; )))) ;; add strings db to rundb, not in use yet
-;; (olddb (if *megatest-db*
-;; *megatest-db*
-;; (let ((db (db:open-megatest-db)))
-;; (set! *megatest-db* db)
-;; db)))
-;; (write-access (file-write-access? dbfile)))
-;; (if (and dbexists (not write-access))
-;; (set! *db-write-access* #f)) ;; only unset so other db's also can use this control
-;; (dbr:dbstruct-rundb-set! dbstruct (cons db dbfile))
-;; (dbr:dbstruct-inuse-set! dbstruct #t)
-;; (dbr:dbstruct-olddb-set! dbstruct olddb)
-;; ;;; (mutex-unlock! *rundb-mutex*) ;;; why did we need a mutex on opening db's?
-;; (db:sync-tables db:sync-tests-only *megatest-db* db)
-;; db))
-
-;; This routine creates the db if not already present. It is only called if the db is not already opened
-;;
-(define (db:open-db dbstruct #!key (areapath #f)(do-sync #t)) ;; TODO: actually use areapath
- (let ((tmpdb-stack (dbr:dbstruct-dbstack dbstruct))) ;; RA => Returns the first reference in dbstruct
- (if (stack? tmpdb-stack)
- (db:get-db tmpdb-stack) ;; get previously opened db (will create new db handle if all in the stack are already used
- (let* ((dbpath (db:dbfile-path )) ;; path to tmp db area
- (dbexists (common:file-exists? dbpath))
- (tmpdbfname (conc dbpath "/megatest.db"))
- (dbfexists (common:file-exists? tmpdbfname)) ;; (conc dbpath "/megatest.db")))
- (mtdbexists (common:file-exists? (conc *toppath* "/megatest.db")))
-
- (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))
- (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"))
-
- ;(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)
- ;; (mutex-unlock! *rundb-mutex*)
- (if (and (or (not dbfexists)
- (and modtimedelta
- (> modtimedelta 10))) ;; 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-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
- 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))))
-
-;; Open the classic megatest.db file (defaults to open in toppath)
-;;
-;; NOTE: returns a dbdat not a dbstruct!
-;;
-(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))
- (db (db:lock-create-open dbpath
- (lambda (db)
- (db:initialize-main-db db)
- ;;(db:initialize-run-id-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 #!key (try-num 3))
- (if (<= try-num 0)
- #f
- (handle-exceptions
- exn
- (begin
- (thread-sleep! 3)
- (sqlite3:interrupt! db)
- (db:safely-close-sqlite3-db db try-num: (- try-num 1)))
- (if (sqlite3:database? db)
- (begin
- (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))
- (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))))
- (map (lambda (db)
- (db:safely-close-sqlite3-db db))
-;; (if (sqlite3:database? db)
-;; (sqlite3:finalize! db)))
- tdbs)
- (db:safely-close-sqlite3-db mdb) ;; (if (sqlite3:database? mdb) (sqlite3:finalize! mdb))
- (db:safely-close-sqlite3-db rdb))))) ;; (if (sqlite3:database? rdb) (sqlite3:finalize! rdb))))))
-
-;; (let ((locdbs (dbr:dbstruct-locdbs dbstruct)))
-;; (if (hash-table? locdbs)
-;; (for-each (lambda (run-id)
-;; (db:close-run-db dbstruct run-id))
-;; (hash-table-keys locdbs)))))
-
-;; (define (db:open-inmem-db)
-;; (let* ((db (sqlite3:open-database ":memory:"))
-;; (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 "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))
- (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))))
- (debug:print-error 0 *default-log-port* "" fname " appears corrupted. Making backup \"old/" fname "\"")
- (system (conc "cd " dbdir ";mkdir -p old;cat " fname " > old/" tmpname))
- (system (conc "rm -f " dbpath))
- (if (common:file-exists? fnamejnl)
- (begin
- (debug:print-error 0 *default-log-port* "" fnamejnl " found, moving it to old dir as " tmpjnl)
- (system (conc "cd " dbdir ";mkdir -p old;cat " fnamejnl " > old/" tmpjnl))
- (system (conc "rm -f " dbdir "/" fnamejnl))))
- ;; attempt to recreate database
- (system (conc "cd " dbdir ";sqlite3 old/" tmpname " .dump | sqlite3 " fname))))
-
-;; 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))
- (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))
- (debug:print 0 *default-log-port* "WARNING: can't write to " dbdir ", can't fix " fname)
- #f)
-
- ;; handle special cases, megatest.db and monitor.db
- ;;
- ;; NOPE: apply this same approach to all db files
- ;;
- (else ;; ((equal? fname "megatest.db") ;; this file can be regenerated if needed
- (handle-exceptions
- exn
- (begin
- ;; (db:move-and-recreate-db dbdat)
- (if (> numtries 0)
- (db:repair-db dbdat numtries: (- numtries 1))
- #f)
- (debug:print 0 *default-log-port* "FATAL: file " dbpath " was found corrupted, an attempt to fix has been made but you must start over.")
- (debug:print 0 *default-log-port*
- " check the following:\n"
- " 1. full directories, look in ~/ /tmp and " dbdir "\n"
- " 2. write access to " dbdir "\n\n"
- " if the automatic recovery failed you may be able to recover data by doing \""
- (if (member fname '("megatest.db" "monitor.db"))
- "megatest -cleanup-db"
- "megatest -import-megatest.db;megatest -cleanup-db")
- "\"\n")
- (exit) ;; we can not safely continue when a db was corrupted - even if fixed.
- )
- ;; test read/write access to the database
- (let ((db (sqlite3:open-database dbpath)))
- (cond
- ((equal? fname "megatest.db")
- (sqlite3:execute db "DELETE FROM tests WHERE state='DELETED';"))
- ((equal? fname "main.db")
- (sqlite3:execute db "DELETE FROM runs WHERE state='deleted';"))
- ((string-match "\\d.db" fname)
- (sqlite3:execute db "UPDATE tests SET state='DELETED' WHERE state='DELETED';"))
- ((equal? fname "monitor.db")
- (sqlite3:execute "DELETE FROM servers WHERE state LIKE 'defunct%';"))
- (else
- (sqlite3:execute db "vacuum;")))
-
- (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)
-
- (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))
- (stmth (sqlite3:prepare db full-ins)))
- (db:delay-if-busy targdb) ;; NO WAITING
- (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)))
- (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
- ;;
- (for-each
- (lambda (table-name)
- (handle-exceptions
- exn
- (if (string-match ".*duplicate.*" ((condition-property-accessor 'exn 'message) exn))
- (debug:print 0 *default-log-port* "Column last_update already added to " table-name " table")
- (db:general-sqlite-error-dump exn "alter table " table-name " ..." #f "none"))
- (sqlite3:execute
- frundb
- (conc "ALTER TABLE " table-name " ADD COLUMN last_update INTEGER DEFAULT 0")))
- (sqlite3:execute
- frundb
- (conc "DROP TRIGGER IF EXISTS update_" table-name "_trigger;"))
- (sqlite3:execute
- frundb
- (conc "CREATE TRIGGER IF NOT EXISTS update_" table-name "_trigger AFTER UPDATE ON " table-name "
- FOR EACH ROW
- BEGIN
- UPDATE " table-name " SET last_update=(strftime('%s','now'))
- WHERE id=old.id;
- END;"))
- )
- '("tests" "test_steps" "test_data")))
-
-(define (db:patch-schema-maindb maindb)
- ;;
- ;; remove all these some time after september 2016 (added in v1.6031
- ;;
- (for-each
- (lambda (column type default)
- (handle-exceptions
- exn
- (if (string-match ".*duplicate.*" ((condition-property-accessor 'exn 'message) exn))
- (debug:print 0 *default-log-port* "Column " column " already added to runs table")
- (db:general-sqlite-error-dump exn "alter table runs ..." #f "none"))
- (sqlite3:execute
- maindb
- (conc "ALTER TABLE runs ADD COLUMN " column " " type " DEFAULT " default))))
- (list "last_update" "contour")
- (list "INTEGER" "TEXT" )
- (list "0" "''" ))
- ;; these schema changes don't need exception handling
- (sqlite3:execute
- maindb
- "CREATE TRIGGER IF NOT EXISTS update_runs_trigger AFTER UPDATE ON runs
+(define (db:initialize-db db)
+ (sqlite3:with-transaction
+ db
+ (lambda ()
+ (sqlite3:execute db "CREATE TABLE IF NOT EXISTS ttype (
+ id SERIAL PRIMARY KEY,
+ target_spec TEXT DEFAULT '');")
+ (sqlite3:execute db "CREATE TABLE IF NOT EXISTS runs (
+ id INTEGER PRIMARY KEY,
+ target TEXT DEFAULT 'nodata',
+ ttype_id INTEGER DEFAULT 0,
+ run_name TEXT DEFAULT 'norun',
+ contour TEXT DEFAULT '',
+ state TEXT DEFAULT '',
+ status TEXT DEFAULT '',
+ owner TEXT DEFAULT '',
+ event_time TIMESTAMP DEFAULT (strftime('%s','now')),
+ comment TEXT DEFAULT '',
+ fail_count INTEGER DEFAULT 0,
+ pass_count INTEGER DEFAULT 0,
+ last_update INTEGER DEFAULT (strftime('%s','now')),
+ CONSTRAINT runsconstraint UNIQUE (target,ttype_id,run_name, area_id));")
+ (sqlite3:execute db "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;")
- (sqlite3:execute maindb "CREATE TABLE IF NOT EXISTS run_stats (
+ (sqlite3:execute db "CREATE TABLE IF NOT EXISTS run_stats (
id INTEGER PRIMARY KEY,
run_id INTEGER,
state TEXT,
status TEXT,
count INTEGER,
last_update INTEGER DEFAULT (strftime('%s','now')))")
- (sqlite3:execute maindb "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;")
- (sqlite3:execute maindb "CREATE TABLE IF NOT EXISTS test_rundat (
- id INTEGER PRIMARY KEY,
- test_id INTEGER,
- update_time TIMESTAMP,
- cpuload INTEGER DEFAULT -1,
- diskfree INTEGER DEFAULT -1,
- diskusage INTGER DEFAULT -1,
- run_duration INTEGER DEFAULT 0);"))
-
-(define (db:adj-target db)
- (let ((fields (configf:get-section *configdat* "fields"))
- (field-num 0))
- ;; because we will be refreshing the keys table it is best to clear it here
- (sqlite3:execute db "DELETE FROM keys;")
- (for-each
- (lambda (field)
- (let ((column (car field))
- (spec (cadr field)))
- (handle-exceptions
- exn
- (if (string-match ".*duplicate.*" ((condition-property-accessor 'exn 'message) exn))
- (debug:print 0 *default-log-port* "Target field " column " already exists in the runs table")
- (db:general-sqlite-error-dump exn "alter table runs ..." #f "none"))
- ;; Add the column if needed
- (sqlite3:execute
- db
- (conc "ALTER TABLE runs ADD COLUMN " column " " spec)))
- ;; correct the entry in the keys column
- (sqlite3:execute
- db
- "INSERT INTO keys (id,fieldname,fieldtype) VALUES (?,?,?);"
- field-num column spec)
- ;; fill in blanks (not allowed as it would be part of the path
- (sqlite3:execute
- db
- (conc "UPDATE runs SET " column "='x' WHERE " column "='';"))
- (set! field-num (+ field-num 1))))
- fields)))
-
-(define *global-db-store* (make-hash-table))
-
-(define (db:get-access-mode)
- (if (args:get-arg "-use-db-cache") 'cached 'rmt))
-
-;; Add db direct
-;;
-(define (db:dispatch-query access-mode rmt-cmd db-cmd . params)
- (if (eq? access-mode 'cached)
- (debug:print 2 *default-log-port* "not doing cached calls right now"))
-;; (apply db:call-with-cached-db db-cmd params)
- (apply rmt-cmd params))
-;;)
-
-;; return the target db handle so it can be used
-;;
-(define (db:cache-for-read-only source target #!key (use-last-update #f))
- (if (and (hash-table-ref/default *global-db-store* target #f)
- (>= (file-modification-time target)(file-modification-time source)))
- (hash-table-ref *global-db-store* target)
- (let* ((toppath (launch:setup))
- (targ-db-last-mod (if (common:file-exists? target)
- (file-modification-time target)
- 0))
- (cache-db (or (hash-table-ref/default *global-db-store* target #f)
- (db:open-megatest-db path: target)))
- (source-db (db:open-megatest-db path: source))
- (curr-time (current-seconds))
- (res '())
- (last-update (if use-last-update (cons "last_update" targ-db-last-mod) #f)))
- (db:sync-tables (db:sync-main-list source-db) last-update source-db cache-db)
- (db:sync-tables db:sync-tests-only last-update source-db cache-db)
- (hash-table-set! *global-db-store* target cache-db)
- cache-db)))
-
-;; ;; call a proc with a cached db
-;; ;;
-;; (define (db:call-with-cached-db proc . params)
-;; ;; first cache the db in /tmp
-;; (let* ((cname-part (conc "megatest_cache/" (common:get-testsuite-name)))
-;; (fname (conc (common:get-area-path-signature) ".db"))
-;; (cache-dir (common:get-create-writeable-dir
-;; (list (conc "/tmp/" (current-user-name) "/" cname-part)
-;; (conc "/tmp/" (current-user-name) "-" cname-part)
-;; (conc "/tmp/" (current-user-name) "_" cname-part))))
-;; (megatest-db (conc *toppath* "/megatest.db")))
-;; ;; (debug:print-info 0 *default-log-port* "Using cache dir " cache-dir)
-;; (if (not cache-dir)
-;; (begin
-;; (debug:print 0 *default-log-port* "ERROR: Failed to find an area to write the cache db")
-;; (exit 1))
-;; (let* ((th1 (make-thread
-;; (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"))))
-;; "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)
-;; ))))
-
-;; options:
-;;
-;; 'killservers - kills all servers
-;; 'dejunk - removes junk records
-;; 'adj-testids - move test-ids into correct ranges
-;; 'old2new - sync megatest.db to /tmp/.../megatest.db and /tmp/.../megatest_ref.db
-;; 'new2old - sync /tmp/.../megatest.db to megatest.db and /tmp/.../megatest_ref.db (and update data_synced)
-;; '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
- (lambda (server)
- (match-let (((mod-time host port start-time pid) server))
- (if (and host pid)
- (tasks:kill-server host pid))))
- servers))
-
- ;; clear out junk records
- ;;
- ((dejunk)
- (db:delay-if-busy mtdb) ;; ok to delay on 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)
- res))
-
-;;;; run-ids
-;; if #f use *db-local-sync* : or 'local-sync-flags
-;; if #t use timestamps : or 'timestamps
-;;
-;; NB// no-sync-db is the db handle, not a flag!
-;;
-(define (db:sync-to-megatest.db dbstruct #!key (no-sync-db #f))
- (let* ((start-time (current-seconds))
- (last-full-update (if no-sync-db
- (db:no-sync-get/default no-sync-db "LAST_FULL_UPDATE" 0)
- 0))
- (full-sync-needed (> (- start-time last-full-update) 3600)) ;; every hour do a full sync
- (last-update (if full-sync-needed
- 0
- (if no-sync-db
- (db:no-sync-get/default no-sync-db "LAST_UPDATE" 0)
- 0))) ;; (or (db:get-var dbstruct "LAST_UPDATE") 0))
- (sync-needed (> (- start-time last-update) 6))
- (res (if (or sync-needed ;; don't sync if a sync already occurred in the past 6 seconds
- full-sync-needed)
- (begin
- (if no-sync-db
- (begin
- (if full-sync-needed (db:no-sync-set no-sync-db "LAST_FULL_UPDATE" start-time))
- (db:no-sync-set no-sync-db "LAST_UPDATE" start-time)))
- (db:tmp->megatest.db-sync dbstruct last-update))
- 0))
- (sync-time (- (current-seconds) start-time)))
- (debug:print-info 3 *default-log-port* "Sync of newdb to olddb completed in " sync-time " seconds pid="(current-process-id))
- (if (common:low-noise-print 30 "sync new to old")
- (if sync-needed
- (debug:print-info 0 *default-log-port* "Sync of " res " records from newdb to olddb completed in " sync-time " seconds pid="(current-process-id))
- (debug:print-info 0 *default-log-port* "No sync needed, last updated " (- start-time last-update) " seconds ago")))
- res))
-
-;; keeping it around for debugging purposes only
-(define (open-run-close-no-exception-handling proc idb . params)
- (debug:print-info 11 *default-log-port* "open-run-close-no-exception-handling START given a db=" (if idb "yes " "no ") ", params=" params)
- (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))
- ((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))
- (set! res (apply proc db params))
- (if (not idb)(sqlite3:finalize! dbstruct))
- (debug:print-info 11 *default-log-port* "open-run-close-no-exception-handling END" )
- res)
- #f))
-
-(define (open-run-close-exception-handling proc idb . params)
- (handle-exceptions
- exn
- (let ((sleep-time (random 30))
- (err-status ((condition-property-accessor 'sqlite3 'status #f) exn)))
- (case err-status
- ((busy)
- (thread-sleep! sleep-time))
- (else
- (debug:print 0 *default-log-port* "EXCEPTION: database probably overloaded or unreadable.")
- (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))
- (print-call-chain (current-error-port))
- (thread-sleep! sleep-time)
- (debug:print-info 0 *default-log-port* "trying db call one more time....this may never recover, if necessary kill process " (current-process-id) " on host " (get-host-name) " to clean up")))
- (apply open-run-close-exception-handling proc idb params))
- (apply open-run-close-no-exception-handling proc idb params)))
-
-;; (define open-run-close
-(define open-run-close open-run-close-exception-handling)
- ;; open-run-close-no-exception-handling
-;; open-run-close-exception-handling)
-;;)
-
-(define (db:initialize-main-db dbdat)
- (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)))
- (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"))
- (begin
- (print "ERROR: your key cannot be named " keyn " as this conflicts with the same named field in the runs table, you must remove your megatest.db and /.db before trying again.")
- (exit 1)))))
- keys)
- (sqlite3:with-transaction
- db
- (lambda ()
- ;; handle-exceptions
- ;; exn
- ;; (begin
- ;; (debug:print 0 "ERROR: Failed to create tables. Look at your [fields] section, should be: fieldname TEXT DEFAULT 'yourdefault'")
- ;; (exit))
- (sqlite3:execute db "CREATE TABLE IF NOT EXISTS keys (id INTEGER PRIMARY KEY, fieldname TEXT, fieldtype TEXT, CONSTRAINT keyconstraint UNIQUE (fieldname));")
- (for-each (lambda (key)
- (sqlite3:execute db "INSERT OR REPLACE INTO keys (fieldname,fieldtype) VALUES (?,?);" key "TEXT"))
- keys)
- (sqlite3:execute db (conc
- "CREATE TABLE IF NOT EXISTS runs (id INTEGER PRIMARY KEY, \n "
- fieldstr (if havekeys "," "") "
- runname TEXT DEFAULT 'norun',
- contour TEXT DEFAULT '',
- state TEXT DEFAULT '',
- status TEXT DEFAULT '',
- owner TEXT DEFAULT '',
- event_time TIMESTAMP DEFAULT (strftime('%s','now')),
- comment TEXT DEFAULT '',
- fail_count INTEGER DEFAULT 0,
- pass_count INTEGER DEFAULT 0,
- last_update INTEGER DEFAULT (strftime('%s','now')),
- CONSTRAINT runsconstraint UNIQUE (runname" (if havekeys "," "") keystr "));"))
- (sqlite3:execute db "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;")
- (sqlite3:execute db "CREATE TABLE IF NOT EXISTS run_stats (
- id INTEGER PRIMARY KEY,
- run_id INTEGER,
- state TEXT,
- status TEXT,
- count INTEGER,
- last_update INTEGER DEFAULT (strftime('%s','now')))")
- (sqlite3:execute db "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;")
- (sqlite3:execute db "CREATE TABLE IF NOT EXISTS test_meta (
+ (sqlite3:execute db "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;")
+ (sqlite3:execute db "CREATE TABLE IF NOT EXISTS test_meta (
id INTEGER PRIMARY KEY,
testname TEXT DEFAULT '',
author TEXT DEFAULT '',
owner TEXT DEFAULT '',
description TEXT DEFAULT '',
@@ -1251,11 +180,11 @@
avg_runtime REAL,
avg_disk REAL,
tags TEXT DEFAULT '',
jobgroup TEXT DEFAULT 'default',
CONSTRAINT test_meta_constraint UNIQUE (testname));")
- (sqlite3:execute db "CREATE TABLE IF NOT EXISTS tasks_queue (id INTEGER PRIMARY KEY,
+ (sqlite3:execute db "CREATE TABLE IF NOT EXISTS tasks_queue (id INTEGER PRIMARY KEY,
action TEXT DEFAULT '',
owner TEXT,
state TEXT DEFAULT 'new',
target TEXT DEFAULT '',
name TEXT DEFAULT '',
@@ -1262,57 +191,54 @@
testpatt TEXT DEFAULT '',
keylock TEXT,
params TEXT,
creation_time TIMESTAMP DEFAULT (strftime('%s','now')),
execution_time TIMESTAMP);")
- ;; archive disk areas, cached info from [archive-disks]
- (sqlite3:execute db "CREATE TABLE IF NOT EXISTS archive_disks (
+ ;; archive disk areas, cached info from [archive-disks]
+ (sqlite3:execute db "CREATE TABLE IF NOT EXISTS archive_disks (
id INTEGER PRIMARY KEY,
archive_area_name TEXT,
disk_path TEXT,
last_df INTEGER DEFAULT -1,
last_df_time TIMESTAMP DEFAULT (strftime('%s','now')),
creation_time TIMESTAMP DEFAULT (strftime('%','now')));")
- ;; individual bup (or tar) data chunks
- (sqlite3:execute db "CREATE TABLE IF NOT EXISTS archive_blocks (
+ ;; individual bup (or tar) data chunks
+ (sqlite3:execute db "CREATE TABLE IF NOT EXISTS archive_blocks (
id INTEGER PRIMARY KEY,
archive_disk_id INTEGER,
disk_path TEXT,
last_du INTEGER DEFAULT -1,
last_du_time TIMESTAMP DEFAULT (strftime('%s','now')),
creation_time TIMESTAMP DEFAULT (strftime('%','now')));")
- ;; tests allocated to what chunks. reusing a chunk for a test/item_path is very efficient
- ;; NB// the per run/test recording of where the archive is stored is done in the test
- ;; record.
- (sqlite3:execute db "CREATE TABLE IF NOT EXISTS archive_allocations (
+ ;; tests allocated to what chunks. reusing a chunk for a test/item_path is very efficient
+ ;; NB// the per run/test recording of where the archive is stored is done in the test
+ ;; record.
+ (sqlite3:execute db "CREATE TABLE IF NOT EXISTS archive_allocations (
id INTEGER PRIMARY KEY,
archive_block_id INTEGER,
testname TEXT,
item_path TEXT,
creation_time TIMESTAMP DEFAULT (strftime('%','now')));")
- ;; move this clean up call somewhere else
- (sqlite3:execute db "DELETE FROM tasks_queue WHERE state='done' AND creation_time < ?;" (- (current-seconds)(* 24 60 60))) ;; remove older than 24 hrs
- (sqlite3:execute db (conc "CREATE INDEX IF NOT EXISTS runs_index ON runs (runname" (if havekeys "," "") keystr ");"))
- ;; (sqlite3:execute db "CREATE VIEW runs_tests AS SELECT * FROM runs INNER JOIN tests ON runs.id=tests.run_id;")
- (sqlite3:execute db "CREATE TABLE IF NOT EXISTS extradat (id INTEGER PRIMARY KEY, run_id INTEGER, key TEXT, val TEXT);")
- (sqlite3:execute db "CREATE TABLE IF NOT EXISTS metadat (id INTEGER PRIMARY KEY, var TEXT, val TEXT,
+ ;; move this clean up call somewhere else
+ (sqlite3:execute db "DELETE FROM tasks_queue WHERE state='done' AND creation_time < ?;" (- (current-seconds)(* 24 60 60))) ;; remove older than 24 hrs
+ (sqlite3:execute db (conc "CREATE INDEX IF NOT EXISTS runs_index ON runs (runname);")) ;; (if havekeys "," "") keystr ");"))
+ ;; (sqlite3:execute db "CREATE VIEW runs_tests AS SELECT * FROM runs INNER JOIN tests ON runs.id=tests.run_id;")
+ (sqlite3:execute db "CREATE TABLE IF NOT EXISTS extradat (id INTEGER PRIMARY KEY, run_id INTEGER, key TEXT, val TEXT);")
+ (sqlite3:execute db "CREATE TABLE IF NOT EXISTS metadat (id INTEGER PRIMARY KEY, var TEXT, val TEXT,
CONSTRAINT metadat_constraint UNIQUE (var));")
- (sqlite3:execute db "CREATE TABLE IF NOT EXISTS access_log (id INTEGER PRIMARY KEY, user TEXT, accessed TIMESTAMP, args TEXT);")
- ;; Must do this *after* running patch db !! No more.
- ;; cannot use db:set-var since it will deadlock, hardwire the code here
- (sqlite3:execute db "INSERT OR REPLACE INTO metadat (var,val) VALUES (?,?);" "MEGATEST_VERSION" (common:version-signature))
- (debug:print-info 11 *default-log-port* "db:initialize END") ;; ))))
-
- ;;======================================================================
- ;; R U N S P E C I F I C D B
- ;;======================================================================
-
- ;; (define (db:initialize-run-id-db db)
- ;; (sqlite3:with-transaction
- ;; db
- ;; (lambda ()
- (sqlite3:execute db "CREATE TABLE IF NOT EXISTS tests
+ (sqlite3:execute db "CREATE TABLE IF NOT EXISTS access_log (id INTEGER PRIMARY KEY, user TEXT, accessed TIMESTAMP, args TEXT);")
+ ;; Must do this *after* running patch db !! No more.
+ ;; cannot use db:set-var since it will deadlock, hardwire the code here
+
+ ;; ERROR: Cannot do this here - must update from Megatest itself, not from mtserver
+ ;; (sqlite3:execute db "INSERT OR REPLACE INTO metadat (var,val) VALUES (?,?);" "MEGATEST_VERSION" (common:version-signature))
+
+ ;;======================================================================
+ ;; R U N S P E C I F I C D B
+ ;;======================================================================
+
+ (sqlite3:execute db "CREATE TABLE IF NOT EXISTS tests
(id INTEGER PRIMARY KEY,
run_id INTEGER DEFAULT -1,
testname TEXT DEFAULT 'noname',
host TEXT DEFAULT 'n/a',
cpuload REAL DEFAULT -1,
@@ -1332,11 +258,16 @@
fail_count INTEGER DEFAULT 0,
pass_count INTEGER DEFAULT 0,
archived INTEGER DEFAULT 0, -- 0=no, > 1=archive block id where test data can be found
last_update INTEGER DEFAULT (strftime('%s','now')),
CONSTRAINT testsconstraint UNIQUE (run_id, testname, item_path));")
- (sqlite3:execute db "CREATE INDEX IF NOT EXISTS tests_index ON tests (run_id, testname, item_path, uname);")
+ ;; deprecated -- (sqlite3:execute db "CREATE INDEX IF NOT EXISTS tests_index ON tests (run_id, testname, item_path, uname);")
+
+ (sqlite3:execute db "CREATE INDEX IF NOT EXISTS tests_run_id_index ON tests (run_id);") ;; new
+ (sqlite3:execute db "CREATE INDEX IF NOT EXISTS tests_testname_index ON tests (testname,item_path);") ;; new
+ (sqlite3:execute db "CREATE INDEX IF NOT EXISTS tests_state_status_index ON tests (state, status); ") ;; new
+
(sqlite3:execute db "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;
@@ -1393,3281 +324,561 @@
state TEXT DEFAULT 'new',
status TEXT DEFAULT 'n/a',
archive_type TEXT DEFAULT 'bup',
du INTEGER,
archive_path TEXT);")))
- db)) ;; )
-
-;;======================================================================
-;; A R C H I V E S
-;;======================================================================
-
-;; 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))
- (res '())
- (blocks '())) ;; a block is an archive chunck that can be added too if there is space
- (sqlite3:for-each-row
- (lambda (id archive-disk-id disk-path last-du last-du-time)
- (set! res (cons (vector id archive-disk-id disk-path last-du last-du-time) res)))
- db
- "SELECT b.id,b.archive_disk_id,b.disk_path,b.last_du,b.last_du_time FROM archive_blocks AS b
- INNER JOIN archive_allocations AS a ON a.archive_block_id=b.id
- WHERE a.testname=? AND a.item_path=?;"
- testname itempath)
- ;; Now res has list of candidate paths, look in archive_disks for candidate with potential free space
- (if (null? res)
- '()
- (sqlite3:for-each-row
- (lambda (id archive-area-name disk-path last-df last-df-time)
- (set! blocks (cons (vector id archive-area-name disk-path last-df last-df-time) blocks)))
- db
- (conc
- "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)
- 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))
- (res #f))
- (sqlite3:for-each-row
- (lambda (id)
- (set! res id))
- db
- "SELECT id FROM archive_disks WHERE archive_area_name=? AND disk_path=?;"
- bdisk-name bdisk-path)
- (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)
- 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)
- (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))
- (res #f))
- ;; first look to see if this path is already registered
- (sqlite3:for-each-row
- (lambda (id)
- (set! res id))
- db
- "SELECT id FROM archive_blocks WHERE archive_disk_id=? AND disk_path=?;"
- bdisk-id archive-path)
- (if res ;; record exists, update du if applicable and return res
- (begin
- (if du (sqlite3:exectute db "UPDATE archive_blocks SET last_du=?,last_du_time=(strftime('%s','now'))
- WHERE archive_disk_id=? AND disk_path=?;"
- bdisk-id archive-path du))
- res)
- (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))
- (db:archive-register-block-name dbstruct bdisk-id archive-path du: du)))
- (stack-push! (dbr:dbstruct-dbstack dbstruct) dbdat)
- res))
-
-
-;; The "archived" field in tests is overloaded; 0 = not archived, > 0 archived in block with given id
-;;
-(define (db:test-set-archive-block-id dbstruct run-id test-id archive-block-id)
- (db:with-db
- dbstruct
- run-id
- #f
- (lambda (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
-;;
-(define (db:test-get-archive-block-info dbstruct archive-block-id)
- (db:with-db
- dbstruct
- #f
- #f
- (lambda (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)))
- db
- "SELECT id,archive_disk_id,disk_path,last_du,last_du_time,creation_time FROM archive_blocks WHERE id=?;"
- archive-block-id)
- res))))
-
-;; (define (db:archive-allocate-testsuite/area-to-block block-id testsuite-name areakey)
-;; (let* ((dbdat (db:get-db dbstruct #f)) ;; archive tables are in main.db
-;; (db (db:dbdat-get-db dbdat))
-;; (res '())
-;; (blocks '())) ;; a block is an archive chunck that can be added too if there is space
-;; (sqlite3:for-each-row #f)
-
-;;======================================================================
-;; L O G G I N G D B
-;;======================================================================
-
-(define (open-logging-db)
- (let* ((dbpath (conc (if *toppath* (conc *toppath* "/") "") "logging.db")) ;; fname)
- (dbexists (common:file-exists? dbpath))
- (db (sqlite3:open-database dbpath))
- (handler (make-busy-timeout (if (args:get-arg "-override-timeout")
- (string->number (args:get-arg "-override-timeout"))
- 136000)))) ;; 136000)))
- (sqlite3:set-busy-handler! db handler)
- (if (not dbexists)
- (begin
- (sqlite3:execute db "CREATE TABLE IF NOT EXISTS log (id INTEGER PRIMARY KEY,event_time TIMESTAMP DEFAULT (strftime('%s','now')),logline TEXT,pwd TEXT,cmdline TEXT,pid INTEGER);")
- (db:set-sync db) ;; (sqlite3:execute db (conc "PRAGMA synchronous = 0;"))
- ))
- db))
-
-(define (db:log-local-event . loglst)
- (let ((logline (apply conc loglst)))
- (db:log-event logline)))
-
-(define (db:log-event logline)
- (let ((db (open-logging-db)))
- (sqlite3:execute db "INSERT INTO log (logline,pwd,cmdline,pid) VALUES (?,?,?,?);"
- logline
- (current-directory)
- (string-intersperse (argv) " ")
- (current-process-id))
- (sqlite3:finalize! db)
- logline))
-
-;;======================================================================
-;; D B U T I L S
-;;======================================================================
-
-;;======================================================================
-;; M A I N T E N A N C E
-;;======================================================================
-
-(define (db:have-incompletes? dbstruct run-id ovr-deadtime)
- (let* ((incompleted '())
- (oldlaunched '())
- (toplevels '())
- (deadtime-str (configf:lookup *configdat* "setup" "deadtime"))
- (deadtime (if (and deadtime-str
- (string->number deadtime-str))
- (string->number deadtime-str)
- 72000))) ;; twenty hours
- (db:with-db
- dbstruct #f #f
- (lambda (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
- ;; (> (- (current-seconds)(+ (db:test-get-event_time testdat)
- ;; (db:test-get-run_duration testdat)))
- ;; 600)
- ;; (db:delay-if-busy dbdat)
- (sqlite3:for-each-row
- (lambda (test-id run-dir uname testname item-path)
- (if (and (equal? uname "n/a")
- (equal? item-path "")) ;; this is a toplevel test
- ;; what to do with toplevel? call rollup?
- (begin
- (set! toplevels (cons (list test-id run-dir uname testname item-path run-id) toplevels))
- (debug:print-info 0 *default-log-port* "Found old toplevel test in RUNNING state, test-id=" test-id))
- (set! incompleted (cons (list test-id run-dir uname testname item-path run-id) incompleted))))
- db
- "SELECT id,rundir,uname,testname,item_path FROM tests WHERE run_id=? AND (strftime('%s','now') - event_time) > (run_duration + ?) AND state IN ('RUNNING','REMOTEHOSTSTART');"
- run-id deadtime)
-
- ;; in LAUNCHED for more than one day. Could be long due to job queues TODO/BUG: Need override for this in config
- ;;
- ;; (db:delay-if-busy dbdat)
- (sqlite3:for-each-row
- (lambda (test-id run-dir uname testname item-path)
- (if (and (equal? uname "n/a")
- (equal? item-path "")) ;; this is a toplevel test
- ;; what to do with toplevel? call rollup?
- (set! toplevels (cons (list test-id run-dir uname testname item-path run-id) toplevels))
- (set! oldlaunched (cons (list test-id run-dir uname testname item-path run-id) oldlaunched))))
- db
- "SELECT id,rundir,uname,testname,item_path FROM tests WHERE run_id=? AND (strftime('%s','now') - event_time) > 86400 AND state IN ('LAUNCHED');"
- run-id)
-
- (debug:print-info 18 *default-log-port* "Found " (length oldlaunched) " old LAUNCHED items, " (length toplevels) " old LAUNCHED toplevel tests and " (length incompleted) " tests marked RUNNING but apparently dead.")
- (if (and (null? incompleted)
- (null? oldlaunched)
- (null? toplevels))
- #f
- #t)))))
-
-;; given a launch delay (minimum time from last launch) return amount of time to wait
-;;
-;; (define (db:launch-delay-left dbstruct run-id launch-delay)
-
-
-;; select end_time-now from
-;; (select testname,item_path,event_time+run_duration as
-;; end_time,strftime('%s','now') as now from tests where state in
-;; ('RUNNING','REMOTEHOSTSTART','LAUNCHED'));
-
-(define (db:find-and-mark-incomplete dbstruct run-id ovr-deadtime)
- (let* ((incompleted '())
- (oldlaunched '())
- (toplevels '())
- (deadtime-str (configf:lookup *configdat* "setup" "deadtime")) ;; FIXME suspect test run time & deadtime are not well matched; resulting in COMPLETED/DEAD status of an a-ok running test
- (deadtime (if (and deadtime-str
- (string->number deadtime-str))
- (string->number deadtime-str)
- 7200))) ;; two hours
- (db:with-db
- dbstruct #f #f
- (lambda (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
- ;; (> (- (current-seconds)(+ (db:test-get-event_time testdat)
- ;; (db:test-get-run_duration testdat)))
- ;; 600)
- ;; (db:delay-if-busy dbdat)
- (sqlite3:for-each-row
- (lambda (test-id run-dir uname testname item-path)
- (if (and (equal? uname "n/a")
- (equal? item-path "")) ;; this is a toplevel test
- ;; what to do with toplevel? call rollup?
- (begin
- (set! toplevels (cons (list test-id run-dir uname testname item-path run-id) toplevels))
- (debug:print-info 0 *default-log-port* "Found old toplevel test in RUNNING state, test-id=" test-id))
- (set! incompleted (cons (list test-id run-dir uname testname item-path run-id) incompleted))))
- db
- "SELECT id,rundir,uname,testname,item_path FROM tests WHERE run_id=? AND (strftime('%s','now') - event_time) > (run_duration + ?) AND state IN ('RUNNING','REMOTEHOSTSTART');"
- run-id deadtime)
-
- ;; in LAUNCHED for more than one day. Could be long due to job queues TODO/BUG: Need override for this in config
- ;;
- ;; (db:delay-if-busy dbdat)
- (sqlite3:for-each-row
- (lambda (test-id run-dir uname testname item-path)
- (if (and (equal? uname "n/a")
- (equal? item-path "")) ;; this is a toplevel test
- ;; what to do with toplevel? call rollup?
- (set! toplevels (cons (list test-id run-dir uname testname item-path run-id) toplevels))
- (set! oldlaunched (cons (list test-id run-dir uname testname item-path run-id) oldlaunched))))
- db
- "SELECT id,rundir,uname,testname,item_path FROM tests WHERE run_id=? AND (strftime('%s','now') - event_time) > 86400 AND state IN ('LAUNCHED');"
- run-id)
-
- (debug:print-info 18 *default-log-port* "Found " (length oldlaunched) " old LAUNCHED items, " (length toplevels) " old LAUNCHED toplevel tests and " (length incompleted) " tests marked RUNNING but apparently dead.")
-
- ;; These are defunct tests, do not do all the overhead of set-state-status. Force them to INCOMPLETE.
- ;;
- ;; (db:delay-if-busy dbdat)
- (let* (;; (min-incompleted (filter (lambda (x)
- ;; (let* ((testpath (cadr x))
- ;; (tdatpath (conc testpath "/testdat.db"))
- ;; (dbexists (common:file-exists? tdatpath)))
- ;; (or (not dbexists) ;; if no file then something wrong - mark as incomplete
- ;; (> (- (current-seconds)(file-modification-time tdatpath)) 600)))) ;; no change in 10 minutes to testdat.db - she's dead Jim
- ;; incompleted))
- (min-incompleted-ids (map car incompleted)) ;; do 'em all
- (all-ids (append min-incompleted-ids (map car oldlaunched))))
- (if (> (length all-ids) 0)
- (begin
- (debug:print 0 *default-log-port* "WARNING: Marking test(s); " (string-intersperse (map conc all-ids) ", ") " as INCOMPLETE")
- (for-each
- (lambda (test-id)
- (db:test-set-state-status dbstruct run-id test-id "COMPLETED" "DEAD" "Test failed to complete")) ;; fix for one aspect of Randy's ticket 1405717332 ;; TODO - fix problem where test goes to COMPLETED/DEAD while in progress, only later to go to COMPLETED/PASS. ref ticket 220546828
-
- all-ids))))))))
-
-;; ALL REPLACED BY THE BLOCK ABOVE
-;;
-;; (sqlite3:execute
-;; db
-;; (conc "UPDATE tests SET state='INCOMPLETE' WHERE run_id=? AND id IN ("
-;; (string-intersperse (map conc all-ids) ",")
-;; ");")
-;; run-id))))
-;;
-;; ;; Now do rollups for the toplevel tests
-;; ;;
-;; ;; (db:delay-if-busy dbdat)
-;; (for-each
-;; (lambda (toptest)
-;; (let ((test-name (list-ref toptest 3)))
-;; ;; (run-id (list-ref toptest 5)))
-;; (db:top-test-set-per-pf-counts dbstruct run-id test-name)))
-;; toplevels)))
-
-;; 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)))
-
-;; Clean out old junk and vacuum the database
-;;
-;; Ultimately do something like this:
-;;
-;; 1. Look at test records either deleted or part of deleted run:
-;; a. If test dir exists, set the the test to state='UNKNOWN', Set the run to 'unknown'
-;; 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;")))
-
-;; Clean out old junk and vacuum the database
-;;
-;; Ultimately do something like this:
-;;
-;; 1. Look at test records either deleted or part of deleted run:
-;; a. If test dir exists, set the the test to state='UNKNOWN', Set the run to 'unknown'
-;; 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-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))
- (count-stmt (sqlite3:prepare db "SELECT (SELECT count(id) FROM tests);"))
- (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 NOT IN (" (string-intersperse (map conc valid-runs) ",") ");")
- ;; delete all tests that are 'DELETED'
- "DELETE FROM tests WHERE state='DELETED';"
- ))))
- ;; (db:delay-if-busy dbdat)
- (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;")))
-
-;; Clean out old junk and vacuum the database
-;;
-;; Ultimately do something like this:
-;;
-;; 1. Look at test records either deleted or part of deleted run:
-;; a. If test dir exists, set the the test to state='UNKNOWN', Set the run to 'unknown'
-;; 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-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))
- (count-stmt (sqlite3:prepare db "SELECT (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 NOT IN (" (string-intersperse (map conc valid-runs) ",") ");")
- ;; delete all tests that are 'DELETED'
- "DELETE FROM runs WHERE state='deleted';"
- )))
- (dead-runs '()))
- (sqlite3:for-each-row
- (lambda (run-id)
- (set! dead-runs (cons run-id dead-runs)))
- db
- "SELECT id FROM runs WHERE state='deleted';")
- ;; (db:delay-if-busy dbdat)
- (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;")
- dead-runs))
-
-;;======================================================================
-;; M E T A G E T A N D S E T V A R S
-;;======================================================================
-
-;; returns number if string->number is successful, string otherwise
-;; also updates *global-delta*
-;;
-(define (db:get-var dbstruct var)
- (let* ((res #f))
- (db:with-db
- dbstruct #f #f
- (lambda (db)
- (sqlite3:for-each-row
- (lambda (val)
- (set! res val))
- db
- "SELECT val FROM metadat WHERE var=?;" var)
- ;; convert to number if can
- (if (string? res)
- (let ((valnum (string->number res)))
- (if valnum (set! res valnum))))
- res))))
-
-;; This was part of db:get-var. It was used to estimate the load on
-;; the database files.
-;;
-;; scale by 10, average with current value.
-;; (set! *global-delta* (/ (+ *global-delta* (* (- (current-milliseconds) start-ms)
-;; (if throttle throttle 0.01)))
-;; 2))
-;; (if (> (abs (- *last-global-delta-printed* *global-delta*)) 0.08) ;; don't print all the time, only if it changes a bit
-;; (begin
-;; (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)
- (sqlite3:execute db "INSERT OR REPLACE INTO metadat (var,val) VALUES (?,?);" var val))))
-
-(define (db:del-var dbstruct var)
- (db:with-db dbstruct #f #t
- (lambda (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 (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)))
-
-(define (db:no-sync-close-db db)
- (db:safely-close-sqlite3-db db))
-
-;; 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)))
- (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
-
-;; 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)))
-
-;; look up values in a header/data structure
-(define (db:get-value-by-header row header field)
- (if (or (null? header) (not row))
- #f
- (let loop ((hed (car header))
- (tal (cdr header))
- (n 0))
- (if (equal? hed field)
- (handle-exceptions
- exn
- (begin
- (debug:print 0 *default-log-port* "WARNING: attempt to read non-existant field, row=" row " header=" header " field=" field)
- #f)
- (vector-ref row n))
- (if (null? tal) #f (loop (car tal)(cdr tal)(+ n 1)))))))
-
-;; Accessors for the header/data structure
-;; get rows and header from
-(define (db:get-header vec)(vector-ref vec 0))
-(define (db:get-rows vec)(vector-ref vec 1))
-
-;;======================================================================
-;; R U N S
-;;======================================================================
-
-
-
-
-
-(define (db:get-run-times dbstruct run-patt target-patt)
-(let ((res `())
- (qry (conc "select runname, (max(end_time)-min(event_time))/60 as runtime, target from (select runname, run_id,tests.event_time,tests.event_time+run_duration AS end_time, " (string-join (db:get-keys dbstruct) " || '/' || ") " as target from tests inner join runs on tests.run_id = runs.id where runs.runname like ? and target like ?) group by run_id ;")))
-;(print qry)
-(db:with-db
- dbstruct
- #f ;; this is for the main runs db
- #f ;; does not modify db
- (lambda (db)
- (sqlite3:for-each-row
- (lambda (runname runtime target )
- (set! res (cons (vector runname runtime target) res)))
- db
- qry
- run-patt target-patt)
-
- res))))
-
-
-
-(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)
- (let ((res #f))
- (sqlite3:for-each-row
- (lambda (runname)
- (set! res runname))
- db
- "SELECT runname FROM runs WHERE id=?;"
- run-id)
- res))))
-
-(define (db:get-run-key-val dbstruct run-id key)
- (db:with-db
- dbstruct
- #f
- #f
- (lambda (db)
- (let ((res #f))
- (sqlite3:for-each-row
- (lambda (val)
- (set! res val))
- db
- (conc "SELECT " key " FROM runs WHERE id=?;")
- run-id)
- res))))
-
-;; keys list to key1,key2,key3 ...
-(define (runs:get-std-run-fields keys remfields)
- (let* ((header (append keys remfields))
- (keystr (conc (keys->keystr keys) ","
- (string-intersperse remfields ","))))
- (list keystr header)))
-
-;; make a query (fieldname like 'patt1' OR fieldname
-(define (db:patt->like fieldname pattstr #!key (comparator " OR "))
- (let ((patts (if (string? pattstr)
- (string-split pattstr ",")
- '("%"))))
- (string-intersperse (map (lambda (patt)
- (let ((wildtype (if (substring-index "%" patt) "LIKE" "GLOB")))
- (conc fieldname " " wildtype " '" patt "'")))
- (if (null? patts)
- '("")
- patts))
- comparator)))
-
-
-;; register a test run with the db, this accesses the main.db and does NOT
-;; use server api
-;;
-(define (db:register-run dbstruct keyvals runname state status user contour-in)
- (let* ((keys (map car keyvals))
- (keystr (keys->keystr keys))
- (contour (or contour-in "")) ;; empty string to force no hierarcy and be backwards compatible.
- (comma (if (> (length keys) 0) "," ""))
- (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 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)
- (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 ");")
- allvals)
- (apply sqlite3:for-each-row
- (lambda (id)
- (set! res id))
- db
- (let ((qry (conc "SELECT id FROM runs WHERE (runname=? " andstr key=?str ");")))
- qry)
- qryvals)
- (sqlite3:execute db "UPDATE runs SET state=?,status=?,event_time=strftime('%s','now') WHERE id=? AND state='deleted';" state status res)
- res)))
- (begin
- (debug:print-error 0 *default-log-port* "Called without all necessary keys")
- #f))))
-
-;; replace header and keystr with a call to runs:get-std-run-fields
-;;
-;; keypatts: ( (KEY1 "abc%def")(KEY2 "%") )
-;; runpatts: patt1,patt2 ...
-;;
-(define (db:get-runs dbstruct runpatt count offset keypatts)
- (let* ((res '())
- (keys (db:get-keys dbstruct))
- (runpattstr (db:patt->like "runname" runpatt))
- (remfields (list "id" "runname" "state" "status" "owner" "event_time"))
- (header (append keys remfields))
- (keystr (conc (keys->keystr keys) ","
- (string-intersperse remfields ",")))
- (qrystr (conc "SELECT " keystr " FROM runs WHERE (" runpattstr ") " ;; runname LIKE ? "
- ;; Generate: " AND x LIKE 'keypatt' ..."
- (if (null? keypatts) ""
- (conc " AND "
- (string-join
- (map (lambda (keypatt)
- (let ((key (car keypatt))
- (patt (cadr keypatt)))
- (db:patt->like key patt)))
- keypatts)
- " AND ")))
- " AND state != 'deleted' ORDER BY event_time DESC "
- (if (number? count)
- (conc " LIMIT " count)
- "")
- (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)
- (sqlite3:for-each-row
- (lambda (a . x)
- (set! res (cons (apply vector a x) res)))
- db
- qrystr
- )))
- (debug:print-info 11 *default-log-port* "db:get-runs END qrystr: " qrystr " keypatts: " keypatts " offset: " offset " limit: " count)
- (vector header res)))
-
-
-(define-record simple-run target id runname state status owner event_time)
-(define-record-printer (simple-run x out)
- (fprintf out "#,(simple-run ~S ~S ~S ~S)"
- (simple-run-target x) (simple-run-id x) (simple-run-runname x) (time->string (seconds->local-time (simple-run-event_time x) ))))
-
-;; simple get-runs
-;;
-(define (db:simple-get-runs dbstruct runpatt count offset target)
- (let* ((res '())
- (keys (db:get-keys dbstruct))
- (runpattstr (db:patt->like "runname" runpatt))
- (remfields (list "id" "runname" "state" "status" "owner" "event_time"))
- (targstr (string-intersperse keys "||'/'||"))
- (keystr (conc targstr " AS target,"
- (string-intersperse remfields ",")))
- (qrystr (conc "SELECT " keystr " FROM runs WHERE (" runpattstr ") " ;; runname LIKE ? "
- ;; Generate: " AND x LIKE 'keypatt' ..."
- " AND target LIKE '" target "'"
- " AND state != 'deleted' ORDER BY event_time DESC "
- (if (number? count)
- (conc " LIMIT " count)
- "")
- (if (number? offset)
- (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)
- (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
- )))
- (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)
-;;
-(define (db:get-changed-run-ids since-time)
- (let* ((dbdir (db:dbfile-path)) ;; (configf:lookup *configdat* "setup" "dbdir"))
- (alldbs (glob (conc dbdir "/[0-9]*.db")))
- (changed (filter (lambda (dbfile)
- (> (file-modification-time dbfile) since-time))
- alldbs)))
- (delete-duplicates
- (map (lambda (dbfile)
- (let* ((res (string-match ".*\\/(\\d)*\\.db" dbfile)))
- (if res
- (string->number (cadr res))
- (begin
- (debug:print 2 *default-log-port* "WARNING: Failed to process " dbfile " for run-id")
- 0))))
- changed))))
-
-;; Get all targets from the db
-;;
-(define (db:get-targets dbstruct)
- (let* ((res '())
- (keys (db:get-keys dbstruct))
- (header keys) ;; (map key:get-fieldname keys))
- (keystr (keys->keystr keys))
- (qrystr (conc "SELECT " keystr " FROM runs WHERE state != 'deleted';"))
- (seen (make-hash-table)))
- (db:with-db
- dbstruct
- #f
- #f
- (lambda (db)
- (sqlite3:for-each-row
- (lambda (a . x)
- (let ((targ (cons a x)))
- (if (not (hash-table-ref/default seen targ #f))
- (begin
- (hash-table-set! seen targ #t)
- (set! res (cons (apply vector targ) res))))))
- db
- qrystr)
- (debug:print-info 11 *default-log-port* "db:get-targets END qrystr: " qrystr )
- (vector header res)))))
-
-;; just get count of runs
-(define (db:get-num-runs dbstruct runpatt)
- (db:with-db
- dbstruct
- #f
- #f
- (lambda (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))
- db
- "SELECT COUNT(id) FROM runs WHERE runname LIKE ? AND state != 'deleted';" runpatt)
- (debug:print-info 11 *default-log-port* "db:get-num-runs END " runpatt)
- numruns))))
-
-;; just get count of runs
-(define (db:get-runs-cnt-by-patt dbstruct runpatt targetpatt keys)
- (db:with-db
- dbstruct
- #f
- #f
- (lambda (db)
- (let ((numruns 0)
- (qry-str #f)
- (key-patt "")
- (keyvals (if targetpatt (keys:target->keyval keys targetpatt) '())))
-
- (for-each (lambda (keyval)
- (let* ((key (car keyval))
- (patt (cadr keyval))
- (fulkey (conc ":" key))
- (wildtype (if (substring-index "%" patt) "like" "glob")))
-
- (if patt
- (set! key-patt (conc key-patt " AND " key " " wildtype " '" patt "'"))
- (begin
- (debug:print-error 0 *default-log-port* "searching for runs with no pattern set for " fulkey)
- (exit 6)))))
- keyvals)
- ;(print runpatt " -- " key-patt)
- (set! qry-str (conc "SELECT COUNT(id) FROM runs WHERE state != 'deleted' AND runname like '" runpatt "'" key-patt))
- ;(print qry-str )
-
- (sqlite3:for-each-row
- (lambda (count)
- (set! numruns count))
- db
- qry-str)
- (debug:print-info 11 *default-log-port* "db:get-num-runs END " runpatt)
- numruns))))
-
-
-;; (sqlite3#fold-row proc3670 init3671 db-or-stmt3672 . params3673)>
-;;
-(define (db:get-raw-run-stats dbstruct run-id)
- (db:with-db
- dbstruct
- run-id
- #f
- (lambda (db)
- (sqlite3:fold-row
- (lambda (res state status count)
- (cons (list state status count) res))
- '()
- db
- "SELECT state,status,count(id) AS count FROM tests WHERE run_id=? AND NOT(uname='n/a' AND item_path='') GROUP BY state,status;"
- run-id))))
-
-;; Update run_stats for given run_id
-;; input data is a list (state status count)
-;;
-(define (db:update-run-stats dbstruct run-id stats)
- ;; (mutex-lock! *db-transaction-mutex*)
- (db:with-db
- dbstruct
- #f
- #f
-
- (lambda (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
- (sqlite3:with-transaction
- db
- (lambda ()
- (for-each
- (lambda (dat)
- (sqlite3:execute stmt1 run-id (car dat)(cadr dat))
- (apply sqlite3:execute stmt2 run-id dat))
- stats)))))
- (sqlite3:finalize! stmt1)
- (sqlite3:finalize! stmt2)
- ;; (mutex-unlock! *db-transaction-mutex*)
- res))))
-
-(define (db:get-main-run-stats dbstruct run-id)
- (db:with-db
- dbstruct
- #f ;; this data comes from main
- #f
- (lambda (db)
- (sqlite3:fold-row
- (lambda (res state status count)
- (cons (list state status count) res))
- '()
- db
- "SELECT state,status,count FROM run_stats WHERE run_id=? AND run_id IN (SELECT id FROM runs WHERE state NOT IN ('DELETED','deleted'));"
- run-id))))
-
-(define (db:print-current-query-stats)
- ;; generate stats from *db-api-call-time*
- (let ((ordered-keys (sort (hash-table-keys *db-api-call-time*)
- (lambda (a b)
- (let ((sum-a (common:sum (hash-table-ref *db-api-call-time* a)))
- (sum-b (common:sum (hash-table-ref *db-api-call-time* b))))
- (> sum-a sum-b)))))
- (total 0))
- (for-each
- (lambda (cmd-key)
- (let* ((dat (hash-table-ref *db-api-call-time* cmd-key))
- (num (length dat))
- (avg (if (> num 0)
- (/ (common:sum dat)(length dat)))))
- (set! total (+ total num))
- (debug:print-info 0 *default-log-port* cmd-key "\tavg: " avg " max: " (common:max dat) " min: " (common:min-max < dat) " num: " (length dat))))
- ordered-keys)
- (debug:print-info 0 *default-log-port* "TOTAL: " total " api calls since start.")))
-
-(define (db:get-all-run-ids dbstruct)
- (db:with-db
- dbstruct
- #f
- #f
- (lambda (db)
- (let ((run-ids '()))
- (sqlite3:for-each-row
- (lambda (run-id)
- (set! run-ids (cons run-id run-ids)))
- db
- "SELECT id FROM runs WHERE state != 'deleted' ORDER BY event_time DESC;")
- (reverse run-ids)))))
-
-;; get some basic run stats
-;;
-;; data structure:
-;;
-;; ( (runname (( state count ) ... ))
-;; ( ...
-;;
-(define (db:get-run-stats dbstruct)
- (let* ((totals (make-hash-table))
- (curr (make-hash-table))
- (res '())
- (runs-info '()))
- ;; First get all the runname/run-ids
- (db:with-db
- dbstruct #f #f
- (lambda (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
- ;; for each run get stats data
- (for-each
- (lambda (run-info)
- ;; get the net state/status counts for this run
- (let* ((run-id (car run-info))
- (run-name (cadr run-info)))
- (db:with-db
- dbstruct
- run-id
- #f
- (lambda (db)
- (sqlite3:for-each-row
- (lambda (state status count)
- (let ((netstate (if (equal? state "COMPLETED") status state)))
- (if (string? netstate)
- (begin
- (hash-table-set! totals netstate (+ (hash-table-ref/default totals netstate 0) count))
- (hash-table-set! curr netstate (+ (hash-table-ref/default curr netstate 0) count))))))
- db
- "SELECT state,status,count(id) FROM tests AS t WHERE run_id=? GROUP BY state,status ORDER BY state,status DESC;"
- run-id)
- ;; add the per run counts to res
- (for-each (lambda (state)
- (set! res (cons (list run-name state (hash-table-ref curr state)) res)))
- (sort (hash-table-keys curr) string>=))
- (set! curr (make-hash-table))))))
- runs-info)
- (for-each (lambda (state)
- (set! res (cons (list "Totals" state (hash-table-ref totals state)) res)))
- (sort (hash-table-keys totals) string>=))
- res))
-
-;; db:get-runs-by-patt
-;; get runs by list of criteria
-;; register a test run with the db
-;;
-;; Use: (db:get-value-by-header (db:get-header runinfo)(db:get-rows runinfo))
-;; to extract info from the structure returned
-;;
-(define (db:get-runs-by-patt dbstruct keys runnamepatt targpatt offset limit fields last-update sort-order ) ;; test-name)
- (let* ((tmp (runs:get-std-run-fields keys (or fields '("id" "runname" "state" "status" "owner" "event_time"))))
- (keystr (car tmp))
- (header (cadr tmp))
- (key-patt "")
- (runwildtype (if (substring-index "%" runnamepatt) "like" "glob"))
- (qry-str #f)
- (keyvals (if targpatt (keys:target->keyval keys targpatt) '())))
- (for-each (lambda (keyval)
- (let* ((key (car keyval))
- (patt (cadr keyval))
- (fulkey (conc ":" key))
- (wildtype (if (substring-index "%" patt) "like" "glob")))
- (if patt
- (set! key-patt (conc key-patt " AND " key " " wildtype " '" patt "'"))
- (begin
- (debug:print-error 0 *default-log-port* "searching for runs with no pattern set for " fulkey)
- (exit 6)))))
- keyvals)
- (set! qry-str (conc "SELECT " keystr " FROM runs WHERE state != 'deleted' AND runname " runwildtype " ? " key-patt
- (if last-update
- (conc " AND last_update >= " last-update " ")
- " ")
- " ORDER BY event_time " sort-order " "
- (if limit (conc " LIMIT " limit) "")
- (if offset (conc " OFFSET " offset) "")
- ";"))
- (debug:print-info 4 *default-log-port* "runs:get-runs-by-patt qry=" qry-str " " runnamepatt)
- ;(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)
- (sqlite3:fold-row
- (lambda (res . r)
- (cons (list->vector r) res))
- '()
- db
- qry-str
- runnamepatt)))))))
-
-;; use (get-value-by-header (db:get-header runinfo)(db:get-rows runinfo))
-;; NOTE: Does NOT return a list of rows (or one row) for the first slot of the vector
-;; this is inconsistent with get-runs but it makes some sense.
-;;
-(define (db:get-run-info dbstruct run-id)
- ;;(if (hash-table-ref/default *run-info-cache* run-id #f)
- ;; (hash-table-ref *run-info-cache* run-id)
- (let* ((res (vector #f #f #f #f))
- (keys (db:get-keys dbstruct))
- (remfields (list "id" "runname" "state" "status" "owner" "event_time" "comment" "fail_count" "pass_count" "contour" "last_update")) ;; "area_id"))
- (header (append keys remfields))
- (keystr (conc (keys->keystr keys) ","
- (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)
- (sqlite3:for-each-row
- (lambda (a . x)
- (set! res (apply vector a x)))
- db
- (conc "SELECT " keystr " FROM runs WHERE id=?;")
- run-id)))
- (debug:print-info 11 *default-log-port* "db:get-run-info run-id: " run-id " header: " header " keystr: " keystr)
- (let ((finalres (vector header res)))
- ;; (hash-table-set! *run-info-cache* run-id finalres)
- finalres)))
-
-(define (db:set-comment-for-run dbstruct run-id comment)
- (db:with-db
- dbstruct #f #f
- (lambda (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)
- (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)
- (sqlite3:execute db "UPDATE tests SET state='DELETED',comment='' WHERE run_id=?;" run-id)
- ;; (db:delay-if-busy dbdat)
- (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)
- (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)
- (let ((newlockval (if lock "locked"
- (if unlock
- "unlocked"
- "locked")))) ;; semi-failsafe
- (sqlite3:execute db "UPDATE runs SET state=? WHERE id=?;" newlockval run-id)
- (sqlite3:execute db "INSERT INTO access_log (user,accessed,args) VALUES(?,strftime('%s','now'),?);"
- user (conc newlockval " " run-id))
- (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)
- (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:get-run-status dbstruct run-id)
- (let ((res "n/a"))
- (db:with-db
- dbstruct #f #f
- (lambda (db)
- (sqlite3:for-each-row
- (lambda (status)
- (set! res status))
- db
- "SELECT status FROM runs WHERE id=?;"
- run-id)
- res))))
-
-;;======================================================================
-;; K E Y S
-;;======================================================================
-
-;; get key val pairs for a given run-id
-;; ( (FIELDNAME1 keyval1) (FIELDNAME2 keyval2) ... )
-(define (db:get-key-val-pairs dbstruct run-id)
- (let* ((keys (db:get-keys dbstruct))
- (res '()))
- (db:with-db
- dbstruct #f #f
- (lambda (db)
- (for-each
- (lambda (key)
- (let ((qry (conc "SELECT " key " FROM runs WHERE id=?;")))
- (sqlite3:for-each-row
- (lambda (key-val)
- (set! res (cons (list key (if (string? key-val) key-val "")) res))) ;; replace non-string bad values with empty string to prevent crashes. This scenario can happen when Megatest is killed on updating the db
- db qry run-id)))
- keys)))
- (reverse res)))
-
-;; get key vals for a given run-id
-(define (db:get-key-vals dbstruct run-id)
- (let* ((keys (db:get-keys dbstruct))
- (res '()))
- (db:with-db
- dbstruct #f #f
- (lambda (db)
- (for-each
- (lambda (key)
- (let ((qry (conc "SELECT " key " FROM runs WHERE id=?;")))
- ;; (db:delay-if-busy dbdat)
- (sqlite3:for-each-row
- (lambda (key-val)
- (set! res (cons (if (string? key-val) key-val "") res))) ;; check that the key-val is a string for cases where a crash injected bad data in the megatest.db
- db qry run-id)))
- keys)))
- (let ((final-res (reverse res)))
- (hash-table-set! *keyvals* run-id final-res)
- final-res)))
-
-;; The target is keyval1/keyval2..., cached in *target* as it is used often
-(define (db:get-target dbstruct run-id)
- (let* ((keyvals (db:get-key-vals dbstruct run-id))
- (thekey (string-intersperse (map (lambda (x)(if x x "-na-")) keyvals) "/")))
- thekey))
-
-;; Get run-ids for runs with same target but different runnames and NOT run-id
-;;
-(define (db:get-prev-run-ids dbstruct run-id)
- (let* ((keyvals (rmt:get-key-val-pairs run-id))
- (kvalues (map cadr keyvals))
- (keys (rmt:get-keys))
- (qrystr (string-intersperse (map (lambda (x)(conc x "=?")) keys) " AND ")))
- (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)
- (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 != ?;")
- (append kvalues (list run-id)))))
- prev-run-ids)))))
-
-;;======================================================================
-;; T E S T S
-;;======================================================================
-
-;; states and statuses are lists, turn them into ("PASS","FAIL"...) and use NOT IN
-;; i.e. these lists define what to NOT show.
-;; states and statuses are required to be lists, empty is ok
-;; not-in #t = above behaviour, #f = must match
-;; mode:
-;; 'dashboard - use state = 'COMPLETED' AND status in ( statuses ) OR state in ( states )
-;;
-(define (db:get-tests-for-run dbstruct run-id testpatt states statuses offset limit not-in sort-by sort-order qryvals last-update mode)
- (let* ((qryvalstr (case qryvals
- ((shortlist) "id,run_id,testname,item_path,state,status")
- ((#f) db:test-record-qry-selector) ;; "id,run_id,testname,state,status,event_time,host,cpuload,diskfree,uname,rundir,item_path,run_duration,final_logf,comment")
- (else qryvals)))
- (res '())
- ;; if states or statuses are null then assume match all when not-in is false
- (states-qry (if (null? states)
- #f
- (conc " state "
- (if (eq? mode 'dashboard)
- " IN ('"
- (if not-in
- " NOT IN ('"
- " IN ('"))
- (string-intersperse states "','")
- "')")))
- (statuses-qry (if (null? statuses)
- #f
- (conc " status "
- (if (eq? mode 'dashboard)
- " IN ('"
- (if not-in
- " NOT IN ('"
- " IN ('") )
- (string-intersperse statuses "','")
- "')")))
- (interim-qry (conc " AND " (if not-in "NOT " "") "( state='COMPLETED' " (if statuses-qry (conc " AND " statuses-qry " ) ") " ) ")
- (if states-qry
- (conc (if not-in " AND " " OR ") states-qry ) ;; " ) ")
- "")))
- (states-statuses-qry
- (cond
- ((and states-qry statuses-qry)
- (case mode
- ((dashboard)
- (if not-in
- (conc " AND (state='COMPLETED' AND status NOT IN ('" (string-intersperse statuses "','") "')) "
- " OR (state != 'COMPLETED' AND state NOT IN ('" (string-intersperse states "','") "')) ")
- (conc " AND (state='COMPLETED' AND status IN ('" (string-intersperse statuses "','") "')) "
- " OR (state NOT IN ('COMPLETED','DELETED') AND state IN ('" (string-intersperse states "','") "')) ")))
- (else (conc " AND ( " states-qry " AND " statuses-qry " ) "))))
- (states-qry
- (case mode
- ((dashboard) (conc " AND " (if not-in "NOT " "") " state IN ('" (string-intersperse states "','") "') ")) ;; interim-qry)
- (else (conc " AND " states-qry))))
- (statuses-qry
- (case mode
- ((dashboard) (conc " AND " (if not-in "NOT " "") " status IN ('" (string-intersperse statuses "','") "') ")) ;; interim-qry)
- (else (conc " AND " statuses-qry))))
- (else "")))
- (tests-match-qry (tests:match->sqlqry testpatt))
- (qry (conc "SELECT " qryvalstr
- (if run-id
- " FROM tests WHERE run_id=? "
- " FROM tests WHERE ? > 0 ") ;; should work?
- (if last-update " " " AND state != 'DELETED' ") ;; if using last-update we want deleted tests?
- states-statuses-qry
- (if tests-match-qry (conc " AND (" tests-match-qry ") ") "")
- (if last-update (conc " AND last_update >= " last-update " ") "")
- (case sort-by
- ((rundir) " ORDER BY length(rundir) ")
- ((testname) (conc " ORDER BY testname " (if sort-order (conc sort-order ",") "") " item_path "))
- ((statestatus) (conc " ORDER BY state " (if sort-order (conc sort-order ",") "") " status "))
- ((event_time) " ORDER BY event_time ")
- (else (if (string? sort-by)
- (conc " ORDER BY " sort-by " ")
- " ")))
- (if sort-order sort-order " ")
- (if limit (conc " LIMIT " limit) " ")
- (if offset (conc " OFFSET " offset) " ")
- ";"
- )))
- (debug:print-info 8 *default-log-port* "db:get-tests-for-run run-id=" run-id ", qry=" qry)
- (db:with-db dbstruct run-id #f
- (lambda (db)
- (sqlite3:for-each-row
- (lambda (a . b) ;; id run-id testname state status event-time host cpuload diskfree uname rundir item-path run-duration final-logf comment)
- (set! res (cons (apply vector a b) res))) ;; id run-id testname state status event-time host cpuload diskfree uname rundir item-path run-duration final-logf comment) res)))
- db
- qry
- (or run-id 1) ;; 1 > 0 , for the case where we are seeking tests matching criteral for all runs
- )))
- (case qryvals
- ((shortlist)(map db:test-short-record->norm res))
- ((#f) res)
- (else res))))
-
-(define (db:test-short-record->norm inrec)
- ;; "id,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
- (vector (vector-ref inrec 0) ;; id
- (vector-ref inrec 1) ;; run_id
- (vector-ref inrec 2) ;; testname
- (vector-ref inrec 4) ;; state
- (vector-ref inrec 5) ;; status
- -1 "" -1 -1 "" "-"
- (vector-ref inrec 3) ;; item-path
- -1 "-" "-"))
-
-(define (db:get-tests-for-run-state-status dbstruct run-id testpatt)
- (let* ((res '())
- (tests-match-qry (tests:match->sqlqry testpatt))
- (qry (conc "SELECT id,testname,item_path,state,status FROM tests WHERE run_id=? "
- (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)
- (sqlite3:for-each-row
- (lambda (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 (cons (vector id run-id testname state status -1 "" -1 -1 "" "-" item-path -1 "-" "-") res)))
- db
- qry
- run-id)))
- res))
-
-(define (db:get-testinfo-state-status dbstruct run-id test-id)
- (let ((res #f))
- (db:with-db dbstruct run-id #f
- (lambda (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
- "SELECT run_id,testname,item_path,state,status FROM tests WHERE id=?;"
- test-id)))
- res))
-
-;; get a useful subset of the tests data (used in dashboard
-;; use db:mintest-get-{id ,run_id,testname ...}
-;;
-(define (db:get-tests-for-run-mindata dbstruct run-id testpatt states statuses not-in)
- (db:get-tests-for-run dbstruct run-id testpatt states statuses #f #f not-in #f #f "id,run_id,testname,state,status,event_time,item_path" 0 #f))
-
-;; do not use.
-;;
-(define (db:get-tests-for-runs dbstruct run-ids testpatt states statuses #!key (not-in #f)(qryvals #f))
- ;; (db:delay-if-busy)
- (let ((res '()))
- (for-each
- (lambda (run-id)
- (set! res (append
- res
- (db:get-tests-for-run dbstruct run-id testpatt states statuses #f #f not-in #f #f qryvals #f 'normal))))
- (if run-ids
- run-ids
- (db:get-all-run-ids dbstruct)))
- res))
-
-;; 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:with-db
- dbstruct #f #f
- (lambda (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 (;; (run-ids (db:get-all-run-ids dbstruct))
- (targtime (- (current-seconds)(* 30 24 60 60)))) ;; one month in the past
- (db:with-db
- dbstruct
- 0
- #t
- (lambda (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 fieldname fields)
- (if (null? fields)
- #f
- (let loop ((hed (car fields))
- (tal (cdr fields))
- (indx 0))
- (if (equal? fieldname hed)
- indx
- (if (null? tal)
- #f
- (loop (car tal)(cdr tal)(+ indx 1)))))))
-
-(define db:test-record-qry-selector (string-intersperse db:test-record-fields ","))
-
-
-;; NOTE: Use db:test-get* to access records
-;; NOTE: This needs rundir decoding? Decide, decode here or where used? For the moment decode where used.
-(define (db:get-all-tests-info-by-run-id dbstruct run-id)
- (let* ((res '()))
- (db:with-db
- dbstruct #f #f
- (lambda (db)
- (sqlite3:for-each-row
- (lambda (id run-id testname state status event-time host cpuload diskfree uname rundir item-path run-duration final-logf comment shortdir attemptnum archived)
- ;; 0 1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16
- (set! res (cons (vector id run-id testname state status event-time host cpuload diskfree uname rundir item-path run-duration final-logf comment shortdir attemptnum archived)
- res)))
- db
- (conc "SELECT " db:test-record-qry-selector " FROM tests WHERE state != 'DELETED' AND run_id=?;")
- run-id)))
- res))
-
-(define (db:replace-test-records dbstruct run-id testrecs)
- (db:with-db dbstruct run-id #t
- (lambda (db)
- (let* ((qmarks (string-intersperse (make-list (length db:test-record-fields) "?") ","))
- (qrystr (conc "INSERT OR REPLACE INTO tests (" db:test-record-qry-selector ") VALUES (" qmarks ") WHERE run_id=?;"))
- (qry (sqlite3:prepare db qrystr)))
- (debug:print 0 *default-log-port* "INFO: migrating test records for run with id " run-id)
- (sqlite3:with-transaction
- db
- (lambda ()
- (for-each
- (lambda (rec)
- ;; (debug:print 0 *default-log-port* "INFO: Inserting values: " (string-intersperse (map conc (vector->list rec)) ",") "\n")
- (apply sqlite3:execute qry (append (vector->list rec)(list run-id))))
- testrecs)))
- (sqlite3:finalize! qry)))))
-
-;; map a test-id into the proper range
-;;
-(define (db:adj-test-id mtdb min-test-id test-id)
- (if (>= test-id min-test-id)
- test-id
- (let loop ((new-id min-test-id))
- (let ((test-id-found #f))
- (sqlite3:for-each-row
- (lambda (id)
- (set! test-id-found id))
- (db:dbdat-get-db mtdb)
- "SELECT id FROM tests WHERE id=?;"
- new-id)
- ;; if test-id-found then need to try again
- (if test-id-found
- (loop (+ new-id 1))
- (begin
- (debug:print-info 0 *default-log-port* "New test id " new-id " selected for test with id " test-id)
- (sqlite3:execute mtdb "UPDATE tests SET id=? WHERE id=?;" new-id test-id)))))))
-
-;; move test ids into the 30k * run_id range
-;;
-(define (db:prep-megatest.db-adj-test-ids mtdb run-id testrecs)
- (debug:print-info 0 *default-log-port* "Adjusting test ids in megatest.db for run " run-id)
- (let ((min-test-id (* run-id 30000)))
- (for-each
- (lambda (testrec)
- (let* ((test-id (vector-ref testrec (db:field->number "id" db:test-record-fields))))
- (db:adj-test-id (db:dbdat-get-db 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
-;;
-(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)))
- 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
- #f
- (lambda (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)))
- db
- (conc "SELECT " db:test-record-qry-selector " FROM tests WHERE id=?;")
- test-id)
- res))))
-
-;; Use db:test-get* to access
-;; Get test data using test_ids. NB// Only works within a single run!!
-;;
-(define (db:get-test-info-by-ids dbstruct run-id test-ids)
- (db:with-db
- dbstruct
- run-id
- #f
- (lambda (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)))
- db
- (conc "SELECT " db:test-record-qry-selector " FROM tests WHERE id in ("
- (string-intersperse (map conc test-ids) ",") ");"))
- res))))
-
-(define (db:get-test-info dbstruct run-id test-name item-path)
- (db:with-db
- dbstruct
- run-id
- #f
- (lambda (db)
- (let ((res #f))
- (sqlite3:for-each-row
- (lambda (a . b)
- (set! res (apply vector a b)))
- db
- (conc "SELECT " db:test-record-qry-selector " FROM tests WHERE testname=? AND item_path=? AND run_id=?;")
- test-name item-path run-id)
- res))))
-
-(define (db:test-get-rundir-from-test-id dbstruct run-id test-id)
- (db:with-db
- dbstruct
- run-id
- #f
- (lambda (db)
- (db:first-result-default
- db
- "SELECT rundir FROM tests WHERE id=?;"
- #f ;; default result
- test-id))))
-
-(define (db:get-test-times dbstruct run-name target)
- (let ((res `())
- (qry (conc "select testname, item_path, run_duration, " (string-join (db:get-keys dbstruct) " || '/' || ") " 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)
- (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
- run-name target)
- res))))
-
-(define (db:get-test-times dbstruct run-name target)
- (let ((res `())
- (qry (conc "select testname, item_path, run_duration, " (string-join (db:get-keys dbstruct) " || '/' || ") " 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)
- (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
- run-name target)
- res))))
-
-;;======================================================================
-;; S T E P S
-;;======================================================================
-
-(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)
- (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 "")
- (if logfile logfile "")))))
-
-;; db-get-test-steps-for-run
-(define (db:get-steps-for-test dbstruct run-id test-id)
- (db:with-db
- dbstruct
- run-id
- #f
- (lambda (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)
- (db:with-db
- dbstruct
- #f
- #f
- (lambda (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
- "SELECT id,test_id,stepname,state,status,event_time,logfile,comment,last_update FROM test_steps WHERE id=? ORDER BY id ASC;" ;; event_time DESC,id ASC;
- test-step-id)
- res))))
-
-(define (db:get-steps-data dbstruct run-id test-id)
- (db:with-db
- dbstruct
- run-id
- #f
- (lambda (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
- "SELECT id,test_id,stepname,state,status,event_time,logfile FROM test_steps WHERE status != 'DELETED' AND test_id=? ORDER BY id ASC;" ;; event_time DESC,id ASC;
- test-id)
- (reverse res)))))
-
-;;======================================================================
-;; T E S T D A T A
-;;======================================================================
-
- (define (db:get-data-info-by-id dbstruct test-data-id)
- (db:with-db
- dbstruct
- #f
- #f
- (lambda (db)
- (let* ((res (vector #f #f #f #f #f #f #f #f #f #f #f #f)))
- (sqlite3:for-each-row
- (lambda (id test-id category variable value expected tol units comment status type last-update)
- (set! res (vector id test-id category variable value expected tol units comment status type last-update)))
- db
- "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;
- test-data-id)
- res))))
-
-
-;; WARNING: Do NOT call this for the parent test on an iterated test
-;; Roll up test_data pass/fail results
-;; look at the test_data status field,
-;; if all are pass (any case) and the test status is PASS or NULL or '' then set test status to PASS.
-;; 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)
- (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))
- ;; 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))))))
-
-;; each section is a rule except "final" which is the final result
-;;
-;; [rule-5]
-;; operator in
-;; section LogFileBody
-;; desc Output voltage
-;; status OK
-;; expected 1.9
-;; measured 1.8
-;; type +/-
-;; tolerance 0.1
-;; pass 1
-;; fail 0
-;;
-;; [final]
-;; exit-code 6
-;; exit-status SKIP
-;; message If flagged we are asking for this to exit with code 6
-;;
-;; recorded in steps table:
-;; category: stepname
-;; variable: rule-N
-;; value: measured
-;; expected: expected
-;; tol: tolerance
-;; units: -
-;; comment: desc or message
-;; status: status
-;; type: type
-;;
-(define (db:logpro-dat->csv dat stepname)
- (let ((res '()))
- (for-each
- (lambda (entry-name)
- (if (equal? entry-name "final")
- (set! res (append
- res
- (list
- (list stepname
- entry-name
- (configf:lookup dat entry-name "exit-code") ;; 0 ;; Value
- 0 ;; 1 ;; Expected
- 0 ;; 2 ;; Tolerance
- "n/a" ;; 3 ;; Units
- (configf:lookup dat entry-name "message") ;; 4 ;; Comment
- (configf:lookup dat entry-name "exit-status") ;; 5 ;; Status
- "logpro" ;; 6 ;; Type
- ))))
- (let* ((value (or (configf:lookup dat entry-name "measured") "n/a"))
- (expected (or (configf:lookup dat entry-name "expected") 0.0))
- (tolerance (or (configf:lookup dat entry-name "tolerance") 0.0))
- (comment (or (configf:lookup dat entry-name "comment")
- (configf:lookup dat entry-name "desc") "n/a"))
- (status (or (configf:lookup dat entry-name "status") "n/a"))
- (type (or (configf:lookup dat entry-name "expected") "n/a")))
- (set! res (append
- res
- (list (list stepname
- entry-name
- value ;; 0
- expected ;; 1
- tolerance ;; 2
- "n/a" ;; 3 Units
- comment ;; 4
- status ;; 5
- type ;; 6
- )))))))
- (hash-table-keys dat))
- res))
-
-;; $MT_MEGATEST -load-test-data << EOF
-;; foo,bar, 1.2, 1.9, >
-;; foo,rab, 1.0e9, 10e9, 1e9
-;; foo,bla, 1.2, 1.9, <
-;; foo,bal, 1.2, 1.2, < , ,Check for overload
-;; foo,alb, 1.2, 1.2, <= , Amps,This is the high power circuit test
-;; foo,abl, 1.2, 1.3, 0.1
-;; foo,bra, 1.2, pass, silly stuff
-;; faz,bar, 10, 8mA, , ,"this is a comment"
-;; EOF
-
-(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)
- (let* ((csvlist (csv->list (make-csv-reader
- (open-input-string csvdata)
- '((strip-leading-whitespace? #t)
- (strip-trailing-whitespace? #t)))))) ;; (csv->list csvdata)))
- (for-each
- (lambda (csvrow)
- (let* ((padded-row (take (append csvrow (list #f #f #f #f #f #f #f #f #f)) 9))
- (category (list-ref padded-row 0))
- (variable (list-ref padded-row 1))
- (value (any->number-if-possible (list-ref padded-row 2)))
- (expected (any->number-if-possible (list-ref padded-row 3)))
- (tol (any->number-if-possible (list-ref padded-row 4))) ;; >, <, >=, <=, or a number
- (units (list-ref padded-row 5))
- (comment (list-ref padded-row 6))
- (status (let ((s (list-ref padded-row 7)))
- (if (and (string? s)(or (string-match (regexp "^\\s*$") s)
- (string-match (regexp "^n/a$") s)))
- #f
- s))) ;; if specified on the input then use, else calculate
- (type (list-ref padded-row 8)))
- ;; look up expected,tol,units from previous best fit test if they are all either #f or ''
- (debug:print 4 *default-log-port* "BEFORE: category: " category " variable: " variable " value: " value
- ", expected: " expected " tol: " tol " units: " units " status: " status " comment: " comment " type: " type)
-
- (if (and (or (not expected)(equal? expected ""))
- (or (not tol) (equal? expected ""))
- (or (not units) (equal? expected "")))
- (let-values (((new-expected new-tol new-units)(tdb:get-prev-tol-for-test #f test-id category variable)))
- (set! expected new-expected)
- (set! tol new-tol)
- (set! units new-units)))
-
- (debug:print 4 *default-log-port* "AFTER: category: " category " variable: " variable " value: " value
- ", expected: " expected " tol: " tol " units: " units " status: " status " comment: " comment)
- ;; calculate status if NOT specified
- (if (and (not status)(number? expected)(number? value)) ;; need expected and value to be numbers
- (if (number? tol) ;; if tol is a number then we do the standard comparison
- (let* ((max-val (+ expected tol))
- (min-val (- expected tol))
- (result (and (>= value min-val)(<= value max-val))))
- (debug:print 4 *default-log-port* "max-val: " max-val " min-val: " min-val " result: " result)
- (set! status (if result "pass" "fail")))
- (set! status ;; NB// need to assess each one (i.e. not return operator since need to act if not valid op.
- (case (string->symbol tol) ;; tol should be >, <, >=, <=
- ((>) (if (> value expected) "pass" "fail"))
- ((<) (if (< value expected) "pass" "fail"))
- ((>=) (if (>= value expected) "pass" "fail"))
- ((<=) (if (<= value expected) "pass" "fail"))
- (else (conc "ERROR: bad tol comparator " tol))))))
- (debug:print 4 *default-log-port* "AFTER2: category: " category " variable: " variable " value: " value
- ", expected: " expected " tol: " tol " units: " units " status: " status " comment: " comment)
- ;; (db:delay-if-busy dbdat)
- (sqlite3:execute db "INSERT OR REPLACE INTO test_data (test_id,category,variable,value,expected,tol,units,comment,status,type) VALUES (?,?,?,?,?,?,?,?,?,?);"
- test-id category variable value expected tol units (if comment comment "") status type)))
- csvlist)))))
-
-;; This routine moved from tdb.scm, tdb:read-test-data
-;;
-(define (db:read-test-data dbstruct run-id test-id categorypatt)
- (let* ((res '()))
- (db:with-db
- dbstruct #f #f
- (lambda (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)
- (reverse res)))))
-
-;; This routine moved from tdb.scm, :read-test-data
-;;
-(define (db:read-test-data* dbstruct run-id test-id categorypatt varpatt)
- (let* ((res '()))
- (db:with-db
- dbstruct #f #f
- (lambda (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)
- (reverse res)))))
-
-
-;;======================================================================
-;; Misc. test related queries
-;;======================================================================
-
-(define (db:get-run-ids-matching-target dbstruct keynames target res runname testpatt statepatt statuspatt)
- (db:with-db
- dbstruct #f #f
- (lambda (db)
- (let* ((row-ids '())
- (keystr (string-intersperse
- (map (lambda (key val)
- (conc key " like '" val "'"))
- keynames
- (string-split target "/"))
- " AND "))
- ;; (testqry (tests:match->sqlqry testpatt))
- (runsqry (sqlite3:prepare db (conc "SELECT id FROM runs WHERE " keystr " AND runname LIKE '" runname "';"))))
- ;; (debug:print 8 *default-log-port* "db:test-get-paths-matching-keynames-target-new\n runsqry=" runsqry "\n tstsqry=" testqry)
- (sqlite3:for-each-row
- (lambda (rid)
- (set! row-ids (cons rid row-ids)))
- runsqry)
- (sqlite3:finalize! runsqry)
- row-ids))))
-
-;; finds latest matching all patts for given run-id
-;;
-(define (db:test-get-paths-matching-keynames-target-new dbstruct run-id keynames target res testpatt statepatt statuspatt runname)
- (let* ((testqry (tests:match->sqlqry testpatt))
- (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)
- (sqlite3:for-each-row
- (lambda (p)
- (set! res (cons p res)))
- db
- tstsqry
- run-id)
- res))))
-
-(define (db:test-toplevel-num-items dbstruct run-id testname)
- (db:with-db
- dbstruct
- run-id
- #f
- (lambda (db)
- (let ((res 0))
- (sqlite3:for-each-row
- (lambda (num-items)
- (set! res num-items))
- db
- "SELECT count(id) FROM tests WHERE run_id=? AND testname=? AND item_path != '' AND state NOT IN ('DELETED');"
- run-id
- testname)
- res))))
-
-;;======================================================================
-;; QUEUE UP META, TEST STATUS AND STEPS REMOTE ACCESS
-;;======================================================================
-
-;; NOTE: Can remove the regex and base64 encoding for zmq
-(define (db:obj->string obj #!key (transport 'http))
- (case transport
- ;; ((fs) obj)
- ((http fs)
- (string-substitute
- (regexp "=") "_"
- (base64:base64-encode
- (z3:encode-buffer
- (with-output-to-string
- (lambda ()(serialize obj))))) ;; BB: serialize - this is what causes problems between different builds of megatest communicating. serialize is sensitive to binary image of mtest.
- #t))
- ((zmq nmsg)(with-output-to-string (lambda ()(serialize obj))))
- (else obj))) ;; rpc
-
-(define (db:string->obj msg #!key (transport 'http))
- (case transport
- ;; ((fs) msg)
- ((http fs)
- (if (string? msg)
- (with-input-from-string
- (z3:decode-buffer
- (base64:base64-decode
- (string-substitute
- (regexp "_") "=" msg #t)))
- (lambda ()(deserialize)))
- (begin
- (debug:print-error 0 *default-log-port* "reception failed. Received \"" msg "\" but cannot translate it.")
- (print-call-chain (current-error-port))
- msg))) ;; crude reply for when things go awry
- ((zmq nmsg)(with-input-from-string msg (lambda ()(deserialize))))
- (else msg))) ;; rpc
-
-;; ; This is to be the big daddy call NOPE: Replaced by db:set-state-status-and-roll-up-items
-;; ;
-;; define (db:test-set-state-status dbstruct run-id test-id state status msg)
-;; (let ((dbdat (db:get-db dbstruct run-id)))
-;; (if (member state '("LAUNCHED" "REMOTEHOSTSTART"))
-;; (db:general-call dbdat 'set-test-start-time (list test-id)))
-;; ;; (if msg
-;; ;; (db:general-call dbdat 'state-status-msg (list state status msg test-id))
-;; ;; (db:general-call dbdat 'state-status (list state status test-id)))
-;; (db:set-state-status-and-roll-up-items dbstruct run-id test-id #f state status msg)
-;; ;; process the test_data table
-;; (if (and test-id state status (equal? status "AUTO"))
-;; (db:test-data-rollup dbstruct run-id test-id status))
-;; (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
-;;
-(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)
- (db:get-test-info-by-id dbstruct run-id test-name) ;; test-name is actually a test-id
- (db:get-test-info dbstruct run-id test-name item-path)))
- (test-id (db:test-get-id testdat))
- (test-name (if (number? test-name)
- (db:test-get-testname testdat)
- test-name))
- (item-path (db:test-get-item-path testdat))
- (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)))
- (mutex-lock! *db-transaction-mutex*)
- (db:with-db
- dbstruct #f #f
- (lambda (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
- (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)))
- ;; (non-completes (filter (lambda (x)
- ;; (not (equal? (dbr:counts-state x) "COMPLETED")))
- ;; state-status-counts))
- (all-curr-states (common:special-sort ;; worst -> best (sort of)
- (delete-duplicates
- (if (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 (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))))
- ;; (if (> running 0)
- ;; "RUNNING"
- ;; (if (> bad-not-started 0)
- ;; "COMPLETED"
- ;; (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")
-
- ;; (print "bad-not-supported: " bad-not-support " all-curr-states: " all-curr-states " all-curr-statuses: " all-curr-states)
- ;; " newstate: " newstate " newstatus: " newstatus)
- ;; NB// Pass the db so it is part of the transaction
- (debug:print 4 *default-log-port* "BB> tl-test-id="tl-test-id" ; "test-name":"item-path"> bad-not-started="bad-not-started" newstate="newstate" newstatus="newstatus" num-non-completes="num-non-completes" non-completes="non-completes "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)))) " | "))
- state-status-counts))
-
- ); end debug:print
- (if tl-test-id
- (db:test-set-state-status db run-id tl-test-id newstate newstatus #f)) ;; we are still in the transaction - must access the db and not the dbstruct
- ))))))
-
- (mutex-unlock! *db-transaction-mutex*)
- (if (and test-id state status (equal? status "AUTO"))
- (db:test-data-rollup dbstruct run-id test-id status))
- tr-res)))))
-;; BBnote: db:get-all-state-status-counts-for-test returns dbr:counts object aggregating state and status of items of a given test, *not including rollup state/status*
-(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)
- (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.
- "SELECT state,status,count(id) FROM tests WHERE run_id=? AND testname=? AND item_path != '' AND item_path !=? GROUP BY state,status;"
- run-id test-name item-path))))
-
- ;; add current item to tally outside of sql query
- (match-countrec-lambda (lambda (countrec)
- (and (equal? (dbr:counts-state countrec) item-state)
- (equal? (dbr:counts-status countrec) item-status))))
-
- (already-have-count-rec-list
- (filter match-countrec-lambda other-items-count-recs)) ;; will have either 0 or 1 count recs depending if another item shares this item's state/status
-
- (updated-count-rec (if (null? already-have-count-rec-list)
- (make-dbr:counts state: item-state status: item-status count: 1)
- (let* ((our-count-rec (car already-have-count-rec-list))
- (new-count (add1 (dbr:counts-count our-count-rec))))
- (make-dbr:counts state: item-state status: item-status count: new-count))))
-
- (nonmatch-countrec-lambda (lambda (countrec) (not (match-countrec-lambda countrec))))
-
- (unrelated-rec-list
- (filter nonmatch-countrec-lambda other-items-count-recs)))
-
- (cons updated-count-rec unrelated-rec-list)))
-
-;; (define (db:get-all-item-states db run-id test-name)
-;; (sqlite3:map-row
-;; (lambda (a) a)
-;; db
-;; "SELECT DISTINCT state FROM tests WHERE item_path != '' AND state != 'DELETED' AND run_id=? AND testname=?"
-;; run-id test-name))
-;;
-;; (define (db:get-all-item-statuses db run-id test-name)
-;; (sqlite3:map-row
-;; (lambda (a) a)
-;; db
-;; "SELECT DISTINCT status FROM tests WHERE item_path != '' AND state != 'DELETED' AND state='COMPLETED' AND run_id=? AND testname=?"
-;; run-id test-name))
-
-(define (db:test-get-logfile-info dbstruct run-id test-name)
- (db:with-db
- dbstruct
- run-id
- #f
- (lambda (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)))
- (set! logf final_logf)
- (set! res (list path final_logf))
- (if (directory? path)
- (debug:print 2 *default-log-port* "Found path: " path)
- (debug:print 2 *default-log-port* "No such path: " path))) ;; )
- db
- "SELECT rundir,final_logf FROM tests WHERE testname=? AND item_path='' AND run_id=?;"
- test-name run-id)
- res))))
-
-;;======================================================================
-;; A G R E G A T E D T R A N S A C T I O N D B W R I T E S
-;;======================================================================
-
-(define db:queries
- (list '(update-run-duration "UPDATE tests SET run_duration=? WHERE id=?;")
-
- ;; TESTS
- '(register-test "INSERT OR IGNORE INTO tests (run_id,testname,event_time,item_path,state,status) VALUES (?,?,strftime('%s','now'),?,'NOT_STARTED','n/a');")
- ;; Test state and status
- '(set-test-state "UPDATE tests SET state=? WHERE id=?;")
- '(set-test-status "UPDATE tests SET state=? WHERE id=?;")
- '(state-status "UPDATE tests SET state=?,status=? WHERE id=?;") ;; DONE
- '(state-status-msg "UPDATE tests SET state=?,status=?,comment=? WHERE id=?;") ;; DONE
- ;; Test comment
- '(set-test-comment "UPDATE tests SET comment=? WHERE id=?;")
- '(set-test-start-time "UPDATE tests SET event_time=strftime('%s','now') WHERE id=?;") ;; DONE
- '(pass-fail-counts "UPDATE tests SET pass_count=?,fail_count=? WHERE id=?;")
- ;; test_data-pf-rollup is used to set a tests PASS/FAIL based on the pass/fail info from the steps
- '(test_data-pf-rollup "UPDATE tests
- SET status=CASE WHEN (SELECT fail_count FROM tests WHERE id=?) > 0
- THEN 'FAIL'
- WHEN (SELECT pass_count FROM tests WHERE id=?) > 0 AND
- (SELECT status FROM tests WHERE id=?) NOT IN ('WARN','FAIL')
- THEN 'PASS'
- ELSE status
- END WHERE id=?;") ;; DONE
- '(test-set-log "UPDATE tests SET final_logf=? WHERE id=?;") ;; DONE
- ;; '(test-set-rundir-by-test-id "UPDATE tests SET rundir=? WHERE id=?") ;; DONE
- ;; '(test-set-rundir "UPDATE tests SET rundir=? AND testname=? AND item_path=?;") ;; DONE
- '(test-set-rundir-shortdir "UPDATE tests SET rundir=?,shortdir=? WHERE testname=? AND item_path=? AND run_id=?;") ;; BROKEN!!! NEEDS run-id
- '(delete-tests-in-state ;; "DELETE FROM tests WHERE state=?;") ;; DONE
- "UPDATE tests SET state='DELETED' WHERE state=?")
- '(tests:test-set-toplog "UPDATE tests SET final_logf=? WHERE run_id=? AND testname=? AND item_path='';")
- '(update-cpuload-diskfree "UPDATE tests SET cpuload=?,diskfree=? WHERE id=?;") ;; DONE
- '(update-uname-host "UPDATE tests SET uname=?,host=? WHERE id=?;") ;; DONE
- '(update-test-rundat "INSERT INTO test_rundat (test_id,update_time,cpuload,diskfree,diskusage,run_duration) VALUES (?,?,?,?,?,?);")
- '(update-test-state "UPDATE tests SET state=? WHERE state=? AND run_id=? AND testname=? AND NOT (item_path='' AND testname IN (SELECT DISTINCT testname FROM tests WHERE testname=? AND item_path != ''));")
- '(update-test-status "UPDATE tests SET status=? WHERE status like ? AND run_id=? AND testname=? AND NOT (item_path='' AND testname IN (SELECT DISTINCT testname FROM tests WHERE testname=? AND item_path != ''));")
- ;; stuff for set-state-status-and-roll-up-items
- '(update-pass-fail-counts "UPDATE tests
- SET fail_count=(SELECT count(id) FROM tests WHERE testname=? AND item_path != '' AND status IN ('FAIL','CHECK','INCOMPLETE','ABORT')),
- pass_count=(SELECT count(id) FROM tests WHERE testname=? AND item_path != '' AND status IN ('PASS','WARN','WAIVED'))
- WHERE testname=? AND item_path='' AND run_id=?;") ;; DONE ;; BROKEN!!! NEEDS run-id
- '(top-test-set-running "UPDATE tests SET state='RUNNING' WHERE testname=? AND item_path='' AND run_id=?;") ;; DONE ;; BROKEN!!! NEEDS run-id
-
- ;; NOT USED
- ;;
- ;; Might be the following top-test-set-per-pf-counts query could be better based off of something like this:
- ;;
- ;; select state,status,count(state) from tests where run_id=59 AND testname='runfirst' group by state,status;
- ;;
- '(top-test-set-per-pf-counts "UPDATE tests
- SET state=CASE
- WHEN (SELECT count(id) FROM tests
- WHERE testname=?
- AND item_path != ''
- AND status NOT IN ('n/a')
- AND state in ('NOT_STARTED')) > 0 THEN 'UNKNOWN'
- WHEN (SELECT count(id) FROM tests
- WHERE testname=?
- AND item_path != ''
- AND (status NOT IN ('TEN_STRIKES','BLOCKED') OR status IN ('INCOMPLETE'))
- AND state in ('RUNNING','NOT_STARTED','LAUNCHED','REMOTEHOSTSTART')) > 0 THEN 'RUNNING'
- WHEN (SELECT count(id) FROM tests
- WHERE testname=?
- AND item_path != ''
- AND state NOT IN ('COMPLETED','DELETED')) = 0 THEN 'COMPLETED'
- WHEN (SELECT count(id) FROM tests
- WHERE testname=?
- AND item_path != ''
- AND state = 'NOT_STARTED') > 0 THEN 'NOT_STARTED'
- ELSE 'UNKNOWN' END,
- status=CASE
- WHEN fail_count > 0 THEN 'FAIL'
- WHEN (SELECT count(id) FROM tests
- WHERE testname=?
- AND item_path != ''
- AND state IN ('BLOCKED','INCOMPLETE')) > 0 THEN 'FAIL'
- WHEN (SELECT count(id) FROM tests
- WHERE testname=?
- AND item_path != ''
- AND state NOT IN ('DELETED')
- AND status IN ('INCOMPLETE','ABORT')) > 0 THEN 'ABORT'
- WHEN (SELECT count(id) FROM tests
- WHERE testname=?
- AND item_path != ''
- AND state NOT IN ('DELETED')
- AND status = 'AUTO') > 0 THEN 'AUTO'
- WHEN (SELECT count(id) FROM tests
- WHERE testname=?
- AND item_path != ''
- AND state NOT IN ('DELETED')
- AND status IN ('STUCK/INCOMPLETE', 'INCOMPLETE')) > 0 THEN 'INCOMPLETE'
- WHEN (SELECT count(id) FROM tests
- WHERE testname=?
- AND item_path != ''
- AND state IN ('COMPLETED','STUCK/INCOMPLETE','INCOMPLETE')
- AND status = 'FAIL') > 0 THEN 'FAIL'
- WHEN (SELECT count(id) FROM tests
- WHERE testname=?
- AND item_path != ''
- AND state NOT IN ('DELETED')
- AND status = 'CHECK') > 0 THEN 'CHECK'
- WHEN (SELECT count(id) FROM tests
- WHERE testname=?
- AND item_path != ''
- AND state NOT IN ('DELETED')
- AND status = 'SKIP') > 0 THEN 'SKIP'
- WHEN (SELECT count(id) FROM tests
- WHERE testname=?
- AND item_path != ''
- AND state NOT IN ('DELETED')
- AND status = 'WARN') > 0 THEN 'WARN'
- WHEN (SELECT count(id) FROM tests
- WHERE testname=?
- AND item_path != ''
- AND state NOT IN ('DELETED')
- AND status = 'WAIVED') > 0 THEN 'WAIVED'
- WHEN (SELECT count(id) FROM tests
- WHERE testname=?
- AND item_path != ''
- AND state NOT IN ('DELETED')
- AND status NOT IN ('PASS','FAIL','WARN','WAIVED')) > 0 THEN 'ABORT'
- WHEN (SELECT count(id) FROM tests
- WHERE testname=?
- AND item_path != ''
- AND state='NOT_STARTED') > 0 THEN 'n/a'
- WHEN (SELECT count(id) FROM tests
- WHERE testname=?
- AND item_path != ''
- AND state = 'COMPLETED'
- AND status = 'PASS') > 0 THEN 'PASS'
- WHEN pass_count > 0 AND fail_count=0 THEN 'PASS'
- ELSE 'UNKNOWN' END
- WHERE testname=? AND item_path='';") ;; DONE ;; BROKEN!!! NEEDS run-id
-
- ;; STEPS
- '(delete-test-step-records "UPDATE test_steps SET status='DELETED' WHERE test_id=?;")
- '(delete-test-data-records "UPDATE test_data SET status='DELETED' WHERE test_id=?;") ;; using status since no state field
- ))
-
-(define (db:lookup-query qry-name)
- (let ((q (alist-ref qry-name db:queries)))
- (if q (car q) #f)))
-
-;; do not run these as part of the transaction
-(define db:special-queries '(rollup-tests-pass-fail
- ;; db:set-state-status-and-roll-up-items ;; WHY NOT!?
- login
- immediate
- flush
- sync
- set-verbosity
- killserver
- ))
-
-(define (db:login dbstruct calling-path calling-version client-signature)
- (cond
- ((not (equal? calling-path *toppath*))
- (list #f "Login failed due to mismatch paths: " calling-path ", " *toppath*))
- ;; ((not (equal? *run-id* run-id))
- ;; (list #f "Login failed due to mismatch run-id: " run-id ", " *run-id*))
- ((not (equal? megatest-version calling-version))
- (list #f "Login failed due to mismatch megatest version: " calling-version ", " megatest-version))
- (else
- (hash-table-set! *logged-in-clients* client-signature (current-seconds))
- '(#t "successful login"))))
-
-(define (db:general-call dbstruct stmtname params)
- (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)
- (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
- (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;"
- run-id testname)
- res)))
-
-(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)
- (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 ))
-
-(define (db:set-top-level-from-items dbstruct run-id testname)
- (let* ((summ (db:get-state-status-summary dbstruct run-id testname))
- (find (lambda (state status)
- (if (null? summ)
- #f
- (let loop ((hed (car summ))
- (tal (cdr summ)))
- (if (and (string-match state (vector-ref hed 0))
- (string-match status (vector-ref hed 1)))
- hed
- (if (null? tal)
- #f
- (loop (car tal)(cdr tal)))))))))
-
-
- ;;; E D I T M E ! !
-
-
- (cond
- ((> (find "COMPLETED" ".*") 0) #f))))
-
-
-
-;; get the previous records for when these tests were run where all keys match but runname
-;; NB// Merge this with test:get-previous-test-run-records? This one looks for all matching tests
-;; can use wildcards. Also can likely be factored in with get test paths?
-;;
-;; Run this remotely!!
-;;
-(define (db:get-matching-previous-test-run-records dbstruct run-id test-name item-path)
- (let* ((keys (db:get-keys dbstruct))
- (selstr (string-intersperse keys ","))
- (qrystr (string-intersperse (map (lambda (x)(conc x "=?")) keys) " AND "))
- (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)
- (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)))
- (if (not keyvals)
- '()
- (let ((prev-run-ids '()))
- (db:with-db
- dbstruct #f #f
- (lambda (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)))))
- ;; collect all matching tests for the runs then
- ;; extract the most recent test and return that.
- (debug:print 4 *default-log-port* "selstr: " selstr ", qrystr: " qrystr ", keyvals: " keyvals
- ", previous run ids found: " prev-run-ids)
- (if (null? prev-run-ids) '() ;; no previous runs? return null
- (let loop ((hed (car prev-run-ids))
- (tal (cdr prev-run-ids)))
- (let ((results (db:get-tests-for-run dbstruct hed (conc test-name "/" item-path) '() '() #f #f #f #f #f #f #f 'normal)))
- (debug:print 4 *default-log-port* "Got tests for run-id " run-id ", test-name " test-name
- ", item-path " item-path " results: " (intersperse results "\n"))
- ;; Keep only the youngest of any test/item combination
- (for-each
- (lambda (testdat)
- (let* ((full-testname (conc (db:test-get-testname testdat) "/" (db:test-get-item-path testdat)))
- (stored-test (hash-table-ref/default tests-hash full-testname #f)))
- (if (or (not stored-test)
- (and stored-test
- (> (db:test-get-event_time testdat)(db:test-get-event_time stored-test))))
- ;; this test is younger, store it in the hash
- (hash-table-set! tests-hash full-testname testdat))))
- results)
- (if (null? tal)
- (map cdr (hash-table->alist tests-hash)) ;; return a list of the most recent tests
- (loop (car tal)(cdr tal))))))))))
-
-;; 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))
- (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
- (dbfj (conc dbpath "-journal")))
- (if (handle-exceptions
- exn
- (begin
- (debug:print-info 0 *default-log-port* "WARNING: failed to test for existance of " dbfj)
- (thread-sleep! 1)
- (db:delay-if-busy count (- count 1)))
- (common:file-exists? dbfj))
- (case count
- ((6)
- (thread-sleep! 0.2)
- (db:delay-if-busy count: 5))
- ((5)
- (thread-sleep! 0.4)
- (db:delay-if-busy count: 4))
- ((4)
- (thread-sleep! 0.8)
- (db:delay-if-busy count: 3))
- ((3)
- (thread-sleep! 1.6)
- (db:delay-if-busy count: 2))
- ((2)
- (thread-sleep! 3.2)
- (db:delay-if-busy count: 1))
- ((1)
- (thread-sleep! 6.4)
- (db:delay-if-busy count: 0))
- (else
- (debug:print-info 0 *default-log-port* "delaying db access due to high database load.")
- (thread-sleep! 12.8))))
- db)
- "bogus result from db:delay-if-busy")))
-
-(define (db:test-get-records-for-index-file dbstruct run-id test-name)
- (let ((res '()))
- (db:with-db
- dbstruct
- run-id
- #f
- (lambda (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?
- test-name
- run-id)
- res))))
-
-;;======================================================================
-;; Tests meta data
-;;======================================================================
-
-;; returns a hash table of tags to tests
-;;
-(define (db:get-tests-tags dbstruct)
- (db:with-db
- dbstruct #f #f
- (lambda (db)
- (let* ((res (make-hash-table)))
- (sqlite3:for-each-row
- (lambda (testname tags-in)
- (let ((tags (string-split tags-in ",")))
- (for-each
- (lambda (tag)
- (hash-table-set! res tag
- (delete-duplicates
- (cons testname (hash-table-ref/default res tag '())))))
- tags)))
- db
- "SELECT testname,tags FROM test_meta")
- (hash-table->alist res)))))
-
-;; read the record given a testname
-(define (db:testmeta-get-record dbstruct testname)
- (let ((res #f))
- (db:with-db
- dbstruct
- #f
- #f
- (lambda (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=?;"
- testname)
- res))))
-
-;; create a new record for a given testname
-(define (db:testmeta-add-record dbstruct testname)
- (db:with-db dbstruct #f #f
- (lambda (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)
- (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)
- (let ((res '()))
- (sqlite3:for-each-row
- (lambda (a . b)
- (set! res (cons (apply vector a b) res)))
- db
- "SELECT id,testname,author,owner,description,reviewed,iterated,avg_runtime,avg_disk,tags,jobgroup FROM test_meta;")
- res))))
-
-;;======================================================================
-;; M I S C M A N A G E M E N T I T E M S
-;;======================================================================
-
-;; A routine to map itempaths using a itemmap
-;; patha and pathb must be strings or this will fail
-;;
-;; path-b is waiting on path-a
-;;
-(define (db:compare-itempaths test-b-name path-a path-b itemmaps )
- (debug:print-info 6 *default-log-port* "ITEMMAPS: " itemmaps)
- (let* ((itemmap (tests:lookup-itemmap itemmaps test-b-name)))
- (if itemmap
- (let ((path-b-mapped (db:multi-pattern-apply path-b itemmap)))
- (debug:print-info 6 *default-log-port* "ITEMMAP is " itemmap ", path: " path-b ", mapped path: " path-b-mapped)
- (equal? path-a path-b-mapped))
- (equal? path-b path-a))))
-
-;; A routine to convert test/itempath using a itemmap
-;; NOTE: to process only an itempath (i.e. no prepended testname)
-;; just call db:multi-pattern-apply
-;;
-(define (db:convert-test-itempath path-in itemmap)
- (debug:print-info 6 *default-log-port* "ITEMMAP is " itemmap)
- (let* ((path-parts (string-split path-in "/"))
- (test-name (if (null? path-parts) "" (car path-parts)))
- (item-path (string-intersperse (if (null? path-parts) '() (cdr path-parts)) "/")))
- (conc test-name "/"
- (db:multi-pattern-apply item-path itemmap))))
-
-;; patterns are:
-;; "rx1" "replacement1"\n
-;; "rx2" "replacement2"
-;; etc.
-;;
-(define (db:multi-pattern-apply item-path itemmap)
- (let ((all-patts (string-split itemmap "\n")))
- (if (null? all-patts)
- item-path
- (let loop ((hed (car all-patts))
- (tal (cdr all-patts))
- (res item-path))
- (let* ((parts (string-split hed))
- (patt (car parts))
-
- (repl (if (> (length parts) 1)(cadr parts) ""))
-
- (newr (if (and patt repl)
- (begin
- (handle-exceptions
- exn
- (begin
- (debug:print 0 *default-log-port*
- "WARNING: itemmap has problem \"" itemmap "\", patt: " patt ", repl: " repl)
- res)
- (string-substitute patt repl res))
-
-
- )
- (begin
- (debug:print 0 *default-log-port*
- "WARNING: itemmap has problem \"" itemmap "\", patt: " patt ", repl: " repl)
- res))))
- (if (null? tal)
- newr
- (loop (car tal)(cdr tal) newr)))))))
-
-
-
-
-;; the new prereqs calculation, looks also at itempath if specified
-;; all prereqs must be met
-;; if prereq test with itempath='' is COMPLETED and PASS, WARN, CHECK, or WAIVED then prereq is met
-;; if prereq test with itempath=ref-item-path and COMPLETED with PASS, WARN, CHECK, or WAIVED then prereq is met
-;;
-;; Note: mode 'normal means that tests must be COMPLETED and ok (i.e. PASS, WARN, CHECK, SKIP or WAIVED)
-;; mode 'toplevel means that tests must be COMPLETED only
-;; mode 'itemmatch or 'itemwait means that tests items must be COMPLETED and (PASS|WARN|WAIVED|CHECK) [[ NB// NOT IMPLEMENTED YET ]]
-;; mode 'exclusive means this test/item cannot run if the same test/item is LAUNCHED,REMOTEHOSTSTART or RUNNING
-;;
-;; IDEA for consideration:
-;; 1. collect all tests "upstream"
-;; 2. any NOT completed and good? if yes => return those as prereqs not met, if no => return null list
-;;
-;; (define (db:get-prereqs-not-met dbstruct run-id waitons ref-item-path mode)
-(define (db:get-prereqs-not-met dbstruct run-id waitons ref-test-name ref-item-path mode itemmaps) ;; #!key (mode '(normal))(itemmap #f))
- ;; BBnote - rollup of an itemized test's overall state/status done in db:set-state-status-and-roll-up-items
- (append
- (if (member 'exclusive mode)
- (let ((running-tests (db:get-tests-for-run dbstruct
- #f ;; run-id of #f means for all runs.
- (if (string=? ref-item-path "") ;; testpatt
- ref-test-name
- (conc ref-test-name "/" ref-item-path))
- '("LAUNCHED" "REMOTEHOSTSTART" "RUNNING") ;; states
- '() ;; statuses
- #f ;; offset
- #f ;; limit
- #f ;; not-in
- #f ;; sort by
- #f ;; sort order
- 'shortlist ;; query type
- 0 ;; last update, beginning of time ....
- #f ;; mode
- )))
- ;;(map (lambda (testdat)
- ;; (if (equal? (db:test-get-item-path testdat) "")
- ;; (db:test-get-testname testdat)
- ;; (conc (db:test-get-testname testdat)
- ;; "/"
- ;; (db:test-get-item-path testdat))))
- running-tests) ;; calling functions want the entire data
- '())
-
- ;; collection of: for each waiton -
- ;; if this ref-test-name is an item in an itemized test and mode is itemwait/itemmatch:
- ;; if waiton is not itemized - if waiton is not both completed and in ok status, add as unmet prerequisite
- ;; if waiton is itemized:
- ;; and waiton's items are not expanded, add as unmet prerequisite
- ;; else if matching waiton item is not both completed and in an ok status, add as unmet prerequisite
- ;; else
- ;; if waiton toplevel is not in both completed and ok status, add as unmet prerequisite
-
- (if (or (not waitons)
- (null? waitons))
- '()
- (let* ((ref-test-itemized-mode (not (null? (lset-intersection eq? mode '(itemmatch itemwait))))) ;; how is this different from using member?
- (ref-test-toplevel-mode (not (null? (lset-intersection eq? mode '(toplevel)))))
- (ref-test-is-toplevel (equal? ref-item-path ""))
- (ref-test-is-item (not ref-test-is-toplevel))
- (unmet-pre-reqs '())
- (result '())
- (unmet-prereq-items '())
- )
- (for-each ; waitons
- (lambda (waitontest-name)
- ;; by getting the tests with matching name we are looking only at the matching test
- ;; and related sub items
- ;; next should be using mt:get-tests-for-run?
-
- (let (;(waiton-is-itemized ...)
- ;(waiton-items-are-expanded ...)
- (waiton-tests (db:get-tests-for-run-state-status dbstruct run-id waitontest-name))
- (ever-seen #f)
- (parent-waiton-met #f)
- (item-waiton-met #f)
-
- )
- (for-each ; test expanded from waiton
- (lambda (waiton-test)
- (let* ((waiton-state (db:test-get-state waiton-test))
- (waiton-status (db:test-get-status waiton-test))
- (waiton-item-path (db:test-get-item-path waiton-test)) ;; BB- this is the upstream itempath
- (waiton-test-name (db:test-get-testname waiton-test))
- (waiton-is-toplevel (equal? waiton-item-path ""))
- (waiton-is-item (not waiton-is-toplevel))
- (waiton-is-completed (member waiton-state *common:ended-states*))
- (waiton-is-running (member waiton-state *common:running-states*))
- (waiton-is-killed (member waiton-state *common:badly-ended-states*))
- (waiton-is-ok (member waiton-status *common:well-ended-states*))
- ;; testname-b path-a path-b
- (same-itempath (db:compare-itempaths ref-test-name waiton-item-path ref-item-path itemmaps)) ;; (equal? ref-item-path waiton-item-path)))
- (real-ref-test-name (car (string-split ref-test-name "/"))) ;; I THINK ref-test-name SHOULD NEVER HAVE THE ITEM_PATH!
- (test-and-ref-are-same (equal? real-ref-test-name waiton-test-name)))
- (debug:print 4 *default-log-port* "waiton-test-name " waiton-test-name " ref-test-name: " ref-test-name " test-and-ref-are-same: " test-and-ref-are-same)
- (set! ever-seen #t)
- ;;(BB> "***consider waiton "waiton-test"/"waiton-item-path"***")
- (cond
- ;; case 0 - toplevel of an itemized test, at least one item in prereq has completed
- ((and waiton-is-item ref-test-is-toplevel ref-test-itemized-mode waiton-is-completed)
- (set! parent-waiton-met #t))
-
- ;; case 1, non-item (parent test) is
- ((and waiton-is-toplevel ;; this is the parent test of the waiton being examined
- waiton-is-completed
- ;;(BB> "cond1")
- (or waiton-is-ok ref-test-toplevel-mode)) ;; itemmatch itemwait))))))
- (set! parent-waiton-met #t))
- ;; Special case for toplevel and KILLED
- ((and waiton-is-toplevel ;; this is the parent test
- waiton-is-killed
- (member 'toplevel mode))
- ;;(BB> "cond2")
- (set! parent-waiton-met #t))
- ;; For itemwait mode IFF the previous matching item is good the set parent-waiton-met
- ((and ref-test-itemized-mode ref-test-is-item same-itempath)
- ;;(BB> "cond3")
- (if (and waiton-is-completed (or waiton-is-ok ref-test-toplevel-mode))
- (set! item-waiton-met #t)
- (set! unmet-prereq-items (cons waiton-test unmet-prereq-items)))
- (if (and waiton-is-toplevel ;; if upstream rollup test is completed, parent-waiton-met is set
- (or waiton-is-completed waiton-is-running))
- (set! parent-waiton-met #t)))
- ;; normal checking of parent items, any parent or parent item not ok blocks running
- ((and waiton-is-completed
- (or waiton-is-ok
- (member 'toplevel mode)) ;; toplevel does not block on FAIL
- (and waiton-is-ok (member 'itemmatch mode) ;; itemmatch blocks on not ok ;; TODO: THIS IS PROBABLY A BUG. ITEMMATCH AND ITEMWAIT ARE SYNONYMS!! WHAT HAPPENED OT ITEMWAIT???
- ))
- ;;(BB> "cond4")
- (set! item-waiton-met #t))
- ((and waiton-is-completed waiton-is-ok same-itempath)
- ;;(BB> "cond5")
- (set! item-waiton-met #t))
- ((and waiton-is-completed waiton-is-ok test-and-ref-are-same) ;; probably from [waitons] table
- (set! item-waiton-met #t))
- (else
- #t
- ;;(BB> "condelse")
- ))))
- waiton-tests)
- ;; both requirements, parent and item-waiton must be met to NOT add item to
- ;; prereq's not met list
- ;; (BB>
- ;; "\n* waiton-tests "waiton-tests
- ;; "\n* parent-waiton-met "parent-waiton-met
- ;; "\n* item-waiton-met "item-waiton-met
- ;; "\n* ever-seen "ever-seen
- ;; "\n* ref-test-itemized-mode "ref-test-itemized-mode
- ;; "\n* unmet-prereq-items "unmet-prereq-items
- ;; "\n* result (pre) "result
- ;; "\n* ever-seen "ever-seen
- ;; "\n")
-
- (cond
- ((and ref-test-itemized-mode ref-test-is-item (not (null? unmet-prereq-items)))
- (set! result (append unmet-prereq-items result)))
- ((not (or parent-waiton-met item-waiton-met))
- (set! result (append (if (null? waiton-tests) (list waitontest-name) waiton-tests) result))) ;; appends the string if the full record is not available
- ;; if the test is not found then clearly the waiton is not met...
- ;; (if (not ever-seen)(set! result (cons waitontest-name result)))))
- ((not ever-seen)
- (set! result (append (if (null? waiton-tests)(list waitontest-name) waiton-tests) result))))))
- waitons)
- (delete-duplicates result)))))
-;;======================================================================
-;; 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)
- (conc key " like '" val "'"))
- 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)
- `((runs . ,(fold-row backcons '() db run-qry))
- (tests . ,(fold-row backcons '() db test-qry))
- (test_steps . ,(fold-row backcons '() db (conc "SELECT id FROM test_steps WHERE test_id in (" test-qry ")")))
- (test_data . ,(fold-row backcons '() db (conc "SELECT id FROM test_data WHERE test_id in (" test-qry ")" )))
- ))))))
-
-;;======================================================================
-;; 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 ...) ...))
-;;
-(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 . ,(fold-row backcons '() db "SELECT id FROM runs WHERE last_update>=?" since-time))
- (tests . ,(fold-row backcons '() db "SELECT id FROM tests WHERE last_update>=?" since-time))
- (test_steps . ,(fold-row backcons '() db "SELECT id FROM test_steps WHERE last_update>=?" since-time))
- (test_data . ,(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 . ,(fold-row backcons '() db "SELECT id FROM run_stats WHERE last_update>=?" since-time))
- )))))
-
-;;======================================================================
-;; Extract ods file from the db
-;;======================================================================
-
-;; 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)
- (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))
- (windows (and pathmod (substring-index "\\" pathmod)))
- (tempdir (conc "/tmp/" (current-user-name) "/" runspatt "_" (random 10000) "_" (current-process-id)))
- (runsheader (append (list "Run Id" "Runname") ; 0 1
- (map car keypatt-alist) ; + N = length keypatt-alist
- (list "Testname" ; 2
- "Item Path" ; 3
- "Description" ; 4
- "State" ; 5
- "Status" ; 6
- "Final Log" ; 7
- "Run Duration" ; 8
- "When Run" ; 9
- "Tags" ; 10
- "Run Owner" ; 11
- "Comment" ; 12
- "Author" ; 13
- "Test Owner" ; 14
- "Reviewed" ; 15
- "Diskfree" ; 16
- "Uname" ; 17
- "Rundir" ; 18
- "Host" ; 19
- "Cpu Load" ; 20
- )))
- (results (list runsheader))
- (testdata-header (list "Run Id" "Testname" "Item Path" "Category" "Variable" "Value" "Expected" "Tol" "Units" "Status" "Comment"))
- (mainqry (conc "SELECT
- t.testname,r.id,runname," keysstr ",t.testname,
- t.item_path,tm.description,t.state,t.status,
- final_logf,run_duration,
- strftime('%m/%d/%Y %H:%M:%S',datetime(t.event_time,'unixepoch'),'localtime'),
- tm.tags,r.owner,t.comment,
- author,
- tm.owner,reviewed,
- diskfree,uname,rundir,
- host,cpuload
- FROM tests AS t JOIN runs AS r ON t.run_id=r.id JOIN test_meta AS tm ON tm.testname=t.testname
- WHERE runname LIKE ? AND " keyqry ";")))
- (debug:print 2 *default-log-port* "Using " tempdir " for constructing the ods file. keyqry: " keyqry " keystr: " keysstr " with keys: " (map cadr keypatt-alist)
- "\n mainqry: " mainqry)
- ;; "Expected Value"
- ;; "Value Found"
- ;; "Tolerance"
- (apply sqlite3:for-each-row
- (lambda (test-id . b)
- (set! test-ids (cons test-id test-ids)) ;; test-id is now testname
- (set! results (append results ;; note, drop the test-id
- (list
- (if pathmod
- (let* ((vb (apply vector b))
- (keyvals (let loop ((i 0)
- (res '()))
- (if (>= i numkeys)
- res
- (loop (+ i 1)
- (append res (list (vector-ref vb (+ i 2))))))))
- (runname (vector-ref vb 1))
- (testname (vector-ref vb (+ 2 numkeys)))
- (item-path (vector-ref vb (+ 3 numkeys)))
- (final-log (vector-ref vb (+ 7 numkeys)))
- (run-dir (vector-ref vb (+ 18 numkeys)))
- (log-fpath (conc run-dir "/" final-log))) ;; (string-intersperse keyvals "/") "/" testname "/" item-path "/"
- (debug:print 4 *default-log-port* "log: " log-fpath " exists: " (common:file-exists? log-fpath))
- (vector-set! vb (+ 7 numkeys) (if (common:file-exists? log-fpath)
- (let ((newpath (conc pathmod "/"
- (string-intersperse keyvals "/")
- "/" runname "/" testname "/"
- (if (string=? item-path "") "" (conc "/" item-path))
- final-log)))
- ;; for now throw away newpath and use the log-fpath conc'd with pathmod
- (set! newpath (conc pathmod log-fpath))
- (if windows (string-translate newpath "/" "\\") newpath))
- (if (debug:debug-mode 1)
- (conc final-log " not-found")
- "")))
- (vector->list vb))
- b)))))
- db
- mainqry
- runspatt (map cadr keypatt-alist))
- (debug:print 2 *default-log-port* "Found " (length test-ids) " records")
- (set! results (list (cons "Runs" results)))
- ;; now, for each test, collect the test_data info and add a new sheet
- (for-each
- (lambda (test-id)
- (let ((test-data (list testdata-header))
- (curr-test-name #f))
- (sqlite3:for-each-row
- (lambda (run-id testname item-path category variable value expected tol units status comment)
- (set! curr-test-name testname)
- (set! test-data (append test-data (list (list run-id testname item-path category variable value expected tol units status comment)))))
- db
- ;; "SELECT run_id,testname,item_path,category,variable,td.value AS value,expected,tol,units,td.status AS status,td.comment AS comment FROM test_data AS td INNER JOIN tests ON tests.id=td.test_id WHERE test_id=?;"
- "SELECT run_id,testname,item_path,category,variable,td.value AS value,td.expected,td.tol,td.units,td.status AS status,td.comment AS comment FROM test_data AS td INNER JOIN tests ON tests.id=td.test_id WHERE testname=?;"
- test-id)
- (if curr-test-name
- (set! results (append results (list (cons curr-test-name test-data)))))
- ))
- (sort (delete-duplicates test-ids) string<=))
- (system (conc "mkdir -p " tempdir))
- ;; (pp results)
- (ods:list->ods
- tempdir
- (if (string-match (regexp "^[/~]+.*") outputfile) ;; full path?
- outputfile
- (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)
- (system "rm -rf tempdir")))
-
-;; (db:extract-ods-file db "outputfile.ods" '(("sysname" "%")("fsname" "%")("datapath" "%")) "%")
-
-
+ db)
+
+(define (db:general-sqlite-error-dump . args)
+ #t
+ (print "Got here: db:general-sqlite-error-dump"))
+(define (db:first-result-default . args)
+ #t
+ (print "Got here: db:first-result-default"))
+(define (db:get-db . args)
+ #t
+ (print "Got here: db:get-db"))
+(define (db:dbdat-get-db . args)
+ #t
+ (print "Got here: db:dbdat-get-db"))
+(define (db:dbdat-get-path . args)
+ #t
+ (print "Got here: db:dbdat-get-path"))
+(define (db:with-db . args)
+ #t
+ (print "Got here: db:with-db"))
+(define (db:set-sync . args)
+ #t
+ (print "Got here: db:set-sync"))
+(define (db:lock-create-open . args)
+ #t
+ (print "Got here: db:lock-create-open"))
+(define (db:open-db . args)
+ #t
+ (print "Got here: db:open-db"))
+(define (db:get-last-update-time . args)
+ #t
+ (print "Got here: db:get-last-update-time"))
+(define (db:setup . args)
+ #t
+ (print "Got here: db:setup"))
+(define (db:open-megatest-db . args)
+ #t
+ (print "Got here: db:open-megatest-db"))
+(define (db:sync-touched . args)
+ #t
+ (print "Got here: db:sync-touched"))
+(define (db:safely-close-sqlite3-db . args)
+ #t
+ (print "Got here: db:safely-close-sqlite3-db"))
+(define (db:close-all . args)
+ #t
+ (print "Got here: db:close-all"))
+(define (db:sync-main-list . args)
+ #t
+ (print "Got here: db:sync-main-list"))
+(define (db:sync-all-tables-list . args)
+ #t
+ (print "Got here: db:sync-all-tables-list"))
+(define (db:move-and-recreate-db . args)
+ #t
+ (print "Got here: db:move-and-recreate-db"))
+(define (db:repair-db . args)
+ #t
+ (print "Got here: db:repair-db"))
+(define (db:sync-tables . args)
+ #t
+ (print "Got here: db:sync-tables"))
+(define (db:patch-schema-rundb . args)
+ #t
+ (print "Got here: db:patch-schema-rundb"))
+(define (db:patch-schema-maindb . args)
+ #t
+ (print "Got here: db:patch-schema-maindb"))
+(define (db:adj-target . args)
+ #t
+ (print "Got here: db:adj-target"))
+(define (db:get-access-mode . args)
+ #t
+ (print "Got here: db:get-access-mode"))
+(define (db:dispatch-query . args)
+ #t
+ (print "Got here: db:dispatch-query"))
+(define (db:cache-for-read-only . args)
+ #t
+ (print "Got here: db:cache-for-read-only"))
+(define (db:multi-db-sync . args)
+ #t
+ (print "Got here: db:multi-db-sync"))
+(define (db:tmp->megatest.db-sync . args)
+ #t
+ (print "Got here: db:tmp->megatest.db-sync"))
+(define (db:sync-to-megatest.db . args)
+ #t
+ (print "Got here: db:sync-to-megatest.db"))
+(define (open-run-close-no-exception-handling . args)
+ #t
+ (print "Got here: open-run-close-no-exception-handling"))
+(define (open-run-close-exception-handling . args)
+ #t
+ (print "Got here: open-run-close-exception-handling"))
+(define (db:initialize-main-db . args)
+ #t
+ (print "Got here: db:initialize-main-db"))
+(define (db:archive-get-allocations . args)
+ #t
+ (print "Got here: db:archive-get-allocations"))
+(define (db:archive-register-disk . args)
+ #t
+ (print "Got here: db:archive-register-disk"))
+(define (db:archive-register-block-name . args)
+ #t
+ (print "Got here: db:archive-register-block-name"))
+(define (db:test-set-archive-block-id . args)
+ #t
+ (print "Got here: db:test-set-archive-block-id"))
+(define (db:test-get-archive-block-info . args)
+ #t
+ (print "Got here: db:test-get-archive-block-info"))
+(define (open-logging-db . args)
+ #t
+ (print "Got here: open-logging-db"))
+(define (db:log-local-event . args)
+ #t
+ (print "Got here: db:log-local-event"))
+(define (db:log-event . args)
+ #t
+ (print "Got here: db:log-event"))
+(define (db:have-incompletes? . args)
+ #t
+ (print "Got here: db:have-incompletes?"))
+(define (db:find-and-mark-incomplete . args)
+ #t
+ (print "Got here: db:find-and-mark-incomplete"))
+(define (db:top-test-set-per-pf-counts . args)
+ #t
+ (print "Got here: db:top-test-set-per-pf-counts"))
+(define (db:clean-up . args)
+ #t
+ (print "Got here: db:clean-up"))
+(define (db:clean-up-rundb . args)
+ #t
+ (print "Got here: db:clean-up-rundb"))
+(define (db:clean-up-maindb . args)
+ #t
+ (print "Got here: db:clean-up-maindb"))
+(define (db:get-var . args)
+ #t
+ (print "Got here: db:get-var"))
+(define (db:set-var . args)
+ #t
+ (print "Got here: db:set-var"))
+(define (db:del-var . args)
+ #t
+ (print "Got here: db:del-var"))
+(define (db:open-no-sync-db . args)
+ #t
+ (print "Got here: db:open-no-sync-db"))
+(define (db:no-sync-db . args)
+ #t
+ (print "Got here: db:no-sync-db"))
+(define (db:no-sync-set . args)
+ #t
+ (print "Got here: db:no-sync-set"))
+(define (db:no-sync-del! . args)
+ #t
+ (print "Got here: db:no-sync-del!"))
+(define (db:no-sync-get/default . args)
+ #t
+ (print "Got here: db:no-sync-get/default"))
+(define (db:no-sync-close-db . args)
+ #t
+ (print "Got here: db:no-sync-close-db"))
+(define (db:no-sync-get-lock . args)
+ #t
+ (print "Got here: db:no-sync-get-lock"))
+(define (db:get-keys . args)
+ #t
+ (print "Got here: db:get-keys"))
+(define (db:get-value-by-header . args)
+ #t
+ (print "Got here: db:get-value-by-header"))
+(define (db:get-header . args)
+ #t
+ (print "Got here: db:get-header"))
+(define (db:get-rows . args)
+ #t
+ (print "Got here: db:get-rows"))
+(define (db:get-run-times . args)
+ #t
+ (print "Got here: db:get-run-times"))
+(define (db:get-run-name-from-id . args)
+ #t
+ (print "Got here: db:get-run-name-from-id"))
+(define (db:get-run-key-val . args)
+ #t
+ (print "Got here: db:get-run-key-val"))
+(define (runs:get-std-run-fields . args)
+ #t
+ (print "Got here: runs:get-std-run-fields"))
+(define (db:patt->like . args)
+ #t
+ (print "Got here: db:patt->like"))
+(define (db:register-run . args)
+ #t
+ (print "Got here: db:register-run"))
+(define (db:get-runs . args)
+ #t
+ (print "Got here: db:get-runs"))
+(define (db:simple-get-runs . args)
+ #t
+ (print "Got here: db:simple-get-runs"))
+(define (db:get-changed-run-ids . args)
+ #t
+ (print "Got here: db:get-changed-run-ids"))
+(define (db:get-targets . args)
+ #t
+ (print "Got here: db:get-targets"))
+(define (db:get-num-runs . args)
+ #t
+ (print "Got here: db:get-num-runs"))
+(define (db:get-runs-cnt-by-patt . args)
+ #t
+ (print "Got here: db:get-runs-cnt-by-patt"))
+(define (db:get-raw-run-stats . args)
+ #t
+ (print "Got here: db:get-raw-run-stats"))
+(define (db:update-run-stats . args)
+ #t
+ (print "Got here: db:update-run-stats"))
+(define (db:get-main-run-stats . args)
+ #t
+ (print "Got here: db:get-main-run-stats"))
+(define (db:print-current-query-stats . args)
+ #t
+ (print "Got here: db:print-current-query-stats"))
+(define (db:get-all-run-ids . args)
+ #t
+ (print "Got here: db:get-all-run-ids"))
+(define (db:get-run-stats . args)
+ #t
+ (print "Got here: db:get-run-stats"))
+(define (db:get-runs-by-patt . args)
+ #t
+ (print "Got here: db:get-runs-by-patt"))
+(define (db:get-run-info . args)
+ #t
+ (print "Got here: db:get-run-info"))
+(define (db:set-comment-for-run . args)
+ #t
+ (print "Got here: db:set-comment-for-run"))
+(define (db:delete-run . args)
+ #t
+ (print "Got here: db:delete-run"))
+(define (db:update-run-event_time . args)
+ #t
+ (print "Got here: db:update-run-event_time"))
+(define (db:lock/unlock-run . args)
+ #t
+ (print "Got here: db:lock/unlock-run"))
+(define (db:set-run-status . args)
+ #t
+ (print "Got here: db:set-run-status"))
+(define (db:get-run-status . args)
+ #t
+ (print "Got here: db:get-run-status"))
+(define (db:get-key-val-pairs . args)
+ #t
+ (print "Got here: db:get-key-val-pairs"))
+(define (db:get-key-vals . args)
+ #t
+ (print "Got here: db:get-key-vals"))
+(define (db:get-target . args)
+ #t
+ (print "Got here: db:get-target"))
+(define (db:get-prev-run-ids . args)
+ #t
+ (print "Got here: db:get-prev-run-ids"))
+(define (db:get-tests-for-run . args)
+ #t
+ (print "Got here: db:get-tests-for-run"))
+(define (db:test-short-record->norm . args)
+ #t
+ (print "Got here: db:test-short-record->norm"))
+(define (db:get-tests-for-run-state-status . args)
+ #t
+ (print "Got here: db:get-tests-for-run-state-status"))
+(define (db:get-testinfo-state-status . args)
+ #t
+ (print "Got here: db:get-testinfo-state-status"))
+(define (db:get-tests-for-run-mindata . args)
+ #t
+ (print "Got here: db:get-tests-for-run-mindata"))
+(define (db:get-tests-for-runs . args)
+ #t
+ (print "Got here: db:get-tests-for-runs"))
+(define (db:delete-test-records . args)
+ #t
+ (print "Got here: db:delete-test-records"))
+(define (db:delete-old-deleted-test-records . args)
+ #t
+ (print "Got here: db:delete-old-deleted-test-records"))
+(define (db:set-tests-state-status . args)
+ #t
+ (print "Got here: db:set-tests-state-status"))
+(define (db:test-set-state-status . args)
+ #t
+ (print "Got here: db:test-set-state-status"))
+(define (db:get-count-tests-running . args)
+ #t
+ (print "Got here: db:get-count-tests-running"))
+(define (db:get-count-tests-actually-running . args)
+ #t
+ (print "Got here: db:get-count-tests-actually-running"))
+(define (db:get-count-tests-running-for-run-id . args)
+ #t
+ (print "Got here: db:get-count-tests-running-for-run-id"))
+(define (db:get-count-tests-running-for-testname . args)
+ #t
+ (print "Got here: db:get-count-tests-running-for-testname"))
+(define (db:get-count-tests-running-in-jobgroup . args)
+ #t
+ (print "Got here: db:get-count-tests-running-in-jobgroup"))
+(define (db:estimated-tests-remaining . args)
+ #t
+ (print "Got here: db:estimated-tests-remaining"))
+(define (db:get-test-id . args)
+ #t
+ (print "Got here: db:get-test-id"))
+(define (db:test-set-top-process-pid . args)
+ #t
+ (print "Got here: db:test-set-top-process-pid"))
+(define (db:test-get-top-process-pid . args)
+ #t
+ (print "Got here: db:test-get-top-process-pid"))
+(define (db:field->number . args)
+ #t
+ (print "Got here: db:field->number"))
+(define (db:get-all-tests-info-by-run-id . args)
+ #t
+ (print "Got here: db:get-all-tests-info-by-run-id"))
+(define (db:replace-test-records . args)
+ #t
+ (print "Got here: db:replace-test-records"))
+(define (db:adj-test-id . args)
+ #t
+ (print "Got here: db:adj-test-id"))
+(define (db:prep-megatest.db-adj-test-ids . args)
+ #t
+ (print "Got here: db:prep-megatest.db-adj-test-ids"))
+(define (db:prep-megatest.db-for-migration . args)
+ #t
+ (print "Got here: db:prep-megatest.db-for-migration"))
+(define (db:get-test-info-by-id . args)
+ #t
+ (print "Got here: db:get-test-info-by-id"))
+(define (db:get-test-info-by-ids . args)
+ #t
+ (print "Got here: db:get-test-info-by-ids"))
+(define (db:get-test-info . args)
+ #t
+ (print "Got here: db:get-test-info"))
+(define (db:test-get-rundir-from-test-id . args)
+ #t
+ (print "Got here: db:test-get-rundir-from-test-id"))
+(define (db:get-test-times . args)
+ #t
+ (print "Got here: db:get-test-times"))
+(define (db:get-test-times . args)
+ #t
+ (print "Got here: db:get-test-times"))
+(define (db:teststep-set-status! . args)
+ #t
+ (print "Got here: db:teststep-set-status!"))
+(define (db:get-steps-for-test . args)
+ #t
+ (print "Got here: db:get-steps-for-test"))
+(define (db:get-steps-info-by-id . args)
+ #t
+ (print "Got here: db:get-steps-info-by-id"))
+(define (db:get-steps-data . args)
+ #t
+ (print "Got here: db:get-steps-data"))
+(define (db:get-data-info-by-id . args)
+ #t
+ (print "Got here: db:get-data-info-by-id"))
+(define (db:test-data-rollup . args)
+ #t
+ (print "Got here: db:test-data-rollup"))
+(define (db:logpro-dat->csv . args)
+ #t
+ (print "Got here: db:logpro-dat->csv"))
+(define (db:csv->test-data . args)
+ #t
+ (print "Got here: db:csv->test-data"))
+(define (db:read-test-data . args)
+ #t
+ (print "Got here: db:read-test-data"))
+(define (db:read-test-data* . args)
+ #t
+ (print "Got here: db:read-test-data*"))
+(define (db:get-run-ids-matching-target . args)
+ #t
+ (print "Got here: db:get-run-ids-matching-target"))
+(define (db:test-get-paths-matching-keynames-target-new . args)
+ #t
+ (print "Got here: db:test-get-paths-matching-keynames-target-new"))
+(define (db:test-toplevel-num-items . args)
+ #t
+ (print "Got here: db:test-toplevel-num-items"))
+(define (db:obj->string . args)
+ #t
+ (print "Got here: db:obj->string"))
+(define (db:string->obj . args)
+ #t
+ (print "Got here: db:string->obj"))
+(define (db:set-state-status-and-roll-up-items . args)
+ #t
+ (print "Got here: db:set-state-status-and-roll-up-items"))
+(define (db:get-all-state-status-counts-for-test . args)
+ #t
+ (print "Got here: db:get-all-state-status-counts-for-test"))
+(define (db:test-get-logfile-info . args)
+ #t
+ (print "Got here: db:test-get-logfile-info"))
+(define (db:lookup-query . args)
+ #t
+ (print "Got here: db:lookup-query"))
+(define (db:login . args)
+ #t
+ (print "Got here: db:login"))
+(define (db:general-call . args)
+ #t
+ (print "Got here: db:general-call"))
+(define (db:get-state-status-summary . args)
+ #t
+ (print "Got here: db:get-state-status-summary"))
+(define (db:get-latest-host-load . args)
+ #t
+ (print "Got here: db:get-latest-host-load"))
+(define (db:set-top-level-from-items . args)
+ #t
+ (print "Got here: db:set-top-level-from-items"))
+(define (db:get-matching-previous-test-run-records . args)
+ #t
+ (print "Got here: db:get-matching-previous-test-run-records"))
+(define (db:delay-if-busy . args)
+ #t
+ (print "Got here: db:delay-if-busy"))
+(define (db:test-get-records-for-index-file . args)
+ #t
+ (print "Got here: db:test-get-records-for-index-file"))
+(define (db:get-tests-tags . args)
+ #t
+ (print "Got here: db:get-tests-tags"))
+(define (db:testmeta-get-record . args)
+ #t
+ (print "Got here: db:testmeta-get-record"))
+(define (db:testmeta-add-record . args)
+ #t
+ (print "Got here: db:testmeta-add-record"))
+(define (db:testmeta-update-field . args)
+ #t
+ (print "Got here: db:testmeta-update-field"))
+(define (db:testmeta-get-all . args)
+ #t
+ (print "Got here: db:testmeta-get-all"))
+(define (db:compare-itempaths . args)
+ #t
+ (print "Got here: db:compare-itempaths"))
+(define (db:convert-test-itempath . args)
+ #t
+ (print "Got here: db:convert-test-itempath"))
+(define (db:multi-pattern-apply . args)
+ #t
+ (print "Got here: db:multi-pattern-apply"))
+(define (db:get-prereqs-not-met . args)
+ #t
+ (print "Got here: db:get-prereqs-not-met"))
+(define (db:get-run-record-ids . args)
+ #t
+ (print "Got here: db:get-run-record-ids"))
+(define (db:get-changed-record-ids . args)
+ #t
+ (print "Got here: db:get-changed-record-ids"))
+(define (db:extract-ods-file . args)
+ #t
+ (print "Got here: db:extract-ods-file"))
+
+;;======================================================================
+;; Strings table (kept in the .db)
+;;======================================================================
+
+;; Move this into the runid db init
+;;
+(define (db: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 (db:sdb-register-string sdb str)
+ (sqlite3:execute sdb "INSERT OR IGNORE INTO strs (str) VALUES (?);" str))
+
+(define (db: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 (db: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 (db: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)
+ (db: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
+ (db:sdb-string->id sdb scache var))))
+ (if id
+ id
+ (begin
+ (db:sdb-register-string sdb var)
+ (db:sdb-string->id sdb scache var)))))
+ ((getstr) (if (or (number? var)
+ (string->number var))
+ (db:sdb-id->string sdb icache var)
+ var))
+ ((passid) var)
+ ((passstr) var)
+ (else #f)))))
+)
Index: ftail.scm
==================================================================
--- ftail.scm
+++ ftail.scm
@@ -13,11 +13,18 @@
;; 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 .
+;;
+;;======================================================================
+;;======================================================================
+;;
+;; log to sqlite3 db, polling to tail along with indexing to any point in
+;; history is then easy
+;;
;;======================================================================
(declare (unit ftail))
(module ftail
Index: http-transport.scm
==================================================================
--- http-transport.scm
+++ http-transport.scm
@@ -40,10 +40,15 @@
(include "common_records.scm")
(include "db_records.scm")
(include "js-path.scm")
+(import portlogger)
+(portlogger:set-default-log-port! *default-log-port*)
+(portlogger:set-configdat! *configdat*)
+(portlogger:set-printers! debug:print debug:print-error)
+
(require-library stml)
(define (http-transport:make-server-url hostport)
(if (not hostport)
#f
(conc "http://" (car hostport) ":" (cadr hostport))))
Index: iup-test/Makefile
==================================================================
--- iup-test/Makefile
+++ iup-test/Makefile
@@ -1,5 +1,5 @@
-LIBSRC = "<$PATH>/chicken-4.10.0-patch"
+LIBSRC = "PATH/chicken-4.10.0-patch"
sample : sample.c
gcc -I$(LIBSRC)/include/ -L$(LIBSRC)/lib -L$(LIBSRC)/lib64 -liup -liupimglib -o sample sample.c
Index: launch.scm
==================================================================
--- launch.scm
+++ launch.scm
@@ -610,13 +610,11 @@
(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")
- ;; (tests:test-force-state-status! run-id test-id "REMOTEHOSTSTART" "n/a")
- (rmt:test-set-state-status run-id test-id "REMOTEHOSTSTART" "n/a" #f)
- ))
+ (exit)))
((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:test-set-state-status run-id test-id "REMOTEHOSTSTART" "n/a" #f)
)
(else ;; (member (db:test-get-state test-info) '("REMOVING" "REMOTEHOSTSTART" "RUNNING" "KILLREQ"))
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.6521)
+(define megatest-version 1.6523)
Index: megatest.scm
==================================================================
--- megatest.scm
+++ megatest.scm
@@ -22,11 +22,11 @@
;; fake out readline usage of toplevel-command
(define (toplevel-command . a) #f)
(use (prefix sqlite3 sqlite3:) srfi-1 posix regex regex-case srfi-69 (prefix base64 base64:)
readline apropos json http-client directory-utils typed-records
- http-client srfi-18 extras format)
+ http-client srfi-18 extras format (prefix pkts pkts:))
;; Added for csv stuff - will be removed
;;
(use sparse-vectors)
@@ -42,21 +42,28 @@
(declare (uses server))
(declare (uses client))
(declare (uses tests))
(declare (uses genexample))
;; (declare (uses daemon))
-(declare (uses db))
+;; (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 ftail))
-(import ftail)
+
+;; (declare (uses ftail))
+;; (import ftail)
+;;
+;; (declare (uses portlogger))
+;; (import portlogger)
+;;
+;; (declare (uses nmsg-transport))
+;; (import (prefix nmsg-transport nmsg:))
(define *db* #f) ;; this is only for the repl, do not use in general!!!!
(include "common_records.scm")
(include "key_records.scm")
@@ -110,10 +117,12 @@
Launching and managing runs
-run : run all tests or as specified by -testpatt
-remove-runs : remove the data for a run, requires -runname and -testpatt
Optionally use :state and :status, use -keep-records to remove only
the run data.
+ -kill-runs : kill existing run(s) (all incomplete tests killed)
+ -kill-rerun : kill an existing run (all incomplete tests killed and run is rerun)
-set-state-status X,Y : set state to X and status to Y, requires controls per -remove-runs
-rerun FAIL,WARN... : force re-run for tests with specificed status(s)
-rerun-clean : set all tests not COMPLETED+PASS,WARN,WAIVED to NOT_STARTED,n/a
and then run the specified testpatt with -preclean
-rerun-all : set all tests to NOT_STARTED,n/a and run with -preclean
@@ -291,10 +300,11 @@
"-set-toplog"
"-runstep"
"-logpro"
"-m"
"-rerun"
+
"-days"
"-rename-run"
"-to"
;; values and messages
":category"
@@ -403,10 +413,12 @@
"-test-paths" ;; get path(s) to a test, ordered by youngest first
"-runall" ;; run all tests, respects -testpatt, defaults to %
"-run" ;; alias for -runall
"-remove-runs"
+ "-kill-runs"
+ "-kill-rerun"
"-keep-records" ;; use with -remove-runs to remove only the run data
"-rebuild-db"
"-cleanup-db"
"-rollup"
"-update-meta"
@@ -571,16 +583,16 @@
(process:children #f))
(original-exit exit-code)))))
;; for some switches always print the command to stderr
;;
-(if (args:any? "-run" "-runall" "-remove-runs" "-set-state-status")
+(if (args:any? "-run" "-runall" "-remove-runs" "-set-state-status" "-kill-runs" "-kill-rerun")
(debug:print 0 *default-log-port* (string-intersperse (argv) " ")))
;; some switches imply homehost. Exit here if not on homehost
;;
-(let ((homehost-required (list "-cleanup-db" "-server")))
+#;(let ((homehost-required (list "-cleanup-db" "-server")))
(if (apply args:any? homehost-required)
(if (not (common:on-homehost?))
(for-each
(lambda (switch)
(if (args:get-arg switch)
@@ -1038,11 +1050,11 @@
(exit 1))
((not (or (args:get-arg ":runname")
(args:get-arg "-runname")))
(debug:print-error 0 *default-log-port* "Missing required parameter for " action ", you must specify the run name pattern with -runname patt")
(exit 2))
- ((not (args:get-arg "-testpatt"))
+ ((not (or (args:get-arg "-testpatt") (eq? action 'kill-runs)))
(debug:print-error 0 *default-log-port* "Missing required parameter for " action ", you must specify the test pattern with -testpatt")
(exit 3))
(else
(if (not (car *configinfo*))
(begin
@@ -1059,10 +1071,46 @@
state: (common:args-get-state)
status: (common:args-get-status)
new-state-status: (args:get-arg "-set-state-status")
mode: mode)))
(set! *didsomething* #t)))))
+
+(if (args:get-arg "-kill-runs")
+ (general-run-call
+ "-kill-runs"
+ "kill runs"
+ (lambda (target runname keys keyvals)
+ (operate-on 'kill-runs mode: #f)
+ )))
+
+(if (args:get-arg "-kill-rerun")
+ (let* ((target-patt (args:get-arg "-target"))
+ (runname-patt (args:get-arg "-runname")))
+ (cond ((not target-patt)
+ (debug:print-error 0 *default-log-port* "Missing target, must specify target for -kill-rerun with -target ")
+ (exit 1))
+ ((not runname-patt)
+ (debug:print-error 0 *default-log-port* "Missing runname, must specify runname for -kill-rerun with -runname ")
+ (exit 1))
+ ((string-search "[ ,%]" target-patt)
+ (debug:print-error 0 *default-log-port* "Invalid target ["target-patt"], must specify exact target (no wildcards) for -kill-rerun with -target ")
+ (exit 1))
+ ((string-search "[ ,%]" runname-patt)
+ (debug:print-error 0 *default-log-port* "Invalid runname ["runname-patt"], must specify exact runname (no wildcards) for -kill-rerun with -runname ")
+ (exit 1))
+ (else
+ (general-run-call
+ "-kill-runs"
+ "kill runs"
+ (lambda (target runname keys keyvals)
+ (operate-on 'kill-runs mode: #f)
+ ))
+
+ (thread-sleep! 15))
+ ;; fall thru and let "-run" loop fire
+ )))
+
(if (args:get-arg "-remove-runs")
(general-run-call
"-remove-runs"
"remove runs"
@@ -1622,18 +1670,19 @@
;; run all tests are are Not COMPLETED and PASS or CHECK
(if (or (args:get-arg "-runall")
(args:get-arg "-run")
(args:get-arg "-rerun-clean")
(args:get-arg "-rerun-all")
- (args:get-arg "-runtests"))
+ (args:get-arg "-runtests")
+ (args:get-arg "-kill-rerun"))
(let ((need-clean (or (args:get-arg "-rerun-clean")
(args:get-arg "-rerun-all"))))
(general-run-call
"-runall"
"run all tests"
(lambda (target runname keys keyvals)
- (if (args:get-arg "-rerun-clean") ;; first set states/statuses correct
+ (if (or (args:get-arg "-kill-rerun") (args:get-arg "-rerun-clean")) ;; first set states/statuses correct
;; For rerun-clean do we or do we not support the testpatt?
(let ((states (or (configf:lookup *configdat* "validvalues" "cleanrerun-states")
"KILLREQ,KILLED,UNKNOWN,INCOMPLETE,STUCK,NOT_STARTED"))
(statuses (or (configf:lookup *configdat* "validvalues" "cleanrerun-statuses")
"FAIL,INCOMPLETE,ABORT,CHECK,DEAD,PREQ_FAIL,PREQ_DISCARDED")))
@@ -2150,11 +2199,11 @@
(if (or (getenv "MT_RUNSCRIPT")
(args:get-arg "-repl")
(args:get-arg "-load"))
(let* ((toppath (launch:setup))
(dbstruct (if (and toppath
- (common:on-homehost?))
+ #;(common:on-homehost?))
(db:setup #t)
#f))) ;; make-dbr:dbstruct path: toppath local: (args:get-arg "-local")) #f)))
(if *toppath*
(cond
((getenv "MT_RUNSCRIPT")
@@ -2174,10 +2223,11 @@
(set! *db* dbstruct)
(import extras) ;; might not be needed
;; (import csi)
(import readline)
(import apropos)
+ (import portlogger)
;; (import (prefix sqlite3 sqlite3:)) ;; doesn't work ...
(if *use-new-readline*
(begin
(install-history-file (get-environment-variable "HOME") ".megatest_history") ;; [homedir] [filename] [nlines])
ADDED mtserve.scm
Index: mtserve.scm
==================================================================
--- /dev/null
+++ mtserve.scm
@@ -0,0 +1,288 @@
+;; Copyright 2006-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 .
+;;
+
+;; (include "common.scm")
+;; (include "megatest-version.scm")
+
+;; fake out readline usage of toplevel-command
+(define (toplevel-command . a) #f)
+
+(use (prefix sqlite3 sqlite3:) srfi-1 posix regex regex-case srfi-69 (prefix base64 base64:)
+ readline apropos json directory-utils typed-records
+ srfi-18 extras format (prefix pkts pkts:))
+
+(declare (uses common))
+(declare (uses megatest-version))
+(declare (uses margs))
+(declare (uses server))
+(declare (uses rmt))
+
+;; (declare (uses daemon))
+
+(declare (uses db))
+(import db)
+
+(declare (uses portlogger))
+(import portlogger)
+
+(declare (uses nmsg-transport))
+(import (prefix nmsg-transport nmsg:))
+
+(include "common_records.scm")
+(include "key_records.scm")
+(include "db_records.scm")
+(include "run_records.scm")
+(include "megatest-fossil-hash.scm")
+
+(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
+
+;; 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") "/.mtserverrc")))
+ (if (file-exists? debugcontrolf)
+ (load debugcontrolf)))
+
+;; usage logging, careful with this, it is not designed to deal with all real world challenges!
+;;
+(if (and *usage-log-file*
+ (file-write-access? *usage-log-file*))
+ (with-output-to-file
+ *usage-log-file*
+ (lambda ()
+ (print
+ (if *usage-use-seconds*
+ (current-seconds)
+ (time->string
+ (seconds->local-time (current-seconds))
+ "%Yww%V.%w %H:%M:%S"))
+ " "
+ (current-user-name) " "
+ (current-directory) " "
+ "\"" (string-intersperse (argv) " ") "\""))
+ #:append))
+
+;; Disabled help items
+;; -rollup : (currently disabled) fill run (set by :runname) with latest test(s)
+;; from prior runs with same keys
+;; -daemonize : fork into background and disconnect from stdin/out
+
+(define help (conc "
+Megatest, documentation at http://www.kiatoa.com/fossils/megatest
+ version " megatest-version "
+ license GPL, Copyright Matt Welland 2006-2017
+
+Usage: mtserver [options]
+ -h : this help
+ -manual : show the Megatest user manual
+ -version : print megatest version (currently " megatest-version ")
+
+Launching and managing runs
+ -run : run all tests or as specified by -testpatt
+ -server main|passive : start the server in \"main\" mode or \"passive\" mode
+ -log logfile : send stdout and stderr to logfile
+ -list-servers : list the servers
+ -kill-servers : kill all servers
+ -repl : start a repl (useful for extending megatest)
+ -ping run-id|host:port : ping server, exit with 0 if found
+ -debug N|N,M,O... : enable debug 0-N or N and M and O ...
+
+Examples
+
+# Get test path, use '.' to get a single path or a specific path/file pattern
+megatest -test-files 'logs/*.log' -target ubuntu/n%/no% -runname w49% -testpatt test_mt%
+
+Called as " (string-intersperse (argv) " ") "
+Version " megatest-version ", built from " megatest-fossil-hash ))
+
+;; -gui : start a gui interface
+;; -config fname : override the runconfigs file with fname
+
+;; process args
+(define remargs (args:get-args
+ (argv)
+ (list "-start-dir"
+ "-server"
+ "-port"
+ "-log"
+ )
+ (list "-h" "-help" "--help"
+ "-manual"
+ "-version"
+ "-list-servers"
+ "-kill-servers"
+ "-repl"
+ "-v" ;; verbose 2, more than normal (normal is 1)
+ "-q" ;; quiet 0, errors/warnings only
+
+ "-diff-rep"
+ )
+ args:arg-hash
+ 0))
+
+;; Add args that use remargs here
+;;
+(if (and (not (null? remargs))
+ (not (or
+ (args:get-arg "-runstep")
+ (args:get-arg "-envcap")
+ (args:get-arg "-envdelta")
+ )
+ ))
+ (debug:print-error 0 *default-log-port* "Unrecognised arguments: " (string-intersperse (if (list? remargs) remargs (argv)) " ")))
+
+;; before doing anything else change to the start-dir if provided
+;;
+(if (args:get-arg "-start-dir")
+ (if (file-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))))
+
+;; The watchdog is to keep an eye on things like db sync etc.
+;;
+(define *watchdog* (make-thread
+ (lambda ()
+ (handle-exceptions
+ exn
+ (begin
+ (print-call-chain)
+ (print " message: " ((condition-property-accessor 'exn 'message) exn)))
+ (common:watchdog)))
+ "Watchdog thread"))
+
+;;======================================================================
+;; Strive for clean exit handling
+;;======================================================================
+
+(define (server-exit-procedure)
+ (on-exit (lambda ()
+ ;; close the databases, ensure the pkt is removed!
+
+ (server:shutdown)
+ 0)))
+
+;; Copied from the SDL2 examples.
+;;
+;; Schedule quit! to be automatically called when your program exits normally.
+(on-exit server-exit-procedure)
+
+;; Install a custom exception handler that will call quit! and then
+;; call the original exception handler. This ensures that quit! will
+;; be called even if an unhandled exception reaches the top level.
+(current-exception-handler
+ (let ((original-handler (current-exception-handler)))
+ (lambda (exception)
+ (server-exit-procedure)
+ (original-handler exception))))
+
+;;(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"
+ "-testdata-csv"
+ "-list-servers"
+ "-server"
+ "-list-disks"
+ "-list-targets"
+ "-show-runconfig"
+ ;;"-list-db-targets"
+ "-show-runconfig"
+ "-show-config"
+ "-show-cmdinfo"
+ "-cleanup-db"))
+ (no-watchdog-args-vals (filter (lambda (x) x)
+ (map args:get-arg no-watchdog-args)))
+ (start-watchdog (null? no-watchdog-args-vals)))
+ ;;(BB> "no-watchdog-args="no-watchdog-args "no-watchdog-args-vals="no-watchdog-args-vals)
+ (if start-watchdog
+ (thread-start! *watchdog*)))
+
+
+;; bracket open-output-file with code to make leading directory if it does not exist and handle exceptions
+(define (open-logfile logpath)
+ (condition-case
+ (let* ((log-dir (or (pathname-directory logpath) ".")))
+ (if (not (directory-exists? log-dir))
+ (system (conc "mkdir -p " log-dir)))
+ (open-output-file logpath))
+ (exn ()
+ (debug:print-error 0 *default-log-port* "Could not open log file for write: "logpath)
+ (define *didsomething* #t)
+ (exit 1))))
+
+;; this segment will run launch:setup only if -log is not set. This is fairly safe as servers are not
+;; manually started and thus should never be started in a non-megatest area. Thus no need to handle situation
+;; where (launch:setup) returns #f?
+;;
+#;(if (or (args:get-arg "-log")(args:get-arg "-server")) ;; redirect the log always when a server
+ (handle-exceptions
+ exn
+ (begin
+ (print "ERROR: Failed to switch to log output. " ((condition-property-accessor 'exn 'message) exn))
+ )
+ (let* ((tl (or (args:get-arg "-log")(launch:setup))) ;; run launch:setup if -server, ensure we do NOT run launch:setup if -log specified
+ (logf (or (args:get-arg "-log") ;; use -log unless we are a server, then craft a logfile name
+ (conc tl "/logs/server-" (current-process-id) "-" (get-host-name) ".log")))
+ (oup (open-logfile logf)))
+ (if (not (args:get-arg "-log"))
+ (hash-table-set! args:arg-hash "-log" logf)) ;; fake out future queries of -log
+ (debug:print-info 0 *default-log-port* "Sending log output to " logf)
+ (set! *default-log-port* oup))))
+
+(if (or (args:get-arg "-h")
+ (args:get-arg "-help")
+ (args:get-arg "--help"))
+ (begin
+ (print help)
+ (exit)))
+
+(if (args:get-arg "-version")
+ (begin
+ (print (common:version-signature)) ;; (print megatest-version)
+ (exit)))
+
+(define *didsomething* #f)
+
+;; ready? start the server
+;;
+(if (args:get-arg "-server")
+ (let ((mode (string->symbol (args:get-arg "-server"))))
+ (if (not (server:launch mode)) ;; opens the port, drops the pkt, contacts other servers and then waits for messages
+ (exit 1))))
+
+(if (args:get-arg "-repl")
+ (begin
+ ;; user will have to start the server manually
+ (print "Run: (server:start-nmsg 'main) to start the server")
+ (import extras) ;; might not be needed
+ ;; (import csi)
+ (import readline)
+ (import apropos)
+ (import portlogger)
+ ;; (import (prefix sqlite3 sqlite3:)) ;; doesn't work ...
+
+ (install-history-file (get-environment-variable "HOME") ".megatest_history") ;; [homedir] [filename] [nlines])
+ (current-input-port (make-readline-port "megatest> "))
+ (repl)
+ (set! *didsomething* #t)))
+
+
Index: mtut.scm
==================================================================
--- mtut.scm
+++ mtut.scm
@@ -29,11 +29,11 @@
(declare (uses common))
(declare (uses megatest-version))
(declare (uses margs))
(declare (uses configf))
-;; (declare (uses rmt))
+(declare (uses rmt))
(use ducttape-lib)
(include "megatest-fossil-hash.scm")
@@ -140,10 +140,12 @@
Run management:
run : initiate or resume a run, already completed and in-progress
tests are not affected.
rerun-clean : clean and rerun all not completed pass/fail tests
rerun-all : clean and rerun entire run
+ kill-run : kill all tests in run
+ kill-rerun : kill all tests in run and restart non-completed tests
remove : remove runs
set-ss : set state/status
archive : compress and move test data to archive disk
kill : stop tests or entire runs
db : database utilities
@@ -247,10 +249,12 @@
;; alist to map actions to old megatest commands
(define *action-keys*
'((run . "-run")
(rerun-clean . "-rerun-clean")
(rerun-all . "-rerun-all")
+ (kill-run . "-kill-runs")
+ (kill-rerun . "-kill-rerun")
(sync . "")
(archive . "-archive")
(set-ss . "-set-state-status")
(remove . "-remove-runs")))
@@ -492,10 +496,12 @@
(with-input-from-string
data
(lambda ()
(read))))
+;; moved to portlogger - TODO: remove from here and get from portlogger
+;;
(define (is-port-in-use port-num)
(let* ((ret #f))
(let-values (((inp oup pid)
(process "netstat" (list "-tulpn" ))))
(let loop ((inl (read-line inp)))
@@ -1443,11 +1449,11 @@
(set! *default-log-port* oup)
)))
(if *action*
(case (string->symbol *action*)
- ((run remove rerun rerun-clean rerun-all set-ss archive kill list)
+ ((run remove rerun rerun-clean rerun-all set-ss archive kill list kill-run kill-rerun)
(let* ((mtconfdat (simple-setup (args:get-arg "-start-dir")))
(mtconf (car mtconfdat))
(area (args:get-arg "-area")) ;; look up the area to dispatch to from [areas] section
(areasec (if area (configf:lookup mtconf "areas" area) #f))
(areadat (if areasec (common:val->alist areasec) #f))
ADDED nmsg-transport.scm
Index: nmsg-transport.scm
==================================================================
--- /dev/null
+++ nmsg-transport.scm
@@ -0,0 +1,125 @@
+
+;; 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 .
+
+;;======================================================================
+;; Support routines for nmsg usage.
+;; This should be reusable, non-megatest specific stuff
+;;======================================================================
+
+(declare (unit nmsg-transport))
+
+(module
+ nmsg-transport
+ (
+ nmsg:start-server
+ nmsg:open-send-close
+ nmsg:open-send-receive
+ nmsg:close
+ )
+
+(import scheme posix chicken data-structures ports)
+
+(use nanomsg srfi-18)
+
+;;start a server, returns the connection
+;;
+(define (nmsg:start-server portnum)
+ (let ((rep (nn-socket 'rep)))
+ (handle-exceptions
+ exn
+ (let ((emsg ((condition-property-accessor 'exn 'message) exn)))
+ (print "ERROR: Failed to start server \"" emsg "\"")
+ #f)
+ (nn-bind rep (conc "tcp://*:" portnum)))
+ rep))
+
+;; open connection to server, send message, close connection
+;;
+;; to take an action on failure use proc which is called with the error info
+;; (proc exn errormsg)
+;;
+;; returns the response or #f if no response within timeout
+;;
+(define (nmsg:open-send-close host-port msg #!key (timeout 3)(proc #f)) ;; default timeout is 3 seconds
+ (let ((req (nn-socket 'req))
+ (uri (conc "tcp://" host-port))
+ (res #f))
+ (handle-exceptions
+ exn
+ (let ((emsg ((condition-property-accessor 'exn 'message) exn)))
+ ;; call proc on fail
+ (if proc (proc exn emsg))
+ #f)
+ (nn-connect req uri)
+ (print "Connected to the server " )
+ (nn-send req msg)
+ (print "Request Sent")
+ (let* ((th1 (make-thread (lambda ()
+ (let ((resp (nn-recv req)))
+ (nn-close req)
+ (set! res resp)))
+ "recv thread"))
+ (th2 (make-thread (lambda ()
+ (thread-sleep! timeout)
+ (thread-terminate! th1))
+ "timer thread")))
+ (thread-start! th1)
+ (thread-start! th2)
+ (thread-join! th1)
+ res))))
+
+;; default timeout is 3 seconds
+;;
+(define (nmsg:open-send-receive host-port msg attrib #!key (timeout 3)(proc #f))
+ (let ((req (nn-socket 'req))
+ (uri (conc "tcp://" host-port))
+ (res #f)
+ (mode (alist-ref 'mode attrib)))
+ (handle-exceptions
+ exn
+ (let ((emsg ((condition-property-accessor 'exn 'message) exn)))
+ ;; Send notification
+ (if proc (proc exn emsg))
+ #f)
+ (nn-connect req uri)
+ (print "Connected to the server " )
+ (nn-send req msg)
+ (print "Request Sent")
+ ;; receive code here
+ ;;(print (nn-recv req))
+ (let* ((th1 (make-thread (lambda ()
+ (let ((resp (nn-recv req)))
+ (nn-close req)
+ (print resp)
+ (set! res (if (equal? resp "ok")
+ #t
+ #f))))
+ "recv thread"))
+ (th2 (make-thread (lambda ()
+ (thread-sleep! timeout)
+ (thread-terminate! th1))
+ "timer thread")))
+ (thread-start! th1)
+ (thread-start! th2)
+ (thread-join! th1)
+ res))))
+
+(define (nmsg:close conn)
+ (nn-close conn))
+
+)
Index: portlogger-example.scm
==================================================================
--- portlogger-example.scm
+++ portlogger-example.scm
@@ -15,7 +15,15 @@
;; You should have received a copy of the GNU General Public License
;; along with Megatest. If not, see .
(declare (uses portlogger))
+(import portlogger)
+(use trace (prefix sqlite3 sqlite3:))
+(trace
+ portlogger:open-db
+ portlogger:take-port
+ portlogger:open-run-close
+ sqlite3:execute
+ )
(print (apply portlogger:main (cdr (argv))))
Index: portlogger.scm
==================================================================
--- portlogger.scm
+++ portlogger.scm
@@ -15,42 +15,67 @@
;;
;; 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 srfi-69 hostinfo dot-locking z3)
-(import (prefix sqlite3 sqlite3:))
-
(declare (unit portlogger))
-(declare (uses db))
+
+(module
+ portlogger
+ (portlogger:set-configdat!
+ portlogger:set-printers!
+ portlogger:set-default-log-port!
+ portlogger:open-db
+ portlogger:open-run-close
+ portlogger:take-port
+ portlogger:get-prev-used-port
+ portlogger:find-port
+ portlogger:set-port
+ portlogger:release-port
+ portlogger:set-failed
+ portlogger:is-port-in-use
+ portlogger:main
+)
+
+(import scheme posix chicken data-structures ports)
+
+(require-extension (srfi 18) extras tcp s11n)
+(use srfi-1 posix srfi-69 hostinfo dot-locking z3 regex)
+(use (prefix sqlite3 sqlite3:))
+(use (prefix mtconfigf configf:))
;; lsof -i
+(define *configdat* #f)
+(define (portlogger:set-configdat! cfgdat)
+ (set! *configdat* cfgdat))
+
+(define (debug:print level port . params)
+ (with-output-to-port
+ port
+ (lambda ()(apply print params))))
+(define debug:print-error debug:print)
+(define *default-log-port* (current-error-port))
+
+(define (portlogger:set-printers! pdebug pdebugerr)
+ (set! debug:print pdebug)
+ (set! debug:print-error pdebugerr))
+(define (portlogger:set-default-log-port! port)
+ (set! *default-log-port* port))
(define (portlogger:open-db fname)
- (let* ((avail (tasks:wait-on-journal fname 5 remove: #t)) ;; wait up to about 10 seconds for the journal to go away
- (exists (common:file-exists? fname))
+ (let* ((avail #t) ;; for now - assume wait on journal not needed (tasks:wait-on-journal fname 5 remove: #t)) ;; wait up to about 10 seconds for the journal to go away
+ (exists (file-exists? fname))
(db (if avail
(sqlite3:open-database fname)
(begin
(system (conc "rm -f " fname))
(sqlite3:open-database fname))))
- (handler (make-busy-timeout 136000))
+ (handler (sqlite3:make-busy-timeout 136000))
(canwrite (file-write-access? fname)))
- ;; (db-init (lambda ()
- ;; (sqlite3:execute
- ;; db
- ;; "CREATE TABLE IF NOT EXISTS ports (
- ;; port INTEGER PRIMARY KEY,
- ;; state TEXT DEFAULT 'not-used',
- ;; fail_count INTEGER DEFAULT 0,
- ;; update_time TIMESTAMP DEFAULT (strftime('%s','now')) );"))))
(sqlite3:set-busy-handler! db handler)
- (db:set-sync db) ;; (sqlite3:execute db "PRAGMA synchronous = 0;")
- ;; (if (not exists) ;; needed with IF NOT EXISTS?
+ (sqlite3:execute db "PRAGMA synchronous = 0;")
(sqlite3:execute
db
"CREATE TABLE IF NOT EXISTS ports (
port INTEGER PRIMARY KEY,
state TEXT DEFAULT 'not-used',
@@ -58,19 +83,19 @@
update_time TIMESTAMP DEFAULT (strftime('%s','now')) );")
db))
(define (portlogger:open-run-close proc . params)
(let* ((fname (conc "/tmp/." (current-user-name) "-portlogger.db"))
- (avail (tasks:wait-on-journal fname 10))) ;; wait up to about 10 seconds for the journal to go away
+ (avail #t)) ;; (tasks:wait-on-journal fname 10))) ;; wait up to about 10 seconds for the journal to go away
(handle-exceptions
exn
(begin
;; (release-dot-lock fname)
(debug:print-error 0 *default-log-port* "portlogger:open-run-close failed. " proc " " params)
(debug:print 0 *default-log-port* " message: " ((condition-property-accessor 'exn 'message) exn))
(debug:print 5 *default-log-port* "exn=" (condition->list exn))
- (if (common:file-exists? fname)(delete-file fname)) ;; brutally get rid of it
+ (if (file-exists? fname)(delete-file fname)) ;; brutally get rid of it
(print-call-chain (current-error-port)))
(let* (;; (lock (obtain-dot-lock fname 2 9 10))
(db (portlogger:open-db fname))
(res (apply proc db params)))
(sqlite3:finalize! db)
@@ -80,13 +105,13 @@
;; (fold-row PROC INIT DATABASE SQL . PARAMETERS)
(define (portlogger:take-port db portnum)
(let* ((qry1 (sqlite3:prepare db "INSERT INTO ports (port,state) VALUES (?,?);"))
(qry2 (sqlite3:prepare db "UPDATE ports SET state=?,update_time=strftime('%s','now') WHERE port=?;"))
(qry3 (sqlite3:prepare db "SELECT state FROM ports WHERE port=?;"))
- (res (sqlite3:with-transaction
- db
- (lambda ()
+ (res ;; (sqlite3:with-transaction ;; move the transaction up to the find-port call
+ ;; db
+ ;; (lambda ()
;; (fold-row (lambda (var curr) (or var curr)) #f db "SELECT var FROM foo WHERE id=100;")
(let* ((curr #f)
(res #f))
(set! curr (sqlite3:fold-row
(lambda (var curr)
@@ -100,11 +125,11 @@
((not-tried) (sqlite3:execute qry1 portnum "taken") 'taken)
((taken) 'already-taken)
((failed) 'failed)
(else 'error)))
;; (print "res=" res)
- res)))))
+ res))) ;; ))
(sqlite3:finalize! qry1)
(sqlite3:finalize! qry2)
(sqlite3:finalize! qry3)
res))
@@ -124,38 +149,60 @@
#f
db
"SELECT (port) FROM ports WHERE state='released' LIMIT 1;")))
(define (portlogger:find-port db)
- (let* ((lowport (let ((val (configf:lookup *configdat* "server" "lowport")))
- (if (and val
- (string->number val))
- (string->number val)
- 32768)))
- (portnum (or (portlogger:get-prev-used-port db)
- (+ lowport ;; top of registered ports is 49152 but lets use ports in the registered range
- (random (- 64000 lowport))))))
- (handle-exceptions
- exn
- (begin
- (debug:print 0 *default-log-port* "EXCEPTION: portlogger database probably overloaded or unreadable. If you see this message again remove /tmp/.$USER-portlogger.db")
- (debug:print 0 *default-log-port* " message: " ((condition-property-accessor 'exn 'message) exn))
- (debug:print 5 *default-log-port* "exn=" (condition->list exn))
- (print-call-chain (current-error-port))
- (debug:print 0 *default-log-port* "Continuing anyway."))
- (portlogger:take-port db portnum))
- portnum))
+ (let ((lowport (let ((val (configf:lookup *configdat* "server" "lowport")))
+ (if (and val
+ (string->number val))
+ (string->number val)
+ 32768))))
+ (sqlite3:with-transaction
+ db
+ (lambda ()
+ (let loop ((numtries 0))
+ (let* ((portnum (or (portlogger:get-prev-used-port db)
+ (+ lowport ;; top of registered ports is 49152 but let's use ports in the registered range
+ (random (- 64000 lowport))))))
+ (handle-exceptions
+ exn
+ (begin
+ (debug:print 0 *default-log-port* "EXCEPTION: portlogger database probably overloaded or unreadable. If you see this message again remove /tmp/.$USER-portlogger.db")
+ (debug:print 0 *default-log-port* " message: " ((condition-property-accessor 'exn 'message) exn))
+ (debug:print 5 *default-log-port* "exn=" (condition->list exn))
+ (print-call-chain (current-error-port))
+ (debug:print 0 *default-log-port* "Continuing anyway."))
+ (portlogger:take-port db portnum) ;; always "take the port"
+ (if (portlogger:is-port-in-use portnum)
+ portnum
+ (loop (add1 numtries))))))))))
;; set port to "released", "failed" etc.
;;
(define (portlogger:set-port db portnum value)
(sqlite3:execute db "UPDATE ports SET state=?,update_time=strftime('%s','now') WHERE port=?;" value portnum))
+;; release port
+(define (portlogger:release-port db portnum)
+ (sqlite3:execute db "UPDATE ports SET state=?,update_time=strftime('%s','now') WHERE port=?;" "released" portnum))
+
;; set port to failed (attempted to take but got error)
;;
(define (portlogger:set-failed db portnum)
(sqlite3:execute db "UPDATE ports SET state='failed',fail_count=fail_count+1,update_time=strftime('%s','now') WHERE port=?;" portnum))
+
+;; pulled from mtut - TODO: remove from mtut
+;;
+(define (portlogger:is-port-in-use port-num)
+ (let-values (((inp oup pid)
+ (process "netstat" (list "-tulpn" ))))
+ (let loop ((inl (read-line inp)))
+ (if (not (eof-object? inl))
+ (begin
+ (if (string-search (regexp (conc ":" port-num "\\s+")) inl)
+ #t
+ (loop (read-line inp))))))))
;;======================================================================
;; MAIN
;;======================================================================
@@ -180,10 +227,12 @@
(state (caddr args)))
(portlogger:set-port db
(if (number? port) port (string->number port))
state)
state))
- ((failed)(portlogger:set-failed db (string->number (cadr args))) 'failed)))))
+ ((failed)(portlogger:set-failed db (string->number (cadr args))) 'failed)
+ (else "nosuchcommand")))))
(sqlite3:finalize! db)
result))
;; (print (apply portlogger:main (cdr (argv))))
+)
Index: rmt.scm
==================================================================
--- rmt.scm
+++ rmt.scm
@@ -20,911 +20,346 @@
(use format typed-records) ;; RADT => purpose of json format??
(declare (unit rmt))
(declare (uses api))
-(declare (uses http-transport))
+(import api)
+
(include "common_records.scm")
-;;
-;; THESE ARE ALL CALLED ON THE CLIENT SIDE!!!
-;;
-
-;; generate entries for ~/.megatestrc with the following
-;;
-;; grep define ../rmt.scm | grep rmt: |perl -pi -e 's/\(define\s+\((\S+)\W.*$/\1/'|sort -u
-
-;;======================================================================
-;; S U P P O R T F U N C T I O N S
-;;======================================================================
-
-;; if a server is either running or in the process of starting call client:setup
-;; else return #f to let the calling proc know that there is no server available
-;;
-(define (rmt:get-connection-info areapath #!key (area-dat #f)) ;; TODO: push areapath down.
- (let* ((runremote (or area-dat *runremote*))
- (cinfo (if (remote? runremote)
- (remote-conndat runremote)
- #f)))
- (if cinfo
- cinfo
- (if (server:check-if-running areapath)
- (client:setup areapath)
- #f))))
-
-(define *send-receive-mutex* (make-mutex)) ;; should have separate mutex per run-id
-
-;; RA => e.g. usage (rmt:send-receive 'get-var #f (list varname))
-;;
-(define (rmt:send-receive cmd rid params #!key (attemptnum 1)(area-dat #f)) ;; start attemptnum at 1 so the modulo below works as expected
-
- ;;DOT digraph megatest_state_status {
- ;;DOT ranksep=0;
- ;;DOT // rankdir=LR;
- ;;DOT node [shape="box"];
- ;;DOT "rmt:send-receive" -> MUTEXLOCK;
- ;;DOT { edge [style=invis];"case 1" -> "case 2" -> "case 3" -> "case 4" -> "case 5" -> "case 6" -> "case 7" -> "case 8" -> "case 9" -> "case 10" -> "case 11"; }
- ;; do all the prep locked under the rmt-mutex
- (mutex-lock! *rmt-mutex*)
-
- ;; 1. check if server is started IFF cmd is a write OR if we are not on the homehost, store in runremote
- ;; 2. check the age of the connections. refresh the connection if it is older than timeout-20 seconds.
- ;; 3. do the query, if on homehost use local access
- ;;
- (let* ((start-time (current-seconds)) ;; snapshot time so all use cases get same value
- (areapath *toppath*);; TODO - resolve from dbstruct to be compatible with multiple areas
- (runremote (or area-dat
- *runremote*))
- (readonly-mode (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
- (if runremote
- (begin
- (remote-ro-mode-set! runremote ro-mode)
- (remote-ro-mode-checked-set! runremote #t)
- ro-mode)
- ro-mode)))))
-
- ;; DOT INIT_RUNREMOTE; // leaving off - doesn't really add to the clarity
- ;; DOT MUTEXLOCK -> INIT_RUNREMOTE [label="no remote?"];
- ;; DOT INIT_RUNREMOTE -> MUTEXLOCK;
- ;; ensure we have a record for our connection for given area
- (if (not runremote) ;; can remove this one. should never get here.
- (begin
- (set! *runremote* (make-remote))
- (set! runremote *runremote*))) ;; new runremote will come from this on next iteration
-
- ;; DOT SET_HOMEHOST; // leaving off - doesn't really add to the clarity
- ;; DOT MUTEXLOCK -> SET_HOMEHOST [label="no homehost?"];
- ;; DOT SET_HOMEHOST -> MUTEXLOCK;
- ;; ensure we have a homehost record
- (if (not (pair? (remote-hh-dat runremote))) ;; not on homehost
- (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
- ;;DOT EXIT;
- ;;DOT MUTEXLOCK -> EXIT [label="> 15 attempts"]; {rank=same "case 1" "EXIT" }
- ;; give up if more than 15 attempts
- ((> attemptnum 15)
- (debug:print 0 *default-log-port* "ERROR: 15 tries to start/connect to server. Giving up.")
- (exit 1))
-
- ;;DOT CASE2 [label="local\nreadonly\nquery"];
- ;;DOT MUTEXLOCK -> CASE2; {rank=same "case 2" CASE2}
- ;;DOT CASE2 -> "rmt:open-qry-close-locally";
- ;; readonly mode, read request- handle it - case 2
- ((and readonly-mode
- (member cmd api:read-only-queries))
- (mutex-unlock! *rmt-mutex*)
- (debug:print-info 12 *default-log-port* "rmt:send-receive, case 2")
- (rmt:open-qry-close-locally cmd 0 params)
- )
-
- ;;DOT CASE3 [label="write in\nread-only mode"];
- ;;DOT MUTEXLOCK -> CASE3 [label="readonly\nmode?"]; {rank=same "case 3" CASE3}
- ;;DOT CASE3 -> "#f";
- ;; readonly mode, write request. Do nothing, return #f
- (readonly-mode
- (mutex-unlock! *rmt-mutex*)
- (debug:print-info 12 *default-log-port* "rmt:send-receive, case 3")
- (debug:print 0 *default-log-port* "WARNING: write transaction requested on a readonly area. cmd="cmd" params="params)
- #f)
-
- ;; This block was for pre-emptively resetting the connection if there had been no communication for some time.
- ;; I don't think it adds any value. If the server is not there, just fail and start a new connection.
- ;; also, the expire-time calculation might not be correct. We want, time-since-last-server-access > (server:get-timeout)
- ;;
- ;;DOT CASE4 [label="reset\nconnection"];
- ;;DOT MUTEXLOCK -> CASE4 [label="have connection,\nlast_access > expire_time"]; {rank=same "case 4" CASE4}
- ;;DOT CASE4 -> "rmt:send-receive";
- ;; reset the connection if it has been unused too long
- ((and runremote
- (remote-conndat runremote)
- (> (current-seconds) ;; if it has been more than server-timeout seconds since last contact, close this connection and start a new on
- (+ (http-transport:server-dat-get-last-access (remote-conndat runremote))
- (remote-server-timeout runremote))))
- (debug:print-info 0 *default-log-port* "Connection to " (remote-server-url runremote) " expired due to no accesses, forcing new connection.")
- (http-transport:close-connections area-dat: runremote)
- (remote-conndat-set! runremote #f) ;; invalidate the connection, thus forcing a new connection.
- (mutex-unlock! *rmt-mutex*)
- (rmt:send-receive cmd rid params attemptnum: attemptnum))
-
- ;;DOT CASE5 [label="local\nread"];
- ;;DOT MUTEXLOCK -> CASE5 [label="server not required,\non homehost,\nread-only query"]; {rank=same "case 5" CASE5};
- ;;DOT CASE5 -> "rmt:open-qry-close-locally";
-
- ;; on homehost and this is a read
- ((and (not (remote-force-server runremote)) ;; honor forced use of server, i.e. server NOT required
- (cdr (remote-hh-dat runremote)) ;; on homehost
- (member cmd api:read-only-queries)) ;; this is a read
- (mutex-unlock! *rmt-mutex*)
- (debug:print-info 12 *default-log-port* "rmt:send-receive, case 5")
- (rmt:open-qry-close-locally cmd 0 params))
-
- ;;DOT CASE6 [label="init\nremote"];
- ;;DOT MUTEXLOCK -> CASE6 [label="on homehost,\nwrite query,\nhave server,\ncan't reach it"]; {rank=same "case 6" CASE6};
- ;;DOT CASE6 -> "rmt:send-receive";
- ;; on homehost and this is a write, we already have a server, but server has died
- ((and (cdr (remote-hh-dat runremote)) ;; on homehost
- (not (member cmd api:read-only-queries)) ;; this is a write
- (remote-server-url runremote) ;; have a server
- (not (server:ping (remote-server-url runremote)))) ;; server has died. NOTE: this is not a cheap call! Need better approach.
- (set! *runremote* (make-remote))
- (remote-force-server-set! runremote (common:force-server?))
- (mutex-unlock! *rmt-mutex*)
- (debug:print-info 12 *default-log-port* "rmt:send-receive, case 6")
- (rmt:send-receive cmd rid params attemptnum: attemptnum))
-
- ;;DOT CASE7 [label="homehost\nwrite"];
- ;;DOT MUTEXLOCK -> CASE7 [label="server not required,\non homehost,\na write,\nhave a server"]; {rank=same "case 7" CASE7};
- ;;DOT CASE7 -> "rmt:open-qry-close-locally";
- ;; on homehost and this is a write, we already have a server
- ((and (not (remote-force-server runremote)) ;; honor forced use of server, i.e. server NOT required
- (cdr (remote-hh-dat runremote)) ;; on homehost
- (not (member cmd api:read-only-queries)) ;; this is a write
- (remote-server-url runremote)) ;; have a server
- (mutex-unlock! *rmt-mutex*)
- (debug:print-info 12 *default-log-port* "rmt:send-receive, case 4.1")
- (rmt:open-qry-close-locally cmd 0 params))
-
- ;;DOT CASE8 [label="force\nserver"];
- ;;DOT MUTEXLOCK -> CASE8 [label="server not required,\nhave homehost info,\nno connection yet,\nnot a read-only query"]; {rank=same "case 8" CASE8};
- ;;DOT CASE8 -> "rmt:open-qry-close-locally";
- ;; on homehost, no server contact made and this is a write, passively start a server
- ((and (not (remote-force-server runremote)) ;; honor forced use of server, i.e. server NOT required
- (cdr (remote-hh-dat runremote)) ;; have homehost
- (not (remote-server-url runremote)) ;; no connection yet
- (not (member cmd api:read-only-queries))) ;; not a read-only query
- (debug:print-info 12 *default-log-port* "rmt:send-receive, case 8")
- (let ((server-url (server:check-if-running *toppath*))) ;; (server:read-dotserver->url *toppath*))) ;; (server:check-if-running *toppath*))) ;; Do NOT want to run server:check-if-running - very expensive to do for every write call
- (if server-url
- (remote-server-url-set! runremote server-url) ;; the string can be consumed by the client setup if needed
- (if (common:force-server?)
- (server:start-and-wait *toppath*)
- (server:kind-run *toppath*))))
- (remote-force-server-set! runremote (common:force-server?))
- (mutex-unlock! *rmt-mutex*)
- (debug:print-info 12 *default-log-port* "rmt:send-receive, case 8.1")
- (rmt:open-qry-close-locally cmd 0 params))
-
- ;;DOT CASE9 [label="force server\nnot on homehost"];
- ;;DOT MUTEXLOCK -> CASE9 [label="no connection\nand either require server\nor not on homehost"]; {rank=same "case 9" CASE9};
- ;;DOT CASE9 -> "start\nserver" -> "rmt:send-receive";
- ((or (and (remote-force-server runremote) ;; we are forcing a server and don't yet have a connection to one
- (not (remote-conndat runremote)))
- (and (not (cdr (remote-hh-dat runremote))) ;; not on a homehost
- (not (remote-conndat runremote)))) ;; and no connection
- (debug:print-info 12 *default-log-port* "rmt:send-receive, case 9, hh-dat: " (remote-hh-dat runremote) " conndat: " (remote-conndat runremote))
- (mutex-unlock! *rmt-mutex*)
- (if (not (server:check-if-running *toppath*)) ;; who knows, maybe one has started up?
- (server:start-and-wait *toppath*))
- (remote-conndat-set! runremote (rmt:get-connection-info *toppath*)) ;; calls client:setup which calls client:setup-http
- (rmt:send-receive cmd rid params attemptnum: attemptnum)) ;; TODO: add back-off timeout as
-
- ;;DOT CASE10 [label="on homehost"];
- ;;DOT MUTEXLOCK -> CASE10 [label="server not required,\non homehost"]; {rank=same "case 10" CASE10};
- ;;DOT CASE10 -> "rmt:open-qry-close-locally";
- ;; all set up if get this far, dispatch the query
- ((and (not (remote-force-server runremote))
- (cdr (remote-hh-dat runremote))) ;; we are on homehost
- (mutex-unlock! *rmt-mutex*)
- (debug:print-info 12 *default-log-port* "rmt:send-receive, case 10")
- (rmt:open-qry-close-locally cmd (if rid rid 0) params))
-
- ;;DOT CASE11 [label="send_receive"];
- ;;DOT MUTEXLOCK -> CASE11 [label="else"]; {rank=same "case 11" CASE11};
- ;;DOT CASE11 -> "rmt:send-receive" [label="call failed"];
- ;;DOT CASE11 -> "RESULT" [label="call succeeded"];
- ;; not on homehost, do server query
- (else
- ;; (mutex-unlock! *rmt-mutex*)
- (debug:print-info 12 *default-log-port* "rmt:send-receive, case 9")
- ;; (mutex-lock! *rmt-mutex*)
- (let* ((conninfo (remote-conndat runremote))
- (dat (case (remote-transport runremote)
- ((http) (condition-case ;; handling here has caused a lot of problems. However it is needed to deal with attemtped communication to servers that have gone away
- (http-transport:client-api-send-receive 0 conninfo cmd params)
- ((commfail)(vector #f "communications fail"))
- ((exn)(vector #f "other fail" (print-call-chain)))))
- (else
- (debug:print 0 *default-log-port* "ERROR: transport " (remote-transport runremote) " not supported")
- (exit))))
- (success (if (vector? dat) (vector-ref dat 0) #f))
- (res (if (vector? dat) (vector-ref dat 1) #f)))
- (if (and (vector? conninfo) (< 5 (vector-length conninfo)))
- (http-transport:server-dat-update-last-access conninfo) ;; refresh access time
- (begin
- (debug:print 0 *default-log-port* "INFO: Should not get here! conninfo=" conninfo)
- (set! conninfo #f)
- (remote-conndat-set! *runremote* #f)
- (http-transport:close-connections area-dat: runremote)))
- ;; (mutex-unlock! *rmt-mutex*)
- (debug:print-info 13 *default-log-port* "rmt:send-receive, case 9. conninfo=" conninfo " dat=" dat " runremote = " runremote)
- (mutex-unlock! *rmt-mutex*)
- (if success ;; success only tells us that the transport was successful, have to examine the data to see if there was a detected issue at the other end
- (if (and (vector? res)
- (eq? (vector-length res) 2)
- (eq? (vector-ref res 1) 'overloaded)) ;; since we are looking at the data to carry the error we'll use a fairly obtuse combo to minimise the chances of some sort of collision.
- ;; this is the case where the returned data is bad or the server is overloaded and we want
- ;; to ease off the queries
- (let ((wait-delay (+ attemptnum (* attemptnum 10))))
- (debug:print 0 *default-log-port* "WARNING: server is overloaded. Delaying " wait-delay " seconds and trying call again.")
- (mutex-lock! *rmt-mutex*)
- (http-transport:close-connections area-dat: runremote)
- (set! *runremote* #f) ;; force starting over
- (mutex-unlock! *rmt-mutex*)
- (thread-sleep! wait-delay)
- (rmt:send-receive cmd rid params attemptnum: (+ attemptnum 1)))
- res) ;; All good, return res
- (begin
- (debug:print 0 *default-log-port* "WARNING: communication failed. Trying again, try num: " attemptnum)
- (mutex-lock! *rmt-mutex*)
- (remote-conndat-set! runremote #f)
- (http-transport:close-connections area-dat: runremote)
- (remote-server-url-set! runremote #f)
- (mutex-unlock! *rmt-mutex*)
- (debug:print-info 12 *default-log-port* "rmt:send-receive, case 9.1")
- ;; (if (not (server:check-if-running *toppath*))
- ;; (server:start-and-wait *toppath*))
- (rmt:send-receive cmd rid params attemptnum: (+ attemptnum 1)))))))))
-
- ;;DOT }
-
-;; (define (rmt:update-db-stats run-id rawcmd params duration)
-;; (mutex-lock! *db-stats-mutex*)
-;; (handle-exceptions
-;; exn
-;; (begin
-;; (debug:print 0 *default-log-port* "WARNING: stats collection failed in update-db-stats")
-;; (debug:print 0 *default-log-port* " message: " ((condition-property-accessor 'exn 'message) exn))
-;; (print "exn=" (condition->list exn))
-;; #f) ;; if this fails we don't care, it is just stats
-;; (let* ((cmd (conc "run-id=" run-id " " (if (eq? rawcmd 'general-call) (car params) rawcmd)))
-;; (stat-vec (hash-table-ref/default *db-stats* cmd #f)))
-;; (if (not (vector? stat-vec))
-;; (let ((newvec (vector 0 0)))
-;; (hash-table-set! *db-stats* cmd newvec)
-;; (set! stat-vec newvec)))
-;; (vector-set! stat-vec 0 (+ (vector-ref stat-vec 0) 1))
-;; (vector-set! stat-vec 1 (+ (vector-ref stat-vec 1) duration))))
-;; (mutex-unlock! *db-stats-mutex*))
-
-(define (rmt:print-db-stats)
- (let ((fmtstr "~40a~7-d~9-d~20,2-f")) ;; "~20,2-f"
- (debug:print 18 *default-log-port* "DB Stats\n========")
- (debug:print 18 *default-log-port* (format #f "~40a~8a~10a~10a" "Cmd" "Count" "TotTime" "Avg"))
- (for-each (lambda (cmd)
- (let ((cmd-dat (hash-table-ref *db-stats* cmd)))
- (debug:print 18 *default-log-port* (format #f fmtstr cmd (vector-ref cmd-dat 0) (vector-ref cmd-dat 1) (/ (vector-ref cmd-dat 1)(vector-ref cmd-dat 0))))))
- (sort (hash-table-keys *db-stats*)
- (lambda (a b)
- (> (vector-ref (hash-table-ref *db-stats* a) 0)
- (vector-ref (hash-table-ref *db-stats* b) 0)))))))
-
-(define (rmt:get-max-query-average run-id)
- (mutex-lock! *db-stats-mutex*)
- (let* ((runkey (conc "run-id=" run-id " "))
- (cmds (filter (lambda (x)
- (substring-index runkey x))
- (hash-table-keys *db-stats*)))
- (res (if (null? cmds)
- (cons 'none 0)
- (let loop ((cmd (car cmds))
- (tal (cdr cmds))
- (max-cmd (car cmds))
- (res 0))
- (let* ((cmd-dat (hash-table-ref *db-stats* cmd))
- (tot (vector-ref cmd-dat 0))
- (curravg (/ (vector-ref cmd-dat 1) (vector-ref cmd-dat 0))) ;; count is never zero by construction
- (currmax (max res curravg))
- (newmax-cmd (if (> curravg res) cmd max-cmd)))
- (if (null? tal)
- (if (> tot 10)
- (cons newmax-cmd currmax)
- (cons 'none 0))
- (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:print0 *default-log-port* "ERROR: bad data from server " v " message: " ((condition-property-accessor 'exn 'message) 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))
- (if (not success)
- (if (> remretries 0)
- (begin
- (debug:print-error 0 *default-log-port* "local query failed. Trying again.")
- (thread-sleep! (/ (random 5000) 1000)) ;; some random delay
- (rmt:open-qry-close-locally cmd run-id params remretries: (- remretries 1)))
- (begin
- (debug:print-error 0 *default-log-port* "too many retries in rmt:open-qry-close-locally, giving up")
- #f))
- (begin
- ;; (rmt:update-db-stats run-id cmd params duration)
- ;; mark this run as dirty if this was a write, the watchdog is responsible for syncing it
- (if qry-is-write
- (let ((start-time (current-seconds)))
- (mutex-lock! *db-multi-sync-mutex*)
-/ (set! *db-last-access* start-time) ;; THIS IS PROBABLY USELESS? (we are on a client)
- (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
- #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)))
-
-;; ;; Wrap json library for strings (why the ports crap in the first place?)
-;; (define (rmt:dat->json-str dat)
-;; (with-output-to-string
-;; (lambda ()
-;; (json-write dat))))
-;;
-;; (define (rmt:json-str->dat json-str)
-;; (with-input-from-string json-str
-;; (lambda ()
-;; (json-read))))
-
-;;======================================================================
-;;
-;; A C T U A L A P I C A L L S
-;;
-;;======================================================================
-
-;;======================================================================
-;; S E R V E R
-;;======================================================================
-
-(define (rmt:kill-server run-id)
- (rmt:send-receive 'kill-server run-id (list run-id)))
-
-(define (rmt:start-server run-id)
- (rmt:send-receive 'start-server 0 (list run-id)))
-
-;;======================================================================
-;; M I S C
-;;======================================================================
-
-(define (rmt:login run-id)
- (rmt:send-receive 'login run-id (list *toppath* megatest-version *my-client-signature*)))
-
-;; This login does no retries under the hood - it acts a bit like a ping.
-;; Deprecated for nmsg-transport.
-;;
-(define (rmt:login-no-auto-client-setup connection-info)
- (case *transport-type* ;; run-id of 0 is just a placeholder
- ((http)(rmt:send-receive-no-auto-client-setup connection-info 'login 0 (list *toppath* megatest-version *my-client-signature*)))
- ;;((nmsg)(nmsg-transport:client-api-send-receive run-id connection-info 'login (list *toppath* megatest-version run-id *my-client-signature*)))
- ))
-
-;; hand off a call to one of the db:queries statements
-;; added run-id to make looking up the correct db possible
-;;
-(define (rmt:general-call stmtname run-id . params)
- (rmt:send-receive 'general-call run-id (append (list stmtname run-id) params)))
-
-
-;; given a hostname, return a pair of cpu load and update time representing latest intelligence from tests running on that host
-(define (rmt:get-latest-host-load hostname)
- (rmt:send-receive 'get-latest-host-load 0 (list hostname)))
-
-;; (define (rmt:sync-inmem->db run-id)
-;; (rmt:send-receive 'sync-inmem->db run-id '()))
-
-(define (rmt:sdb-qry qry val run-id)
- ;; add caching if qry is 'getid or 'getstr
- (rmt:send-receive 'sdb-qry run-id (list qry val)))
-
-;; NOT COMPLETED
-(define (rmt:runtests user run-id testpatt params)
- (rmt:send-receive 'runtests run-id testpatt))
-
-(define (rmt:get-run-record-ids target run keynames test-patt)
- (rmt:send-receive 'get-run-record-ids #f (list target run keynames test-patt)))
-
-(define (rmt:get-changed-record-ids since-time)
- (rmt:send-receive 'get-changed-record-ids #f (list since-time)) )
-
-;;======================================================================
-;; T E S T M E T A
-;;======================================================================
-
-(define (rmt:get-tests-tags)
- (rmt:send-receive 'get-tests-tags #f '()))
-
-;;======================================================================
-;; K E Y S
-;;======================================================================
-
-;; These require run-id because the values come from the run!
-;;
-(define (rmt:get-key-val-pairs run-id)
- (rmt:send-receive 'get-key-val-pairs run-id (list run-id)))
-
-(define (rmt:get-keys)
- (if *db-keys* *db-keys*
- (let ((res (rmt:send-receive 'get-keys #f '())))
- (set! *db-keys* res)
- res)))
-
-(define (rmt:get-keys-write) ;; dummy query to force server start
- (let ((res (rmt:send-receive 'get-keys-write #f '())))
- (set! *db-keys* res)
- res))
-
-;; we don't reuse run-id's (except possibly *after* a db cleanup) so it is safe
-;; to cache the resuls in a hash
-;;
-(define (rmt:get-key-vals run-id)
- (or (hash-table-ref/default *keyvals* run-id #f)
- (let ((res (rmt:send-receive 'get-key-vals #f (list run-id))))
- (hash-table-set! *keyvals* run-id res)
- res)))
-
-(define (rmt:get-targets)
- (rmt:send-receive 'get-targets #f '()))
-
-(define (rmt:get-target run-id)
- (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 )))
-
-
-;;======================================================================
-;; T E S T S
-;;======================================================================
-
-;; Just some syntatic sugar
-(define (rmt:register-test run-id test-name item-path)
- (rmt:general-call 'register-test run-id run-id test-name item-path))
-
-(define (rmt:get-test-id run-id testname item-path)
- (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)
- (if (number? test-id)
- (rmt:send-receive 'get-test-info-by-id run-id (list run-id test-id))
- (begin
- (debug:print 0 *default-log-port* "WARNING: Bad data handed to rmt:get-test-info-by-id run-id=" run-id ", test-id=" test-id)
- (print-call-chain (current-error-port))
- #f)))
-
-(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))
- (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)
- (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)
- (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)
- ;; (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))
- ;; '())))
-
-;; get stuff via synchash
-(define (rmt:synchash-get run-id proc synckey keynum params)
- (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)
- (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)
- (let ((multi-run-mutex (make-mutex))
- (run-id-list (if run-ids
- run-ids
- (rmt:get-all-run-ids)))
- (result '()))
- (if (null? run-id-list)
- '()
- (let loop ((hed (car run-id-list))
- (tal (cdr run-id-list))
- (threads '()))
- (if (> (length threads) 5)
- (loop hed tal (filter (lambda (th)(not (member (thread-state th) '(terminated dead)))) threads))
- (let* ((newthread (make-thread
- (lambda ()
- (let ((res (rmt:send-receive 'get-tests-for-run-mindata hed (list hed testpatt states status not-in))))
- (if (list? res)
- (begin
- (mutex-lock! multi-run-mutex)
- (set! result (append result res))
- (mutex-unlock! multi-run-mutex))
- (debug:print-error 0 *default-log-port* "get-tests-for-run-mindata failed for run-id " hed ", testpatt " testpatt ", states " states ", status " status ", not-in " not-in))))
- (conc "multi-run-thread for run-id " hed)))
- (newthreads (cons newthread threads)))
- (thread-start! newthread)
- (thread-sleep! 0.05) ;; give that thread some time to start
- (if (null? tal)
- newthreads
- (loop (car tal)(cdr tal) newthreads))))))
- result))
-
-;; ;; IDEA: Threadify these - they spend a lot of time waiting ...
-;; ;;
-;; (define (rmt:get-tests-for-runs-mindata run-ids testpatt states status not-in)
-;; (let ((run-id-list (if run-ids
-;; run-ids
-;; (rmt:get-all-run-ids))))
-;; (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)
- (rmt:send-receive 'delete-test-records run-id (list run-id test-id)))
-
-;; This is not needed as test steps are deleted on test delete call
-;;
-;; (define (rmt:delete-test-step-records run-id test-id)
-;; (rmt:send-receive 'delete-test-step-records run-id (list run-id test-id)))
-
-(define (rmt:test-set-state-status run-id test-id state status msg)
- (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)
- (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)
- (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)
- (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)
- (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)
- (rmt:send-receive 'get-testinfo-state-status run-id (list run-id test-id)))
-
-(define (rmt:test-set-log! run-id test-id logf)
- (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)
- (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)
- (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)))
-
-;; NOTE: This will open and access ALL run databases.
-;;
-(define (rmt:test-get-paths-matching-keynames-target-new keynames target res testpatt statepatt statuspatt runname)
- (let ((run-ids (rmt:get-run-ids-matching-target keynames target res runname testpatt statepatt statuspatt)))
- (apply append
- (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-run-ids-matching keynames target res)
-;; (rmt:send-receive #f 'get-run-ids-matching (list keynames target res)))
-
-(define (rmt:get-prereqs-not-met run-id waitons ref-test-name ref-item-path #!key (mode '(normal))(itemmaps #f))
- (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)
- (rmt:send-receive 'get-count-tests-running-for-run-id run-id (list run-id)))
-
-;; Statistical queries
-
-(define (rmt:get-count-tests-running run-id)
- (rmt:send-receive 'get-count-tests-running run-id (list run-id)))
-
-(define (rmt:get-count-tests-running-for-testname run-id testname)
- (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)
- (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)
- (rmt:send-receive 'set-state-status-and-roll-up-items run-id (list run-id test-name item-path state status comment)))
-
-(define (rmt:update-pass-fail-counts run-id test-name)
- (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)
- (rmt:send-receive 'top-test-set-per-pf-counts run-id (list run-id test-name)))
-
-(define (rmt:get-raw-run-stats run-id)
- (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
-;;======================================================================
-
-(define (rmt:get-run-info run-id)
- (rmt:send-receive 'get-run-info run-id (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)
- (rmt:send-receive 'get-runs-cnt-by-patt #f (list runpatt targetpatt keys)))
-
-;; 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)))
-
-(define (rmt:delete-run run-id)
- (rmt:send-receive 'delete-run run-id (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)
- (rmt:send-receive 'delete-old-deleted-test-records #f '()))
-
-(define (rmt:get-runs runpatt count offset keypatts)
- (rmt:send-receive 'get-runs #f (list runpatt count offset keypatts)))
-
-(define (rmt:simple-get-runs runpatt count offset target)
- (rmt:send-receive 'simple-get-runs #f (list runpatt count offset target)))
-
-(define (rmt:get-all-run-ids)
- (rmt:send-receive 'get-all-run-ids #f '()))
-
-(define (rmt:get-prev-run-ids run-id)
- (rmt:send-receive 'get-prev-run-ids #f (list run-id)))
-
-(define (rmt:lock/unlock-run run-id lock unlock user)
- (rmt:send-receive 'lock/unlock-run #f (list run-id lock unlock user)))
-
-;; set/get status
-(define (rmt:get-run-status run-id)
- (rmt:send-receive 'get-run-status #f (list run-id)))
-
-(define (rmt:set-run-status run-id run-status #!key (msg #f))
- (rmt:send-receive 'set-run-status #f (list run-id run-status msg)))
-
-(define (rmt:update-run-event_time run-id)
- (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)
- ;; (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)
- (rmt:send-receive 'get-main-run-stats #f (list run-id)))
-
-(define (rmt:get-var varname)
- (rmt:send-receive 'get-var #f (list varname)))
-
-(define (rmt:del-var varname)
- (rmt:send-receive 'del-var #f (list varname)))
-
-(define (rmt:set-var varname value)
- (rmt:send-receive 'set-var #f (list varname value)))
-
-;;======================================================================
-;; M U L T I R U N Q U E R I E S
-;;======================================================================
-
-;; Need to move this to multi-run section and make associated changes
-(define (rmt:find-and-mark-incomplete-all-runs #!key (ovr-deadtime #f))
- (let ((run-ids (rmt:get-all-run-ids)))
- (for-each (lambda (run-id)
- (rmt:find-and-mark-incomplete run-id ovr-deadtime))
- run-ids)))
-
-;; get the previous record for when this test was run where all keys match but runname
-;; returns #f if no such test found, returns a single test record if found
-;;
-;; Run this at the client end since we have to connect to multiple run-id dbs
-;;
-(define (rmt:get-previous-test-run-record run-id test-name item-path)
- (let* ((keyvals (rmt:get-key-val-pairs run-id))
- (keys (rmt:get-keys))
- (selstr (string-intersperse keys ","))
- (qrystr (string-intersperse (map (lambda (x)(conc x "=?")) keys) " AND ")))
- (if (not keyvals)
- #f
- (let ((prev-run-ids (rmt:get-prev-run-ids run-id)))
- ;; for each run starting with the most recent look to see if there is a matching test
- ;; if found then return that matching test record
- (debug:print 4 *default-log-port* "selstr: " selstr ", qrystr: " qrystr ", keyvals: " keyvals ", previous run ids found: " prev-run-ids)
- (if (null? prev-run-ids) #f
- (let loop ((hed (car prev-run-ids))
- (tal (cdr prev-run-ids)))
- (let ((results (rmt:get-tests-for-run hed (conc test-name "/" item-path) '() '() ;; run-id testpatt states statuses
- #f #f #f ;; offset limit not-in hide/not-hide
- #f #f #f #f 'normal))) ;; sort-by sort-order qryvals last-update mode
- (debug:print 4 *default-log-port* "Got tests for run-id " run-id ", test-name " test-name ", item-path " item-path ": " results)
- (if (and (null? results)
- (not (null? tal)))
- (loop (car tal)(cdr tal))
- (if (null? results) #f
- (car results))))))))))
-
-(define (rmt:get-run-stats)
- (rmt:send-receive 'get-run-stats #f '()))
-
-;;======================================================================
-;; S T E P S
-;;======================================================================
-
-;; Getting steps is more complicated.
-;;
-;; If given work area
-;; 1. Find the testdat.db file
-;; 2. Open the testdat.db file and do the query
-;; If not given the work area
-;; 1. Do a remote call to get the test path
-;; 2. Continue as above
-;;
-;;(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)
- (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:get-steps-for-test run-id test-id)
- (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)))
-
-;;======================================================================
-;; T E S T D A T A
-;;======================================================================
-
-(define (rmt:read-test-data run-id test-id categorypatt #!key (work-area #f))
- (rmt:send-receive 'read-test-data run-id (list run-id test-id categorypatt)))
-(define (rmt:read-test-data* run-id test-id categorypatt varpatt #!key (work-area #f))
- (rmt:send-receive 'read-test-data* 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:testmeta-add-record testname)
- (rmt:send-receive 'testmeta-add-record #f (list testname)))
-
-(define (rmt:testmeta-get-record testname)
- (rmt:send-receive 'testmeta-get-record #f (list testname)))
-
-(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)
- (rmt:send-receive 'test-data-rollup run-id (list run-id test-id status)))
-
-(define (rmt:csv->test-data run-id test-id csvdata)
- (rmt:send-receive 'csv->test-data run-id (list run-id test-id csvdata)))
-
-;;======================================================================
-;; T A S K S
-;;======================================================================
-
-(define (rmt:tasks-find-task-queue-records target run-name test-patt state-patt action-patt)
- (rmt:send-receive 'find-task-queue-records #f (list target run-name test-patt state-patt action-patt)))
-
-(define (rmt:tasks-add action owner target runname testpatt params)
- (rmt:send-receive 'tasks-add #f (list action owner target runname testpatt params)))
-
-(define (rmt:tasks-set-state-given-param-key param-key new-state)
- (rmt:send-receive 'tasks-set-state-given-param-key #f (list param-key new-state)))
-
-(define (rmt:tasks-get-last target runname)
- (rmt:send-receive 'tasks-get-last #f (list target runname)))
-
-;;======================================================================
-;; N O S Y N C D B
-;;======================================================================
-
-(define (rmt:no-sync-set var val)
- (rmt:send-receive 'no-sync-set #f `(,var ,val)))
-
-(define (rmt:no-sync-get/default var default)
- (rmt:send-receive 'no-sync-get/default #f `(,var ,default)))
-
-(define (rmt:no-sync-del! var)
- (rmt:send-receive 'no-sync-del! #f `(,var)))
-
-(define (rmt:no-sync-get-lock keyname)
- (rmt:send-receive 'no-sync-get-lock #f `(,keyname)))
-
-;;======================================================================
-;; A R C H I V E S
-;;======================================================================
-
-(define (rmt:archive-get-allocations testname itempath dneeded)
- (rmt:send-receive 'archive-get-allocations #f (list testname itempath dneeded)))
-
-(define (rmt:archive-register-block-name bdisk-id archive-path)
- (rmt:send-receive 'archive-register-block-name #f (list bdisk-id archive-path)))
-
-(define (rmt:archive-allocate-testsuite/area-to-block block-id testsuite-name areakey)
- (rmt:send-receive 'archive-allocate-test-to-block #f (list block-id testsuite-name areakey)))
-
-(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)
- (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)))
+(use (prefix pkts pkts:) srfi-18)
+
+(defstruct cmdrec
+ cmd
+ (host #f)
+ (run-ids #f)
+ params)
+
+;; call cmd on remote host (#f for any host)
+;;
+;; example: (rmt:run 'get-runs target run-name test-patt state status)
+;;
+(define (rmt:run cmd . params)
+ (let ((server (rmt:get-server cmdrec))) ;; look up server
+ #f))
+
+(define (rmt:get-connection-info . args)
+ #t
+ (print "Got here: rmt:get-connection-info"))
+(define (rmt:send-receive . args)
+ #t
+ (print "Got here: rmt:send-receive"))
+(define (rmt:print-db-stats . args)
+ #t
+ (print "Got here: rmt:print-db-stats"))
+(define (rmt:get-max-query-average . args)
+ #t
+ (print "Got here: rmt:get-max-query-average"))
+(define (rmt:open-qry-close-locally . args)
+ #t
+ (print "Got here: rmt:open-qry-close-locally"))
+(define (rmt:send-receive-no-auto-client-setup . args)
+ #t
+ (print "Got here: rmt:send-receive-no-auto-client-setup"))
+(define (rmt:kill-server . args)
+ #t
+ (print "Got here: rmt:kill-server"))
+(define (rmt:start-server . args)
+ #t
+ (print "Got here: rmt:start-server"))
+(define (rmt:login . args)
+ #t
+ (print "Got here: rmt:login"))
+(define (rmt:login-no-auto-client-setup . args)
+ #t
+ (print "Got here: rmt:login-no-auto-client-setup"))
+(define (rmt:general-call . args)
+ #t
+ (print "Got here: rmt:general-call"))
+(define (rmt:get-latest-host-load . args)
+ #t
+ (print "Got here: rmt:get-latest-host-load"))
+(define (rmt:sdb-qry . args)
+ #t
+ (print "Got here: rmt:sdb-qry"))
+(define (rmt:runtests . args)
+ #t
+ (print "Got here: rmt:runtests"))
+(define (rmt:get-run-record-ids . args)
+ #t
+ (print "Got here: rmt:get-run-record-ids"))
+(define (rmt:get-changed-record-ids . args)
+ #t
+ (print "Got here: rmt:get-changed-record-ids"))
+(define (rmt:get-tests-tags . args)
+ #t
+ (print "Got here: rmt:get-tests-tags"))
+(define (rmt:get-key-val-pairs . args)
+ #t
+ (print "Got here: rmt:get-key-val-pairs"))
+(define (rmt:get-keys . args)
+ #t
+ (print "Got here: rmt:get-keys"))
+(define (rmt:get-keys-write . args)
+ #t
+ (print "Got here: rmt:get-keys-write"))
+(define (rmt:get-key-vals . args)
+ #t
+ (print "Got here: rmt:get-key-vals"))
+(define (rmt:get-targets . args)
+ #t
+ (print "Got here: rmt:get-targets"))
+(define (rmt:get-target . args)
+ #t
+ (print "Got here: rmt:get-target"))
+(define (rmt:get-run-times . args)
+ #t
+ (print "Got here: rmt:get-run-times"))
+(define (rmt:register-test . args)
+ #t
+ (print "Got here: rmt:register-test"))
+(define (rmt:get-test-id . args)
+ #t
+ (print "Got here: rmt:get-test-id"))
+(define (rmt:get-test-info-by-id . args)
+ #t
+ (print "Got here: rmt:get-test-info-by-id"))
+(define (rmt:test-get-rundir-from-test-id . args)
+ #t
+ (print "Got here: rmt:test-get-rundir-from-test-id"))
+(define (rmt:open-test-db-by-test-id . args)
+ #t
+ (print "Got here: rmt:open-test-db-by-test-id"))
+(define (rmt:test-set-state-status-by-id . args)
+ #t
+ (print "Got here: rmt:test-set-state-status-by-id"))
+(define (rmt:set-tests-state-status . args)
+ #t
+ (print "Got here: rmt:set-tests-state-status"))
+(define (rmt:get-tests-for-run . args)
+ #t
+ (print "Got here: rmt:get-tests-for-run"))
+(define (rmt:synchash-get . args)
+ #t
+ (print "Got here: rmt:synchash-get"))
+(define (rmt:get-tests-for-run-mindata . args)
+ #t
+ (print "Got here: rmt:get-tests-for-run-mindata"))
+(define (rmt:get-tests-for-runs-mindata . args)
+ #t
+ (print "Got here: rmt:get-tests-for-runs-mindata"))
+(define (rmt:delete-test-records . args)
+ #t
+ (print "Got here: rmt:delete-test-records"))
+(define (rmt:test-set-state-status . args)
+ #t
+ (print "Got here: rmt:test-set-state-status"))
+(define (rmt:test-toplevel-num-items . args)
+ #t
+ (print "Got here: rmt:test-toplevel-num-items"))
+(define (rmt:get-matching-previous-test-run-records . args)
+ #t
+ (print "Got here: rmt:get-matching-previous-test-run-records"))
+(define (rmt:test-get-logfile-info . args)
+ #t
+ (print "Got here: rmt:test-get-logfile-info"))
+(define (rmt:test-get-records-for-index-file . args)
+ #t
+ (print "Got here: rmt:test-get-records-for-index-file"))
+(define (rmt:get-testinfo-state-status . args)
+ #t
+ (print "Got here: rmt:get-testinfo-state-status"))
+(define (rmt:test-set-log! . args)
+ #t
+ (print "Got here: rmt:test-set-log!"))
+(define (rmt:test-set-top-process-pid . args)
+ #t
+ (print "Got here: rmt:test-set-top-process-pid"))
+(define (rmt:test-get-top-process-pid . args)
+ #t
+ (print "Got here: rmt:test-get-top-process-pid"))
+(define (rmt:get-run-ids-matching-target . args)
+ #t
+ (print "Got here: rmt:get-run-ids-matching-target"))
+(define (rmt:test-get-paths-matching-keynames-target-new . args)
+ #t
+ (print "Got here: rmt:test-get-paths-matching-keynames-target-new"))
+(define (rmt:get-prereqs-not-met . args)
+ #t
+ (print "Got here: rmt:get-prereqs-not-met"))
+(define (rmt:get-count-tests-running-for-run-id . args)
+ #t
+ (print "Got here: rmt:get-count-tests-running-for-run-id"))
+(define (rmt:get-count-tests-running . args)
+ #t
+ (print "Got here: rmt:get-count-tests-running"))
+(define (rmt:get-count-tests-running-for-testname . args)
+ #t
+ (print "Got here: rmt:get-count-tests-running-for-testname"))
+(define (rmt:get-count-tests-running-in-jobgroup . args)
+ #t
+ (print "Got here: rmt:get-count-tests-running-in-jobgroup"))
+(define (rmt:set-state-status-and-roll-up-items . args)
+ #t
+ (print "Got here: rmt:set-state-status-and-roll-up-items"))
+(define (rmt:update-pass-fail-counts . args)
+ #t
+ (print "Got here: rmt:update-pass-fail-counts"))
+(define (rmt:top-test-set-per-pf-counts . args)
+ #t
+ (print "Got here: rmt:top-test-set-per-pf-counts"))
+(define (rmt:get-raw-run-stats . args)
+ #t
+ (print "Got here: rmt:get-raw-run-stats"))
+(define (rmt:get-test-times . args)
+ #t
+ (print "Got here: rmt:get-test-times"))
+(define (rmt:get-run-info . args)
+ #t
+ (print "Got here: rmt:get-run-info"))
+(define (rmt:get-num-runs . args)
+ #t
+ (print "Got here: rmt:get-num-runs"))
+(define (rmt:get-runs-cnt-by-patt . args)
+ #t
+ (print "Got here: rmt:get-runs-cnt-by-patt"))
+(define (rmt:register-run . args)
+ #t
+ (print "Got here: rmt:register-run"))
+(define (rmt:get-run-name-from-id . args)
+ #t
+ (print "Got here: rmt:get-run-name-from-id"))
+(define (rmt:delete-run . args)
+ #t
+ (print "Got here: rmt:delete-run"))
+(define (rmt:update-run-stats . args)
+ #t
+ (print "Got here: rmt:update-run-stats"))
+(define (rmt:delete-old-deleted-test-records . args)
+ #t
+ (print "Got here: rmt:delete-old-deleted-test-records"))
+(define (rmt:get-runs . args)
+ #t
+ (print "Got here: rmt:get-runs"))
+(define (rmt:simple-get-runs . args)
+ #t
+ (print "Got here: rmt:simple-get-runs"))
+(define (rmt:get-all-run-ids . args)
+ #t
+ (print "Got here: rmt:get-all-run-ids"))
+(define (rmt:get-prev-run-ids . args)
+ #t
+ (print "Got here: rmt:get-prev-run-ids"))
+(define (rmt:lock/unlock-run . args)
+ #t
+ (print "Got here: rmt:lock/unlock-run"))
+(define (rmt:get-run-status . args)
+ #t
+ (print "Got here: rmt:get-run-status"))
+(define (rmt:set-run-status . args)
+ #t
+ (print "Got here: rmt:set-run-status"))
+(define (rmt:update-run-event_time . args)
+ #t
+ (print "Got here: rmt:update-run-event_time"))
+(define (rmt:get-runs-by-patt . args)
+ #t
+ (print "Got here: rmt:get-runs-by-patt"))
+(define (rmt:find-and-mark-incomplete . args)
+ #t
+ (print "Got here: rmt:find-and-mark-incomplete"))
+(define (rmt:get-main-run-stats . args)
+ #t
+ (print "Got here: rmt:get-main-run-stats"))
+(define (rmt:get-var . args)
+ #t
+ (print "Got here: rmt:get-var"))
+(define (rmt:del-var . args)
+ #t
+ (print "Got here: rmt:del-var"))
+(define (rmt:set-var . args)
+ #t
+ (print "Got here: rmt:set-var"))
+(define (rmt:find-and-mark-incomplete-all-runs . args)
+ #t
+ (print "Got here: rmt:find-and-mark-incomplete-all-runs"))
+(define (rmt:get-previous-test-run-record . args)
+ #t
+ (print "Got here: rmt:get-previous-test-run-record"))
+(define (rmt:get-run-stats . args)
+ #t
+ (print "Got here: rmt:get-run-stats"))
+(define (rmt:teststep-set-status! . args)
+ #t
+ (print "Got here: rmt:teststep-set-status!"))
+(define (rmt:get-steps-for-test . args)
+ #t
+ (print "Got here: rmt:get-steps-for-test"))
+(define (rmt:get-steps-info-by-id . args)
+ #t
+ (print "Got here: rmt:get-steps-info-by-id"))
+(define (rmt:read-test-data . args)
+ #t
+ (print "Got here: rmt:read-test-data"))
+(define (rmt:read-test-data* . args)
+ #t
+ (print "Got here: rmt:read-test-data*"))
+(define (rmt:get-data-info-by-id . args)
+ #t
+ (print "Got here: rmt:get-data-info-by-id"))
+(define (rmt:testmeta-add-record . args)
+ #t
+ (print "Got here: rmt:testmeta-add-record"))
+(define (rmt:testmeta-get-record . args)
+ #t
+ (print "Got here: rmt:testmeta-get-record"))
+(define (rmt:testmeta-update-field . args)
+ #t
+ (print "Got here: rmt:testmeta-update-field"))
+(define (rmt:test-data-rollup . args)
+ #t
+ (print "Got here: rmt:test-data-rollup"))
+(define (rmt:csv->test-data . args)
+ #t
+ (print "Got here: rmt:csv->test-data"))
+(define (rmt:tasks-find-task-queue-records . args)
+ #t
+ (print "Got here: rmt:tasks-find-task-queue-records"))
+(define (rmt:tasks-add . args)
+ #t
+ (print "Got here: rmt:tasks-add"))
+(define (rmt:tasks-set-state-given-param-key . args)
+ #t
+ (print "Got here: rmt:tasks-set-state-given-param-key"))
+(define (rmt:tasks-get-last . args)
+ #t
+ (print "Got here: rmt:tasks-get-last"))
+(define (rmt:no-sync-set . args)
+ #t
+ (print "Got here: rmt:no-sync-set"))
+(define (rmt:no-sync-get/default . args)
+ #t
+ (print "Got here: rmt:no-sync-get/default"))
+(define (rmt:no-sync-del! . args)
+ #t
+ (print "Got here: rmt:no-sync-del!"))
+(define (rmt:no-sync-get-lock . args)
+ #t
+ (print "Got here: rmt:no-sync-get-lock"))
+(define (rmt:archive-get-allocations . args)
+ #t
+ (print "Got here: rmt:archive-get-allocations"))
+(define (rmt:archive-register-block-name . args)
+ #t
+ (print "Got here: rmt:archive-register-block-name"))
+(define (rmt:archive-allocate-testsuite/area-to-block . args)
+ #t
+ (print "Got here: rmt:archive-allocate-testsuite/area-to-block"))
+(define (rmt:archive-register-disk . args)
+ #t
+ (print "Got here: rmt:archive-register-disk"))
+(define (rmt:test-set-archive-block-id . args)
+ #t
+ (print "Got here: rmt:test-set-archive-block-id"))
+(define (rmt:test-get-archive-block-info . args)
+ #t
+ (print "Got here: rmt:test-get-archive-block-info"))
DELETED rpc-transport.scm
Index: rpc-transport.scm
==================================================================
--- rpc-transport.scm
+++ /dev/null
@@ -1,237 +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 rpc)
-(import (prefix rpc rpc:))
-
-(use sqlite3 srfi-1 posix regex regex-case srfi-69 hostinfo md5 message-digest)
-(import (prefix sqlite3 sqlite3:))
-
-(declare (unit rpc-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")
-
-;; procstr is the name of the procedure to be called as a string
-(define (rpc-transport:autoremote procstr params)
- (handle-exceptions
- exn
- (begin
- (debug:print 1 *default-log-port* "Remote failed for " proc " " params)
- (apply (eval (string->symbol procstr)) params))
- ;; (if *runremote*
- ;; (apply (eval (string->symbol (conc "remote:" procstr))) params)
- (apply (eval (string->symbol procstr)) params)))
-
-;; all routes though here end in exit ...
-;;
-;; start_server?
-;;
-(define (rpc-transport:launch run-id)
- (let* ((tdbdat (tasks:open-db)))
- (BB> "rpc-transport:launch fired for run-id="run-id)
- (set! *run-id* run-id)
- (if (args:get-arg "-daemonize")
- (daemon:ize))
- (if (server:check-if-running run-id)
- (begin
- (debug:print 0 *default-log-port* "INFO: Server for run-id " run-id " already running")
- (exit 0)))
- (let loop ((server-id (tasks:server-lock-slot (db:delay-if-busy tdbdat) run-id))
- (remtries 4))
- (if (not server-id)
- (if (> remtries 0)
- (begin
- (thread-sleep! 2)
- (loop (tasks:server-lock-slot (db:delay-if-busy tdbdat) run-id)
- (- remtries 1)))
- (begin
- ;; since we didn't get the server lock we are going to clean up and bail out
- (debug:print-info 2 *default-log-port* "INFO: server pid=" (current-process-id) ", hostname=" (get-host-name) " not starting due to other candidates ahead in start queue")
- (tasks:server-delete-records-for-this-pid (db:delay-if-busy tdbdat) " rpc-transport:launch")))
- (begin
- (rpc-transport:run (if (args:get-arg "-server")(args:get-arg "-server") "-") run-id server-id)
- (exit))))))
-
-(define (rpc-transport:run hostn run-id server-id)
- (debug:print 2 *default-log-port* "Attempting to start the rpc server ...")
- ;; (trace rpc:publish-procedure!)
-
- (rpc:publish-procedure! 'server:login server:login)
- (rpc:publish-procedure! 'testing (lambda () "Just testing"))
-
- (let* ((db #f)
- (hostname (get-host-name))
- (ipaddrstr (let ((ipstr (if (string=? "-" hostn)
- ;; (string-intersperse (map number->string (u8vector->list (hostname->ip hostname))) ".")
- (server:get-best-guess-address hostname)
- #f)))
- (if ipstr ipstr hostn))) ;; hostname)))
- (start-port (open-run-close tasks:server-get-next-port tasks:open-db))
- (link-tree-path (configf:lookup *configdat* "setup" "linktree"))
- (rpc:listener (rpc-transport:find-free-port-and-open (rpc:default-server-port)))
- (th1 (make-thread
- (lambda ()
- ((rpc:make-server rpc:listener) #t))
- "rpc:server"))
- ;; (cute (rpc:make-server rpc:listener) "rpc:server")
- ;; 'rpc:server))
- (hostname (if (string=? "-" hostn)
- (get-host-name)
- hostn))
- (ipaddrstr (if (string=? "-" hostn)
- (server:get-best-guess-address hostname) ;; (string-intersperse (map number->string (u8vector->list (hostname->ip hostname))) ".")
- #f))
- (portnum (rpc:default-server-port))
- (host:port (conc (if ipaddrstr ipaddrstr hostname) ":" portnum))
- (tdb (tasks:open-db)))
- (thread-start! th1)
- (set! db *dbstruct-db*)
- (open-run-close tasks:server-set-interface-port
- tasks:open-db
- server-id
- ipaddrstr portnum)
- (debug:print 0 *default-log-port* "Server started on " host:port)
-
- ;; (trace rpc:publish-procedure!)
- ;; (rpc:publish-procedure! 'server:login server:login)
- ;; (rpc:publish-procedure! 'testing (lambda () "Just testing"))
-
- ;;======================================================================
- ;; ;; end of publish-procedure section
- ;;======================================================================
- ;;
- (on-exit (lambda ()
- (open-run-close tasks:server-set-state! tasks:open-db server-id "stopped")))
-
- (set! *rpc:listener* rpc:listener)
- (tasks:server-set-state! tdb server-id "running")
- (set! *dbstruct-db* (db:setup run-id))
- ;; if none running or if > 20 seconds since
- ;; server last used then start shutdown
- (let loop ((count 0))
- (thread-sleep! 5) ;; no need to do this very often
- (let ((numrunning -1)) ;; (db:get-count-tests-running db)))
- (if (or (> numrunning 0)
- (> (+ *db-last-access* 60)(current-seconds)))
- (begin
- (debug:print-info 0 *default-log-port* "Server continuing, tests running: " numrunning ", seconds since last db access: " (- (current-seconds) *db-last-access*))
- (loop (+ 1 count)))
- (begin
- (debug:print-info 0 *default-log-port* "Starting to shutdown the server side")
- (open-run-close tasks:server-delete-record tasks:open-db server-id " rpc-transport:try-start-server stop")
- (thread-sleep! 10)
- (debug:print-info 0 *default-log-port* "Max cached queries was " *max-cache-size*)
- (debug:print-info 0 *default-log-port* "Server shutdown complete. Exiting")
- ))))))
-
-(define (rpc-transport:find-free-port-and-open port)
- (handle-exceptions
- exn
- (begin
- (print "Failed to bind to port " (rpc:default-server-port) ", trying next port")
- (rpc-transport:find-free-port-and-open (+ port 1)))
- (rpc:default-server-port port)
- (tcp-read-timeout 240000)
- (tcp-listen (rpc:default-server-port) 10000)))
-
-(define (rpc-transport:ping run-id host port)
- (handle-exceptions
- exn
- (begin
- (print "SERVER_NOT_FOUND")
- (exit 1))
- (let ((login-res ((rpc:procedure 'server:login host port) *toppath*)))
- (if (and (list? login-res)
- (car login-res))
- (begin
- (print "LOGIN_OK")
- (exit 0))
- (begin
- (print "LOGIN_FAILED")
- (exit 1))))))
-
-(define (rpc-transport:client-setup run-id #!key (remtries 10))
- (if *runremote*
- (begin
- (debug:print-error 0 *default-log-port* "Attempt to connect to server but already connected")
- #f)
- (let* ((host-info (hash-table-ref/default *runremote* run-id #f))) ;; (open-run-close db:get-var #f "SERVER"))
- (if host-info
- (let ((iface (car host-info))
- (port (cadr host-info))
- (ping-res ((rpc:procedure 'server:login host port) *toppath*)))
- (if ping-res
- (let ((server-dat (list iface port #f #f #f)))
- (hash-table-set! *runremote* run-id server-dat)
- server-dat)
- (begin
- (server:try-running *toppath*)
- (thread-sleep! 2)
- (rpc-transport:client-setup run-id (- remtries 1)))))
- (let* ((server-db-info (open-run-close tasks:get-server tasks:open-db run-id)))
- (debug:print-info 0 *default-log-port* "client:setup server-dat=" server-dat ", remaining-tries=" remaining-tries)
- (if server-db-info
- (let* ((iface (tasks:hostinfo-get-interface server-db-info))
- (port (tasks:hostinfo-get-port server-db-info))
- (server-dat (list iface port #f #f #f))
- (ping-res ((rpc:procedure 'server:login host port) *toppath*)))
- (if start-res
- (begin
- (hash-table-set! *runremote* run-id server-dat)
- server-dat)
- (begin
- (server:try-running *toppath*)
- (thread-sleep! 2)
- (rpc-transport:client-setup run-id (- remtries 1)))))
- (begin
- (server:try-running *toppath*)
- (thread-sleep! 2)
- (rpc-transport:client-setup run-id (- remtries 1)))))))))
-;;
-;; (port (if (and hostinfo (> (length hostdat) 1))(cadr hostdat) #f)))
-;; (if (and port
-;; (string->number port))
-;; (let ((portn (string->number port)))
-;; (debug:print-info 2 *default-log-port* "Setting up to connect to host " host ":" port)
-;; (handle-exceptions
-;; exn
-;; (begin
-;; (debug:print-error 0 *default-log-port* "Failed to open a connection to the server at host: " host " port: " port)
-;; (debug:print 0 *default-log-port* " EXCEPTION: " ((condition-property-accessor 'exn 'message) exn))
-;; ;; (open-run-close
-;; ;; (lambda (db . param)
-;; ;; (sqlite3:execute db "DELETE FROM metadat WHERE var='SERVER'"))
-;; ;; #f)
-;; (set! *runremote* #f))
-;; (if (and (not (args:get-arg "-server")) ;; no point in the server using the server using the server
-;; ((rpc:procedure 'server:login host portn) *toppath*))
-;; (begin
-;; (debug:print-info 2 *default-log-port* "Logged in and connected to " host ":" port)
-;; (set! *runremote* (vector host portn)))
-;; (begin
-;; (debug:print-info 2 *default-log-port* "Failed to login or connect to " host ":" port)
-;; (set! *runremote* #f)))))
-;; (debug:print-info 2 *default-log-port* "no server available")))))
-
Index: runs.scm
==================================================================
--- runs.scm
+++ runs.scm
@@ -2044,11 +2044,11 @@
(state-status (if (string? new-state-status) (string-split new-state-status ",") '(#f #f)))
(rp-mutex (make-mutex))
(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".
- (let* ((write-access-actions '(remove-runs set-state-status archive run-wait))
+ (let* ((write-access-actions '(remove-runs set-state-status archive run-wait kill-runs))
(dbfile (conc *toppath* "/megatest.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 .")
@@ -2081,16 +2081,19 @@
(worker-thread #f))
(debug:print-info 4 *default-log-port* "runs:operate-on run=" run ", header=" header)
(if (not (null? tests))
(begin
(case action
+ ((kill-runs)
+ (tasks:kill-runner target run-name "%")
+ (debug:print 1 *default-log-port* "Killing tests for run: " runkey " " (db:get-value-by-header run header "runname"))
+ )
((remove-runs)
;; (if (tasks:need-server run-id)(tasks:start-and-wait-for-server tdbdat run-id 10))
;; seek and kill in flight -runtests with % as testpatt here
;; (if (equal? testpatt "%")
(tasks:kill-runner target run-name testpatt)
-
;; (debug:print 0 *default-log-port* "not attempting to kill any run launcher processes as testpatt is " testpatt))
(debug:print 1 *default-log-port* "Removing tests for run: " runkey " " (db:get-value-by-header run header "runname")))
((set-state-status)
;; (if (tasks:need-server run-id)(tasks:start-and-wait-for-server tdbdat run-id 10))
(debug:print 1 *default-log-port* "Modifying state and staus for tests for run: " runkey " " (db:get-value-by-header run header "runname")))
@@ -2194,11 +2197,11 @@
(if (< (- now last-visit) 1.0)
(thread-sleep! 1.0))
(hash-table-set! backgrounded-remove-last-visit test-fulln (current-seconds))
;; send to back of line, loop
(let ((newtal (append tal (list test))))
- (loop (car newtal)(cdr newtal)))
+ (loop (car newtal)(cdr newtal)))
)
((done)
;; drop this one; if remaining, loop, else finish
(hash-table-set! backgrounded-remove-last-visit test-fulln (current-seconds))
(let ((subrun-remove-succeeded (hash-table-ref/default backgrounded-remove-result test-fulln 'exception)))
@@ -2251,10 +2254,32 @@
(begin
(runs:remove-test-directory new-test-dat mode) ;; 'remove-all)
(if (not (null? tal))
(loop (car tal)(cdr tal)))))))
(rmt:update-run-stats run-id (rmt:get-raw-run-stats run-id)))
+ ((kill-runs)
+ ;; RUNNING -> KILLREQ
+ ;; LAUNCHED,RUNNING,REMOTEHOSTSTART -> NOT STARTED
+ (cond
+ ((and has-subrun (member test-state (list "RUNNING" "LAUNCHED" "REMOTEHOSTSTART" "KILLREQ")))
+ (common:send-thunk-to-background-thread
+ (lambda ()
+ (let* ((subrun-remove-succeeded
+ (subrun:kill-subrun run-dir keep-records)))
+ #t)))
+ (if (not (null? tal))
+ (loop (car tal)(cdr tal)))
+ )
+ ((member test-state (list "RUNNING" "LAUNCHED" "REMOTEHOSTSTART" "KILLREQ"))
+ (debug:print 1 *default-log-port* "INFO: issuing killreq to test "test-fulln)
+ (mt:test-set-state-status-by-id run-id (db:test-get-id test) "KILLREQ" "n/a" #f)
+ (if (not (null? tal))
+ (loop (car tal)(cdr tal))))
+ (else
+ (if (not (null? tal))
+ (loop (car tal)(cdr tal)))
+ )))
((set-state-status)
(let* ((new-state (car state-status))
(new-status (cadr state-status))
(test-id (db:test-get-id test))
(test-run-dir (db:test-get-rundir new-test-dat))
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
@@ -15,606 +15,260 @@
;;
;; You should have received a copy of the GNU General Public License
;; along with Megatest. If not, see .
;;
+;;======================================================================
+;;
+;; This is the Megatest specific stuff for starting and maintaining a
+;; server. Anything that talks to the server should go in client.scm (maybe - might get rid of client.scm)
+;; General nanomsg stuff (not Megatest specific) should go in the
+;; nmsg-transport.scm file.
+;;
+;;======================================================================
+
(require-extension (srfi 18) extras tcp s11n)
(use srfi-1 posix regex regex-case srfi-69 hostinfo md5 message-digest
- directory-utils posix-extras matchable)
+ directory-utils posix-extras matchable typed-records
+ pkts)
(use spiffy uri-common intarweb http-client spiffy-request-vars)
(declare (unit server))
(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))
-
-(include "common_records.scm")
-(include "db_records.scm")
-
-(define (server:make-server-url hostport)
- (if (not hostport)
- #f
- (conc "http://" (car hostport) ":" (cadr hostport))))
-
-(define *server-loop-heart-beat* (current-seconds))
-
-;;======================================================================
-;; P K T S S T U F F
-;;======================================================================
-
-;; ???
-
-;;======================================================================
-;; P K T S S T U F F
-;;======================================================================
-
-;; ???
-
-;;======================================================================
-;; S E R V E R
-;;======================================================================
-
-;; Call this to start the actual server
-;;
-
-;; all routes though here end in exit ...
-;;
-;; start_server
-;;
-(define (server:launch run-id transport-type)
- (case transport-type
- ((http)(http-transport:launch))
- ;;((nmsg)(nmsg-transport:launch run-id))
- ;;((rpc) (rpc-transport:launch run-id))
- (else (debug:print-error 0 *default-log-port* "unknown server type " transport-type))))
-
-;;======================================================================
-;; S E R V E R U T I L I T I E S
-;;======================================================================
-
-;; Get the transport
-(define (server:get-transport)
- (if *transport-type*
- *transport-type*
- (let ((ttype (string->symbol
- (or (args:get-arg "-transport")
- (configf:lookup *configdat* "server" "transport")
- "rpc"))))
- (set! *transport-type* ttype)
- ttype)))
-
-;; Generate a unique signature for this server
-(define (server:mk-signature)
- (message-digest-string (md5-primitive)
- (with-output-to-string
- (lambda ()
- (write (list (current-directory)
- (argv)))))))
-
-;; When using zmq this would send the message back (two step process)
-;; with spiffy or rpc this simply returns the return data to be returned
-;;
-(define (server:reply return-addr query-sig success/fail result)
- (debug:print-info 11 *default-log-port* "server:reply return-addr=" return-addr ", result=" result)
- ;; (send-message pubsock target send-more: #t)
- ;; (send-message pubsock
- (case (server:get-transport)
- ((rpc) (db:obj->string (vector success/fail query-sig result)))
- ((http) (db:obj->string (vector success/fail query-sig result)))
- ((fs) result)
- (else
- (debug:print-error 0 *default-log-port* "unrecognised transport type: " *transport-type*)
- result)))
-
-;; Given a run id start a server process ### NOTE ### > file 2>&1
-;; if the run-id is zero and the target-host is set
-;; try running on that host
-;; incidental: rotate logs in logs/ dir.
-;;
-(define (server:run areapath) ;; areapath is *toppath* for a given testsuite area
- (let* ((curr-host (get-host-name))
- ;; (attempt-in-progress (server:start-attempted? areapath))
- ;; (dot-server-url (server:check-if-running areapath))
- (curr-ip (server:get-best-guess-address curr-host))
- (curr-pid (current-process-id))
- (homehost (common:get-homehost)) ;; configf:lookup *configdat* "server" "homehost" ))
- (target-host (car homehost))
- (testsuite (common:get-testsuite-name))
- (logfile (conc areapath "/logs/server.log")) ;; -" curr-pid "-" target-host ".log"))
- (cmdln (conc (common:get-megatest-exe)
- " -server " (or target-host "-") (if (equal? (configf:lookup *configdat* "server" "daemonize") "yes")
- " -daemonize "
- "")
- ;; " -log " logfile
- " -m testsuite:" testsuite)) ;; (conc " >> " logfile " 2>&1 &")))))
- (log-rotate (make-thread common:rotate-logs "server run, rotate logs thread"))
- (load-limit (configf:lookup-number *configdat* "jobtools" "max-server-start-load" default: 3.0)))
- ;; we want the remote server to start in *toppath* so push there
- (push-directory areapath)
- (debug:print 0 *default-log-port* "INFO: Trying to start server (" cmdln ") ...")
- (thread-start! log-rotate)
-
- ;; host.domain.tld match host?
- (if (and target-host
- ;; look at target host, is it host.domain.tld or ip address and does it
- ;; match current ip or hostname
- (not (string-match (conc "("curr-host "|" curr-host"\\..*)") target-host))
- (not (equal? curr-ip target-host)))
- (begin
- (debug:print-info 0 *default-log-port* "Starting server on " target-host ", logfile is " logfile)
- (setenv "TARGETHOST" target-host)))
-
- (setenv "TARGETHOST_LOGF" logfile)
- (thread-sleep! (/ (random 5000) 1000)) ;; add about a random (up to 5 seconds) initial delay. It seems pretty common that many running tests request a server at the same time
- (common:wait-for-normalized-load load-limit " delaying server start due to load" target-host) ;; do not try starting servers on an already overloaded machine, just wait forever
- (system (conc "nbfake " cmdln))
- (unsetenv "TARGETHOST_LOGF")
- (if (get-environment-variable "TARGETHOST")(unsetenv "TARGETHOST"))
- (thread-join! log-rotate)
- (pop-directory)))
-
-;; given a path to a server log return: host port startseconds
-;;
-(define (server:logf-get-start-info logf)
- (let ((rx (regexp "^SERVER STARTED: (\\S+):(\\d+) AT ([\\d\\.]+)"))) ;; SERVER STARTED: host:port AT timesecs
- (handle-exceptions
- exn
- (list #f #f #f) ;; no idea what went wrong, call it a bad server
- (with-input-from-file
- logf
- (lambda ()
- (let loop ((inl (read-line))
- (lnum 0))
- (if (not (eof-object? inl))
- (let ((mlst (string-match rx inl)))
- (if (not mlst)
- (if (< lnum 500) ;; give up if more than 500 lines of server log read
- (loop (read-line)(+ lnum 1))
- (list #f #f #f))
- (let ((dat (cdr mlst)))
- (list (car dat) ;; host
- (string->number (cadr dat)) ;; port
- (string->number (caddr dat))))))
- (list #f #f #f))))))))
-
-;; get a list of servers with all relevant data
-;; ( mod-time host port start-time pid )
-;;
-(define (server:get-list areapath #!key (limit #f))
- (let ((fname-rx (regexp "^(|.*/)server-(\\d+)-(\\S+).log$"))
- (day-seconds (* 24 60 60)))
- ;; if the directory exists continue to get the list
- ;; otherwise attempt to create the logs dir and then
- ;; continue
- (if (if (directory-exists? (conc areapath "/logs"))
- '()
- (if (file-write-access? areapath)
- (begin
- (condition-case
- (create-directory (conc areapath "/logs") #t)
- (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.")))
- (directory-exists? (conc areapath "/logs")))
- '()))
- (let* ((server-logs (glob (conc areapath "/logs/server-*.log")))
- (num-serv-logs (length server-logs)))
- (if (null? server-logs)
- '()
- (let loop ((hed (car server-logs))
- (tal (cdr server-logs))
- (res '()))
- (let* ((mod-time (handle-exceptions
- 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))
- (server:logf-get-start-info hed)
- '())) ;; don't waste time processing server files not touched in the 15 minutes if there are more than ten servers to look at
- (serv-rec (cons mod-time serv-dat))
- (fmatch (string-match fname-rx hed))
- (pid (if fmatch (string->number (list-ref fmatch 2)) #f))
- (new-res (if (null? serv-dat)
- res
- (cons (append serv-rec (list pid)) res))))
- (if (null? tal)
- (if (and limit
- (> (length new-res) limit))
- new-res ;; (take new-res limit) <= need intelligent sorting before this will work
- new-res)
- (loop (car tal)(cdr tal) new-res)))))))))
-
-(define (server:get-num-alive srvlst)
- (let ((num-alive 0))
- (for-each
- (lambda (server)
- (match-let (((mod-time host port start-time pid)
- server))
- (let* ((uptime (- (current-seconds) mod-time))
- (runtime (if start-time
- (- mod-time start-time)
- 0)))
- (if (< uptime 5)(set! num-alive (+ num-alive 1))))))
- srvlst)
- num-alive))
-
-;; given a list of servers get a list of valid servers, i.e. at least
-;; 10 seconds old, has started and is less than 1 hour old and is
-;; active (i.e. mod-time < 10 seconds
-;;
-;; mod-time host port start-time pid
-;;
-;; sort by start-time descending. I.e. get the oldest first. Young servers will thus drop off
-;; and servers should stick around for about two hours or so.
-;;
-(define (server:get-best srvlst)
- (let* ((nums (server:get-num-servers))
- (now (current-seconds))
- (slst (sort
- (filter (lambda (rec)
- (if (and (list? rec)
- (> (length rec) 2))
- (let ((start-time (list-ref rec 3))
- (mod-time (list-ref rec 0)))
- ;; (print "start-time: " start-time " mod-time: " mod-time)
- (and start-time mod-time
- (> (- now start-time) 0) ;; been running at least 0 seconds
- (< (- now mod-time) 16) ;; still alive - file touched in last 16 seconds
- (< (- now start-time)
- (+ (- (string->number (or (configf:lookup *configdat* "server" "runtime") "3600"))
- 180)
- (random 360))) ;; under one hour running time +/- 180
- ))
- #f))
- srvlst)
- (lambda (a b)
- (< (list-ref a 3)
- (list-ref b 3))))))
- (if (> (length slst) nums)
- (take slst nums)
- slst)))
-
-(define (server:get-first-best areapath)
- (let ((srvrs (server:get-best (server:get-list areapath))))
- (if (and srvrs
- (not (null? srvrs)))
- (car srvrs)
- #f)))
-
-(define (server:get-rand-best areapath)
- (let ((srvrs (server:get-best (server:get-list areapath))))
- (if (and (list? srvrs)
- (not (null? srvrs)))
- (let* ((len (length srvrs))
- (idx (random len)))
- (list-ref srvrs idx))
- #f)))
-
-
-(define (server:record->url servr)
- (match-let (((mod-time host port start-time pid)
- servr))
- (if (and host port)
- (conc host ":" port)
- #f)))
-
-(define (server:get-client-signature) ;; BB> why is this proc named "get-"? it returns nothing -- set! has not return value.
- (if *my-client-signature* *my-client-signature*
- (let ((sig (server:mk-signature)))
- (set! *my-client-signature* sig)
- *my-client-signature*)))
-
-;; kind start up of servers, wait 40 seconds before allowing another server for a given
-;; run-id to be launched
-(define (server:kind-run areapath)
- (if (not (server:check-if-running areapath)) ;; why try if there is already a server running?
- (let* ((last-run-dat (hash-table-ref/default *server-kind-run* areapath '(0 0))) ;; callnum, whenrun
- (call-num (car last-run-dat))
- (when-run (cadr last-run-dat))
- (run-delay (+ (case call-num
- ((0) 0)
- ((1) 20)
- ((2) 300)
- (else 600))
- (random 5))) ;; add a small random number just in case a lot of jobs hit the work hosts simultaneously
- (lock-file (conc areapath "/logs/server-start.lock")))
- (if (> (- (current-seconds) when-run) run-delay)
- (begin
- (common:simple-file-lock-and-wait lock-file expire-time: 15)
- (server:run areapath)
- (thread-sleep! 5) ;; don't release the lock for at least a few seconds
- (common:simple-file-release-lock lock-file)))
- (hash-table-set! *server-kind-run* areapath (list (+ call-num 1)(current-seconds))))))
-
-(define (server:start-and-wait areapath #!key (timeout 60))
- (let ((give-up-time (+ (current-seconds) timeout)))
- (let loop ((server-url (server:check-if-running areapath))
- (try-num 0))
- (if (or server-url
- (> (current-seconds) give-up-time)) ;; server-url will be #f if no server available.
- server-url
- (let ((num-ok (length (server:get-best (server:get-list areapath)))))
- (if (and (> try-num 0) ;; first time through simply wait a little while then try again
- (< num-ok 1)) ;; if there are no decent candidates for servers then try starting a new one
- (server:kind-run areapath))
- (thread-sleep! 5)
- (loop (server:check-if-running areapath)
- (+ try-num 1)))))))
-
-(define server:try-running server:run) ;; there is no more per-run servers ;; REMOVE ME. BUG.
-
-(define (server:get-num-servers #!key (numservers 2))
- (let ((ns (string->number
- (or (configf:lookup *configdat* "server" "numservers") "notanumber"))))
- (or ns numservers)))
-
-;; no longer care if multiple servers are started by accident. older servers will drop off in time.
-;;
-(define (server:check-if-running areapath) ;; #!key (numservers "2"))
- (let* ((ns (server:get-num-servers))
- (servers (server:get-best (server:get-list areapath))))
- ;; (print "servers: " servers " ns: " ns)
- (if (or (and servers
- (null? servers))
- (not servers)
- (and (list? servers)
- (< (length servers) (random ns)))) ;; somewhere between 0 and numservers
- #f
- (let loop ((hed (car servers))
- (tal (cdr servers)))
- (let ((res (server:check-server hed)))
- (if res
- res
- (if (null? tal)
- #f
- (loop (car tal)(cdr tal)))))))))
-
-;; ping the given server
-;;
-(define (server:check-server server-record)
- (let* ((server-url (server:record->url server-record))
- (res (case *transport-type*
- ((http)(server:ping server-url))
- ;; ((nmsg)(nmsg-transport:ping (tasks:hostinfo-get-interface server)
- )))
- (if res
- server-url
- #f)))
-
-(define (server:kill servr)
- (match-let (((mod-time hostname port start-time pid)
- servr))
- (tasks:kill-server hostname pid)))
-
-;; called in megatest.scm, host-port is string hostname:port
-;;
-;; NOTE: This is NOT called directly from clients as not all transports support a client running
-;; in the same process as the server.
-;;
-(define (server:ping host-port-in #!key (do-exit #f))
- (let ((host:port (if (not host-port-in) ;; use read-dotserver to find
- #f ;; (server:check-if-running *toppath*)
- ;; (if (number? host-port-in) ;; we were handed a server-id
- ;; (let ((srec (tasks:get-server-by-id (db:delay-if-busy (tasks:open-db)) host-port-in)))
- ;; ;; (print "srec: " srec " host-port-in: " host-port-in)
- ;; (if srec
- ;; (conc (vector-ref srec 3) ":" (vector-ref srec 4))
- ;; (conc "no such server-id " host-port-in)))
- host-port-in))) ;; )
- (let* ((host-port (if host:port
- (let ((slst (string-split host:port ":")))
- (if (eq? (length slst) 2)
- (list (car slst)(string->number (cadr slst)))
- #f))
- #f)))
-;; (toppath (launch:setup)))
- ;; (print "host-port=" host-port)
- (if (not host-port)
- (begin
- (if host-port-in
- (debug:print 0 *default-log-port* "ERROR: bad host:port"))
- (if do-exit (exit 1))
- #f)
- (let* ((iface (car host-port))
- (port (cadr host-port))
- (server-dat (http-transport:client-connect iface port))
- (login-res (rmt:login-no-auto-client-setup server-dat)))
- (if (and (list? login-res)
- (car login-res))
- (begin
- ;; (print "LOGIN_OK")
- (if do-exit (exit 0))
- #t)
- (begin
- ;; (print "LOGIN_FAILED")
- (if do-exit (exit 1))
- #f)))))))
-
-;; run ping in separate process, safest way in some cases
-;;
-(define (server:ping-server ifaceport)
- (with-input-from-pipe
- (conc (common:get-megatest-exe) " -ping " ifaceport)
- (lambda ()
- (let loop ((inl (read-line))
- (res "NOREPLY"))
- (if (eof-object? inl)
- (case (string->symbol res)
- ((NOREPLY) #f)
- ((LOGIN_OK) #t)
- (else #f))
- (loop (read-line) inl))))))
-
-;; NOT USED (well, ok, reference in rpc-transport but otherwise not used).
-;;
-(define (server:login toppath)
- (lambda (toppath)
- (set! *db-last-access* (current-seconds)) ;; might not be needed.
- (if (equal? *toppath* toppath)
- #t
- #f)))
-
-;; timeout is hms string: 1h 5m 3s, default is 1 minute
-;;
-(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)))
-
-(define (server:get-best-guess-address hostname)
- (let ((res #f))
- (for-each
- (lambda (adr)
- (if (not (eq? (u8vector-ref adr 0) 127))
- (set! res adr)))
- ;; NOTE: This can fail when there is no mention of the host in /etc/hosts. FIXME
- (vector->list (hostinfo-addresses (hostname->hostinfo hostname))))
- (string-intersperse
- (map number->string
- (u8vector->list
- (if res res (hostname->ip hostname)))) ".")))
-
-;; moving this here as it needs access to db and cannot be in common.
-;;
-(define (server:writable-watchdog 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))
- (sync-duration 0) ;; run time of the sync in milliseconds
- ;;(this-wd-num (begin (mutex-lock! *wdnum*mutex) (let ((x *wdnum*)) (set! *wdnum* (add1 *wdnum*)) (mutex-unlock! *wdnum*mutex) x)))
- )
- (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)
- (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)))))))
+
+(declare (uses db))
+(import db)
+
+;; Basic stuff for safely kicking off a server
+(declare (uses portlogger))
+(import portlogger)
+
+(declare (uses nmsg-transport))
+(import nmsg-transport)
+
+
+;; Might want to bring the daemonizing back
+;; (declare (uses daemon))
+
+(include "common_records.scm")
+(include "db_records.scm")
+
+;;======================================================================
+;; P K T S S T U F F
+;;======================================================================
+
+;;======================================================================
+;; N A N O M S G B A S E D S E R V E R
+;;======================================================================
+
+(defstruct area
+ (conn #f)
+ (port #f)
+ (myaddr #f)
+ (hosts (make-hash-table))
+ pktid ;; get pkt from hosts table if needed
+ pktfile
+ pktsdir
+ mtrah
+ (mutex (make-mutex))
+ )
+
+;; make it a global? Well, it is local to area module
+
+(define *area-conndat* (make-area))
+(define *pktspec*
+ `((server (hostname . h)
+ (port . p)
+ (pid . i)
+ )
+ (data (hostname . h) ;; sender hostname
+ (port . p) ;; sender port
+ (ip . i) ;; sender ip
+ (hostkey . k) ;; sending host key - store info at server under this key
+ (servkey . s) ;; server key - this needs to match at server end or reject the msg
+ (format . f) ;; sb=serialized-base64, t=text, sx=sexpr, j=json
+ (data . d) ;; base64 encoded slln data
+ )))
+
+(define (server:get-mtrah)
+ (or (get-environment-variable "MT_RUN_AREA_HOME")
+ (if (file-exists? "megatest.config")
+ (current-directory)
+ #f)))
+
+;; get a port
+;; start the nmsg server
+;; look for other servers
+;; contact other servers and compile list of servers
+;; there are two types of server
+;; main servers - dashboards, runners and dedicated servers - need pkt
+;; passive servers - test executers, step calls, list-runs - no pkt
+;;
+(define (server:start-nmsg #!optional (force-server-type #f))
+ (mutex-lock! (area-mutex *area-conndat*))
+ (let* ((server-type (or force-server-type
+ (if (args:any? "-run" "-server")
+ 'main
+ 'passive)))
+ (port-num (portlogger:open-run-close portlogger:find-port))
+ (area-conn (nmsg:start-server port-num))
+ ;; (pktspec (area-pktspec *area-conndat*))
+ (mtdir (or (server:get-mtrah)
+ (begin
+ (print "ERROR: megatest.config not found and MT_RUN_AREA_HOME is not set.")
+ #f)))
+ (pktdir (conc mtdir
+ "/.server-pkts")))
+ (if (not mtdir)
+ #f
+ (begin
+ (if (not (directory? pktdir))(create-directory pktdir))
+ ;; server is started, now create pkt if needed
+ (if (eq? server-type 'main)
+ (begin
+ (area-pktid-set! *area-conndat*
+ (write-alist->pkt
+ pktdir
+ `((hostname . ,(get-host-name))
+ (port . ,port-num)
+ (pid . ,(current-process-id)))
+ pktspec: *pktspec*
+ ptype: 'server))
+ (area-pktfile-set! *area-conndat* (conc pktdir "/" (area-pktid *area-conndat*) ".pkt"))))
+ ;; set all the area info in the
+ (area-pktsdir-set! *area-conndat* pktdir)
+ (area-mtrah-set! *area-conndat* mtdir)
+ (area-conn-set! *area-conndat* area-conn)
+ (area-port-set! *area-conndat* port-num)
+ (mutex-unlock! (area-mutex *area-conndat*))
+ #t))))
+
+;; Call this to start the actual server
+;;
+;; start_server
+;;
+;; mode: '
+;; handler: proc which takes pktrecieved as argument
+;;
+(define (server:launch mode handler)
+ (let* ((start-time (current-seconds))
+ (rep (server:start-nmsg mode))
+ (last-msg (current-seconds))
+ (th1 (make-thread
+ (lambda ()
+ (let loop ()
+ (let ((pktdat (nn-recv rep)))
+ (set! last-msg (current-seconds))
+ (if (not (eof-object? pktdat))
+ (begin
+ (proc pktdat)
+ (loop))))))
+ "message handler"))
+ (th2 (make-thread
+ (lambda ()
+ (let loop ()
+ (thread-sleep! 10)
+ (if (> (- (current-seconds) last-msg) 60) ;; timeout after 60 seconds
+ (begin
+ (print "Waited for 60 seconds and no messages, exiting now.")
+ (exit))
+ (loop)))))))
+ (thread-start! th1)
+ (thread-start! th2)
+ (thread-join th1)))
+
+(define (server:shutdown)
+ (let ((conn (area-conn *area-conndat*))
+ (pktf (area-pktfile *area-conndat*))
+ (port (area-port *area-conndat*)))
+ (if conn
+ (begin
+ (if pktf (delete-file* pktf))
+ (server:send-all "imshuttingdown")
+ (nmsg:close conn)
+ (portlogger:open-run-close portlogger:release-port port)))))
+
+(define (server:send-all msg)
+ #f)
+
+;; given a area record look up all the packets
+(define (server:get-all-server-pkts rec)
+ (let ((all-pkt-files (glob (conc (area-pktsdir rec) "/*.pkt"))))
+;; (pktspec (area-pktspec rec)))
+ (map (lambda (pkt-file)
+ (read-pkt->alist pkt-file pktspec: *pktspec*))
+ all-pkt-files)))
+
+#;((Z . "9a0212302295a19610d5796fce0370fa130758e9")
+ (port . "34827")
+ (pid . "28748")
+ (hostname . "zeus")
+ (T . "server")
+ (D . "1549427032.0"))
+
+;; srvpkt is the info for the server we wish to send the message to
+;;
+(define (server:send servpkt data dtype)
+ (let* ((port (alist-ref 'port servpkt))
+ (host (alist-ref 'hostname servpkt))
+ (hkey (alist-ref 'Z servpkt))
+ (addr (conc host ":" port))
+ (myport (area-port *area-conndat*))
+ (myhost (area-myaddr *area-conndat*))
+ (mykey (area-pktid *area-conndat*))
+ (msg (alist->pkt `((hostname . ,myhost)
+ (port . ,myport)
+ (servkey . ,hkey) ;; server looks at this to ensure message is for them
+ (hostkey . ,mykey)
+ (format . ,dtype) ;; formating of the message
+ (data . ,data))
+ *pktspec*)))
+ (if (and port host)
+ (nmsg:open-send-receive addr msg)
+ #f)))
+
+;; is the server alive?
+;;
+(define (server:ping servpkt)
+ (let* ((start-time (current-milliseconds))
+ (res (server:send servpkt "ping" "t")))
+ (cons (- (current-milliseconds)
+ (equal? res "got ping")))))
+
+;; look up all pkts and get the server id (the hash), port, host/ip
+;; store this info in the global struct *area-conndat*
+;;
+(define (server:get-all)
+ ;; readll all pkts
+ ;; foreach pkt; if it isn't me ping the server; if alive, add to hosts hash, else rm the pkt
+ (let ((all-pkts (server:get-all-server-pkts *area-conn*)))
+ (for-each
+ (lambda (servpkt)
+ (server:ping servpkt))
+ all-pkts)))
+
+;; send out an "I'm about to exit notice to all known servers"
+;;
+(define (server:imminent-death)
+ '())
+
+(define (server:get-my-best-address)
+ (ip->string (car (filter (lambda (x)
+ (not (eq? (u8vector-ref x 0) 127)))
+ (vector->list (hostinfo-addresses (hostname->hostinfo "zeus")))))))
+
+;; whoami? I am my pkt
+;;
+(define (server:whoami? area)
+ (hash-table-ref/default (area-hosts area)(area-pktid area) #f))
+
+;;======================================================================
+;; S E R V E R U T I L I T I E S
+;;======================================================================
+
+;; get a signature for identifing this process
+(define (server:get-process-signature)
+ (cons (get-host-name)(current-process-id)))
Index: subrun.scm
==================================================================
--- subrun.scm
+++ subrun.scm
@@ -118,10 +118,19 @@
(begin
(subrun:set-subrun-removed test-run-dir)
#t)
#f))
#t))
+
+(define (subrun:kill-subrun test-run-dir )
+ (if (and (not (subrun:subrun-removed? test-run-dir)) (subrun:subrun-test-initialized? test-run-dir))
+ (let* ((action-switches-str
+ (conc "-kill-runs" ))
+ (kill-result
+ (subrun:exec-sub-megatest test-run-dir action-switches-str "kill")))
+ kill-result)
+ #t))
(define (subrun:launch-cmd test-run-dir)
(if (subrun:subrun-removed? test-run-dir)
(subrun:unset-subrun-removed test-run-dir))
ADDED util.scm
Index: util.scm
==================================================================
--- /dev/null
+++ util.scm
@@ -0,0 +1,423 @@
+;;======================================================================
+;; Copyright 2018, 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 .
+;;
+;;======================================================================
+
+;;======================================================================
+;; Tests
+;;======================================================================
+
+(declare (unit util))
+
+(declare (uses common))
+
+(module util
+ *
+
+(import chicken scheme data-structures extras srfi-13 ports )
+
+
+;;======================================================================
+;; L O C K I N G M E C H A N I S M S
+;;======================================================================
+
+;; faux-lock is deprecated. Please use simple-lock below
+;;
+(define (common:faux-lock keyname #!key (wait-time 8)(allow-lock-steal #t))
+ (if (rmt:no-sync-get/default keyname #f) ;; do not be tempted to compare to pid. locking is a one-shot action, if already locked for this pid it doesn't actually count
+ (if (> wait-time 0)
+ (begin
+ (thread-sleep! 1)
+ (if (eq? wait-time 1) ;; only one second left, steal the lock
+ (begin
+ (debug:print-info 0 *default-log-port* "stealing lock for " keyname)
+ (common:faux-unlock keyname force: #t)))
+ (common:faux-lock keyname wait-time: (- wait-time 1)))
+ #f)
+ (begin
+ (rmt:no-sync-set keyname (conc (current-process-id)))
+ (equal? (conc (current-process-id)) (conc (rmt:no-sync-get/default keyname #f))))))
+
+(define (common:faux-unlock keyname #!key (force #f))
+ (if (or force (equal? (conc (current-process-id)) (conc (rmt:no-sync-get/default keyname #f))))
+ (begin
+ (if (rmt:no-sync-get/default keyname #f) (rmt:no-sync-del! keyname))
+ #t)
+ #f))
+
+;; simple lock. improve and converge on this one.
+;;
+(define (common:simple-lock keyname)
+ (rmt:no-sync-get-lock keyname))
+
+(define (common:run-a-command cmd #!key (with-vars #f))
+ (let* ((pre-cmd (dtests:get-pre-command))
+ (post-cmd (dtests:get-post-command))
+ (fullcmd (if (or pre-cmd post-cmd)
+ (conc pre-cmd cmd post-cmd)
+ (conc "viewscreen " cmd))))
+ (debug:print-info 02 *default-log-port* "Running command: " fullcmd)
+ (if with-vars
+ (common:without-vars cmd)
+ (common:without-vars fullcmd "MT_.*"))))
+
+;; ideally put all this info into the db, no need to preserve it across moving homehost
+;;
+;; return list of
+;; ( reachable? cpuload update-time )
+(define (common:get-host-info hostname)
+ (let* ((loadinfo (rmt:get-latest-host-load hostname)) ;; if this host happens to have been recently used by a test reuse the load data
+ (load (car loadinfo))
+ (load-sample-time (cdr loadinfo))
+ (load-sample-age (- (current-seconds) load-sample-time))
+ (loadinfo-timeout-seconds 6) ;; this was 20 seconds, seems way too lax. Switch to 6 seconds
+ (host-last-update-timeout-seconds 4)
+ (host-rec (hash-table-ref/default *host-loads* hostname #f))
+ )
+ (cond
+ ((< load-sample-age loadinfo-timeout-seconds)
+ (list #t
+ load-sample-time
+ load))
+ ((and host-rec
+ (< (current-seconds) (+ (host-last-update host-rec) host-last-update-timeout-seconds)))
+ (list #t
+ (host-last-update host-rec)
+ (host-last-cpuload host-rec )))
+ ((common:unix-ping hostname)
+ (list #t
+ (current-seconds)
+ (alist-ref 'adj-core-load (common:get-normalized-cpu-load hostname)))) ;; this is cheaper than you might think. get-normalized-cpu-load is cached for up to 5 seconds
+ (else
+ (list #f 0 -1) ;; bad host, don't use!
+ ))))
+
+(define (get-uname . params)
+ (let* ((uname-res (process:cmd-run->list (conc "uname " (if (null? params) "-a" (car params)))))
+ (uname #f))
+ (if (null? (car uname-res))
+ "unknown"
+ (caar uname-res))))
+
+(define (get-unix-df path)
+ (let* ((df-results (process:cmd-run->list (conc "df " path)))
+ (space-rx (regexp "([0-9]+)\\s+([0-9]+)%"))
+ (freespc #f))
+ ;; (write df-results)
+ (for-each (lambda (l)
+ (let ((match (string-search space-rx l)))
+ (if match
+ (let ((newval (string->number (cadr match))))
+ (if (number? newval)
+ (set! freespc newval))))))
+ (car df-results))
+ freespc))
+
+;; given path get free space, allows override in [setup]
+;; with free-space-script /path/to/some/script.sh
+;;
+(define (get-df path)
+ (if (configf:lookup *configdat* "setup" "free-space-script")
+ (with-input-from-pipe
+ (conc (configf:lookup *configdat* "setup" "free-space-script") " " path)
+ (lambda ()
+ (let ((res (read-line)))
+ (if (string? res)
+ (string->number res)))))
+ (get-unix-df path)))
+
+(define (std-exit-procedure)
+ (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)
+
+;; from metadat lookup MEGATEST_VERSION
+;;
+(define (common:get-last-run-version) ;; RADT => How does this work in send-receive function??; assume it is the value saved in some DB
+ (rmt:get-var "MEGATEST_VERSION"))
+
+(define (common:set-last-run-version)
+ (rmt:set-var "MEGATEST_VERSION" (common:version-signature)))
+
+;;======================================================================
+;; D I S K S P A C E
+;;======================================================================
+
+(define (common:get-disk-space-used fpath)
+ (with-input-from-pipe (conc "/usr/bin/du -s " fpath) read))
+
+(define (common:check-space-in-dir dirpath required)
+ (let* ((dbspace (if (directory? dirpath)
+ (get-df dirpath)
+ 0)))
+ (list (> dbspace required)
+ dbspace
+ required
+ dirpath)))
+
+;; check space in dbdir and in megatest dir
+;; returns: ok/not dbspace required-space
+;;
+(define (common:check-db-dir-space)
+ (let* ((required (string->number
+ (or (configf:lookup *configdat* "setup" "dbdir-space-required")
+ "100000")))
+ (dbdir (common:get-db-tmp-area)) ;; (db:get-dbdir))
+ (tdbspace (common:check-space-in-dir dbdir required))
+ (mdbspace (common:check-space-in-dir *toppath* required)))
+ (sort (list tdbspace mdbspace) (lambda (a b)
+ (< (cadr a)(cadr b))))))
+
+;; check available space in dbdir, exit if insufficient
+;;
+(define (common:check-db-dir-and-exit-if-insufficient)
+ (let* ((spacedat (car (common:check-db-dir-space))) ;; look only at worst for now
+ (is-ok (car spacedat))
+ (dbspace (cadr spacedat))
+ (required (caddr spacedat))
+ (dbdir (cadddr spacedat)))
+ (if (not is-ok)
+ (begin
+ (debug:print-error 0 *default-log-port* "Insufficient space in " dbdir ", require " required ", have " dbspace ", exiting now.")
+ (exit 1)))))
+
+;; paths is list of lists ((name path) ... )
+;;
+(define (common:get-disk-with-most-free-space disks minsize)
+ (let ((best #f)
+ (bestsize 0))
+ (for-each
+ (lambda (disk-num)
+ (let* ((dirpath (cadr (assoc disk-num disks)))
+ (freespc (cond
+ ((not (directory? dirpath))
+ (if (common:low-noise-print 300 "disks not a dir " disk-num)
+ (debug:print 0 *default-log-port* "WARNING: disk " disk-num " at path \"" dirpath "\" is not a directory - ignoring it."))
+ -1)
+ ((not (file-write-access? dirpath))
+ (if (common:low-noise-print 300 "disks not writeable " disk-num)
+ (debug:print 0 *default-log-port* "WARNING: disk " disk-num " at path \"" dirpath "\" is not writeable - ignoring it."))
+ -1)
+ ((not (eq? (string-ref dirpath 0) #\/))
+ (if (common:low-noise-print 300 "disks not a proper path " disk-num)
+ (debug:print 0 *default-log-port* "WARNING: disk " disk-num " at path \"" dirpath "\" is not a fully qualified path - ignoring it."))
+ -1)
+ (else
+ (get-df dirpath)))))
+ (if (> freespc bestsize)
+ (begin
+ (set! best (cons disk-num dirpath))
+ (set! bestsize freespc)))))
+ (map car disks))
+ (if (and best (> bestsize minsize))
+ best
+ #f))) ;; #f means no disk candidate found
+
+;; see defstruct host at top of file.
+;; host: reachable last-update last-used last-cpuload
+;;
+(define (common:update-host-loads-table hosts-raw)
+ (let* ((hosts (filter (lambda (x)
+ (string-match (regexp "^\\S+$") x))
+ hosts-raw)))
+ (for-each
+ (lambda (hostname)
+ (let* ((rec (let ((h (hash-table-ref/default *host-loads* hostname #f)))
+ (if h
+ h
+ (let ((h (make-host)))
+ (hash-table-set! *host-loads* hostname h)
+ h))))
+ (host-info (common:get-host-info hostname))
+ (is-reachable (car host-info))
+ (last-reached-time (cadr host-info))
+ (load (caddr host-info)))
+ (host-reachable-set! rec is-reachable)
+ (host-last-update-set! rec last-reached-time)
+ (host-last-cpuload-set! rec load)))
+ hosts)))
+
+;; go through the hosts from least recently used to most recently used, pick the first that meets the load criteral from the
+;; [host-rules] section.
+;;
+(define (common:get-least-loaded-host hosts-raw host-type configdat)
+ (let* ((rdat (configf:lookup configdat "host-rules" host-type))
+ (rules (common:val->alist (or rdat "") convert: #t)) ;; maxnload, maxnjobs, maxjobrate
+ (maxnload (common:alist-ref/default 'maxnload rules 1.5)) ;; max normalized load
+ (maxnjobs (common:alist-ref/default 'maxnjobs rules 1.5)) ;; max normalized number of jobs
+ (maxjobrate (common:alist-ref/default 'maxjobrate rules (/ 1 6))) ;; max rate of submitting jobs to a given host in jobs/second
+ (hosts (filter (lambda (x)
+ (string-match (regexp "^\\S+$") x))
+ hosts-raw))
+ ;; (best-host #f)
+ (get-rec (lambda (hostname)
+ ;; (print "get-rec hostname=" hostname)
+ (let ((h (hash-table-ref/default *host-loads* hostname #f)))
+ (if h
+ h
+ (let ((h (make-host)))
+ (hash-table-set! *host-loads* hostname h)
+ h)))))
+ (best-load 99999)
+ (curr-time (current-seconds))
+ (get-hosts-sorted (lambda (hosts)
+ (sort hosts (lambda (a b)
+ (let ((a-rec (get-rec a))
+ (b-rec (get-rec b)))
+ ;; (print "a=" a " a-rec=" a-rec " host-last-used=" (host-last-used a-rec))
+ ;; (print "b=" b " b-rec=" b-rec " host-last-used=" (host-last-used b-rec))
+ (< (host-last-used a-rec)
+ (host-last-used b-rec))))))))
+ (debug:print 0 *default-log-port* "INFO: hosts-sorted=" (get-hosts-sorted hosts))
+ (if (null? hosts)
+ #f ;; no hosts to select from. All done and giving up now.
+ (let ((hosts-sorted (get-hosts-sorted hosts)))
+ (common:update-host-loads-table hosts)
+ (let loop ((hostname (car hosts-sorted))
+ (tal (cdr hosts-sorted))
+ (best-host #f))
+ (let* ((rec (get-rec hostname))
+ (reachable (host-reachable rec))
+ (load (host-last-cpuload rec))
+ (last-used (host-last-used rec))
+ (delta (- curr-time last-used))
+ (job-rate (if (> delta 0)
+ (/ 1 delta)
+ 999)) ;; jobs per second
+ (new-best
+ (cond
+ ((not reachable)
+ (debug:print 0 *default-log-port* "Skipping host " hostname " as it cannot be reached.")
+ best-host)
+ ((and (< load maxnload) ;; load is acceptable
+ (< job-rate maxjobrate)) ;; job rate is acceptable
+ (set! best-load load)
+ hostname)
+ (else best-host))))
+ (debug:print 0 *default-log-port* "INFO: Trying host " hostname " with load " load ", last used " delta " seconds ago, with job-rate " job-rate " for running a test." )
+ (if new-best
+ (begin ;; found a host, return it
+ (debug:print 0 *default-log-port* "INFO: Found host: " new-best " load: " load " last-used: " delta " seconds ago, with job-rate: " job-rate)
+ (host-last-used-set! rec curr-time)
+ new-best)
+ (if (null? tal) #f (loop (car tal)(cdr tal) best-host)))))))))
+
+(define (common:wait-for-cpuload maxload-in numcpus-in waitdelay #!key (count 1000) (msg #f)(remote-host #f))
+ (let* ((loadavg (common:get-cpu-load remote-host))
+ (numcpus (if (< 1 numcpus-in) ;; not possible
+ (common:get-num-cpus remote-host)
+ numcpus-in))
+ (maxload (max maxload-in 0.5)) ;; so maxload must be greater than 0.5 for now BUG - FIXME?
+ (first (car loadavg))
+ (next (cadr loadavg))
+ (adjload (* maxload (max 1 numcpus))) ;; possible bug where numcpus (or could be maxload) is zero, crude fallback is to at least use 1
+ (loadjmp (- first next))
+ (adjwait (+ (random 10)(/ (- 1000 count) 10) waitdelay))) ;; add some randomness to the time to break any alignment where netbatch dumps many jobs to machines simultaneously
+ (cond
+ ((and (> first adjload)
+ (> count 0))
+ (debug:print-info 0 *default-log-port* "server start delayed " adjwait " seconds due to load " first " exceeding max of " adjload " on server " (or remote-host (get-host-name)) " (normalized load-limit: " maxload ") " (if msg msg ""))
+ (thread-sleep! adjwait)
+ (common:wait-for-cpuload maxload numcpus waitdelay count: (- count 1) msg: msg remote-host: remote-host))
+ ((and (> loadjmp numcpus)
+ (> count 0))
+ (debug:print-info 0 *default-log-port* "waiting " adjwait " seconds due to load jump " loadjmp " > numcpus " numcpus (if msg msg ""))
+ (thread-sleep! adjwait)
+ (common:wait-for-cpuload maxload numcpus waitdelay count: (- count 1) msg: msg remote-host: remote-host)))))
+
+(define (common:wait-for-homehost-load maxload msg)
+ (let* ((hh-dat (if (common:on-homehost?) ;; if we are on the homehost then pass in #f so the calls are local.
+ #f
+ (common:get-homehost)))
+ (hh (if hh-dat (car hh-dat) #f))
+ (numcpus (common:get-num-cpus hh)))
+ (common:wait-for-normalized-load maxload msg hh)))
+
+(define (common:get-num-cpus remote-host)
+ (let* ((actual-host (or remote-host (get-host-name))))
+ (or (common:get-cached-info actual-host "num-cpus" age: 86400) ;; hosts had better not be changing the number of cpus too often!
+ (let* ((proc (lambda ()
+ (let loop ((numcpu 0)
+ (inl (read-line)))
+ (if (eof-object? inl)
+ (begin
+ (common:write-cached-info remote-host "num-cpus" numcpu)
+ numcpu)
+ (loop (if (string-match "^processor\\s+:\\s+\\d+$" inl)
+ (+ numcpu 1)
+ numcpu)
+ (read-line))))))
+ (result (if remote-host
+ (with-input-from-pipe
+ (conc "ssh " remote-host " cat /proc/cpuinfo")
+ proc)
+ (with-input-from-file "/proc/cpuinfo" proc))))
+ (common:write-cached-info actual-host "num-cpus" result)
+ result))))
+
+;; wait for normalized cpu load to drop below maxload
+;;
+(define (common:wait-for-normalized-load maxload msg remote-host)
+ (let ((num-cpus (common:get-num-cpus remote-host)))
+ (common:wait-for-cpuload maxload num-cpus 15 msg: msg remote-host: remote-host)))
+
+
+)
+
ADDED utils/gen-list-of-functions.sh
Index: utils/gen-list-of-functions.sh
==================================================================
--- /dev/null
+++ utils/gen-list-of-functions.sh
@@ -0,0 +1,8 @@
+#!/bin/bash
+
+# extract a list of functions from a .scm file
+
+INFILE=$1
+
+grep -E '^\(define\s+\(' $INFILE|cut -f3 -d\(|tr ')' ' '|cut -f1 -d' '
+
ADDED utils/get-procedures.sh
Index: utils/get-procedures.sh
==================================================================
--- /dev/null
+++ utils/get-procedures.sh
@@ -0,0 +1,5 @@
+#!/bin/bash
+
+fname=$1
+
+grep '(define (' $fname | tr '()' ' '|awk '{print $2}'