Index: Makefile ================================================================== --- Makefile +++ Makefile @@ -4,14 +4,20 @@ 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 \ process.scm runs.scm tasks.scm tests.scm genexample.scm \ - fs-transport.scm http-transport.scm \ + http-transport.scm filedb.scm \ client.scm gutils.scm synchash.scm daemon.scm mt.scm dcommon.scm \ - tree.scm ezsteps.scm lock-queue.scm sdb.scm filedb.scm \ - rmt.scm api.scm tdb.scm + tree.scm ezsteps.scm lock-queue.scm sdb.scm \ + rmt.scm api.scm tdb.scm portlogger.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 \ + spiffy-directory-listing ssax sxml-serializer sxml-modifications iup canvas-draw sqlite3 GUISRCF = dashboard-tests.scm dashboard-guimonitor.scm OFILES = $(SRCFILES:%.scm=%.o) GOFILES = $(GUISRCF:%.scm=%.o) @@ -21,12 +27,17 @@ DEPLOYHELPERS=$(addprefix deploytarg/,$(ADTLSCR)) MTESTHASH=$(shell fossil info|grep checkout:| awk '{print $$2}') CSIPATH=$(shell which csi) CKPATH=$(shell dirname $(shell dirname $(CSIPATH))) +# ARCHSTR=$(shell uname -m)_$(shell uname -r) +# BASH_MACHTYPE=$(shell bash -c "echo \$$MACHTYPE") +# ARCHSTR=$(BASH_MACHTYPE)_$(shell lsb_release -sr) +ARCHSTR=$(shell lsb_release -sr) +# ARCHSTR=$(shell bash -c "echo \$$MACHTYPE") -all : mtest dboard newdboard txtdb +all : $(PREFIX)/bin/.$(ARCHSTR) mtest dboard txtdb refdb : txtdb/txtdb.scm csc -I txtdb txtdb/txtdb.scm -o refdb mtest: $(OFILES) megatest.o @@ -33,39 +44,25 @@ csc $(CSCOPTS) $(OFILES) megatest.o -o mtest dboard : $(OFILES) $(GOFILES) dashboard.scm csc $(OFILES) dashboard.scm $(GOFILES) -o dboard -newdboard : newdashboard.scm $(OFILES) $(GOFILES) - csc $(OFILES) $(GOFILES) newdashboard.scm -o newdboard - -$(PREFIX)/bin/revtagfsl : utils/revtagfsl.scm - csc utils/revtagfsl.scm -o $(PREFIX)/bin/revtagfsl - -deploytarg/libiupcd.so : $(CKPATH)/lib/libiupcd.so - for i in iup im cd av call sqlite; do \ - cp $(CKPATH)/lib/lib$$i* deploytarg/ ; \ - done - cp $(CKPATH)/include/*.h deploytarg - -# puts deployed megatest in directory "megatest" -deploytarg/megatest : $(OFILES) megatest.o - csc -deploy $(CSCOPTS) $(OFILES) megatest.scm - rsync -av megatest/ deploytarg/ - -deploytarg/dashboard : $(OFILES) $(GOFILES) - csc -deploy $(OFILES) $(GOFILES) dashboard.scm - rsync -av dashboard/ deploytarg/ - +ndboard : newdashboard.scm $(OFILES) $(GOFILES) + csc $(OFILES) $(GOFILES) newdashboard.scm -o ndboard + +# +# $(PREFIX)/bin/revtagfsl : utils/revtagfsl.scm +# csc utils/revtagfsl.scm -o $(PREFIX)/bin/revtagfsl # Special dependencies for the includes tests.o db.o launch.o runs.o dashboard-tests.o dashboard-guimonitor.o dashboard-main.o monitor.o dashboard.o megatest.o : db_records.scm tests.o runs.o dashboard.o dashboard-tests.o dashboard-main.o : run_records.scm db.o ezsteps.o keys.o launch.o megatest.o monitor.o runs-for-ref.o runs.o tests.o : key_records.scm tests.o tasks.o dashboard-tasks.o : task_records.scm runs.o : test_records.scm megatest.o : megatest-fossil-hash.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 zmq-transport.scm : common_records.scm # 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 @@ -75,29 +72,27 @@ $(OFILES) $(GOFILES) : common_records.scm %.o : %.scm csc $(CSCOPTS) -c $< -$(PREFIX)/bin/mtest : mtest +$(PREFIX)/bin/.$(ARCHSTR)/mtest : mtest @echo Installing to PREFIX=$(PREFIX) - $(INSTALL) mtest $(PREFIX)/bin/mtest - utils/mk_wrapper $(PREFIX) mtest > $(PREFIX)/bin/megatest + $(INSTALL) mtest $(PREFIX)/bin/.$(ARCHSTR)/mtest + utils/mk_wrapper $(PREFIX) mtest $(PREFIX)/bin/megatest chmod a+x $(PREFIX)/bin/megatest -$(PREFIX)/bin/newdboard : newdboard - $(INSTALL) newdboard $(PREFIX)/bin/newdboard - utils/mk_wrapper $(PREFIX) newdboard > $(PREFIX)/bin/newdashboard +$(PREFIX)/bin/.$(ARCHSTR)/ndboard : ndboard + $(INSTALL) ndboard $(PREFIX)/bin/.$(ARCHSTR)/ndboard + +$(PREFIX)/bin/newdashboard : $(PREFIX)/bin/.$(ARCHSTR)/ndboard + utils/mk_wrapper $(PREFIX) ndboard $(PREFIX)/bin/newdashboard chmod a+x $(PREFIX)/bin/newdashboard $(HELPERS) : utils/mt_* $(INSTALL) $< $@ chmod a+x $@ -$(DEPLOYHELPERS) : utils/mt_* - $(INSTALL) $< $@ - chmod a+X $@ - $(PREFIX)/bin/mt_xterm : utils/mt_xterm $(INSTALL) $< $@ chmod a+x $@ $(PREFIX)/bin/nbfake : utils/nbfake @@ -105,10 +100,14 @@ chmod a+x $@ $(PREFIX)/bin/nbfind : utils/nbfind $(INSTALL) $< $@ chmod a+x $@ + +$(PREFIX)/bin/loadrunner : utils/loadrunner + $(INSTALL) $< $@ + chmod a+x $@ $(PREFIX)/bin/refdb : refdb $(INSTALL) $< $@ chmod a+x $@ @@ -120,33 +119,67 @@ $(INSTALL) $< $@ chmod a+x $@ # install dashboard as dboard so wrapper script can be called dashboard -$(PREFIX)/bin/dboard : dboard $(FILES) - $(INSTALL) dboard $(PREFIX)/bin/dboard - utils/mk_wrapper $(PREFIX) dboard > $(PREFIX)/bin/dashboard +$(PREFIX)/bin/.$(ARCHSTR)/dboard : dboard $(FILES) + utils/mk_wrapper $(PREFIX) dboard $(PREFIX)/bin/dashboard chmod a+x $(PREFIX)/bin/dashboard - -install : bin $(PREFIX)/bin/mtest $(PREFIX)/bin/megatest $(PREFIX)/bin/dboard $(PREFIX)/bin/dashboard $(HELPERS) $(PREFIX)/bin/nbfake \ - $(PREFIX)/bin/nbfind $(PREFIX)/bin/newdboard $(PREFIX)/bin/refdb $(PREFIX)/bin/mt_xterm $(PREFIX)/bin/revtagfsl - -deploytarg/apropos.so : Makefile - for i in apropos base64 canvas-draw csv-xml directory-utils dot-locking extras fmt format hostinfo http-client intarweb json md5 message-digest posix posix-extras readline regex regex-case s11n spiffy spiffy-request-vars sqlite3 srfi-1 srfi-18 srfi-69 tcp test uri-common check-errors synch matchable sql-null tcp-server rpc blob-utils string-utils variable-item defstruct uri-generic sendfile opensll openssl lookup-table list-utils stack; do \ - chicken-install -prefix deploytarg -deploy $$i;done - -deploytarg/libsqlite3.so : - CSC_OPTIONS="-Ideploytarg -Ldeploytarg" $CHICKEN_INSTALL -prefix deploytarg -deploy sqlite3 - - - -deploy : deploytarg/megatest deploytarg/dashboard $(DEPLOYHELPERS) deploytarg/nbfake deploytarg/nbfind deploytarg/libiupcd.so deploytarg/apropos.so - - -bin : - mkdir -p $(PREFIX)/bin + $(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/nbfind $(PREFIX)/bin/loadrunner $(PREFIX)/bin/refdb $(PREFIX)/bin/mt_xterm \ + $(PREFIX)/bin/newdashboard + +$(PREFIX)/bin/.$(ARCHSTR) : + mkdir -p $(PREFIX)/bin/.$(ARCHSTR) test: tests/tests.scm cd tests;csi -I .. -b -n tests.scm clean : rm -f $(OFILES) $(GOFILES) megatest dboard dboard.o megatest.o dashboard.o + +# Deploy section (not complete yet) +# +$(DEPLOYHELPERS) : utils/mt_* + $(INSTALL) $< $@ + chmod a+X $@ + +deploytarg/apropos.so : Makefile + chicken-install -p deploytarg -deploy $(EGGS) + +# for i in apropos base64 canvas-draw csv-xml directory-utils dot-locking extras fmt format hostinfo http-client intarweb json md5 message-digest posix posix-extras readline regex regex-case s11n spiffy spiffy-request-vars sqlite3 srfi-1 srfi-18 srfi-69 tcp test uri-common check-errors synch matchable sql-null tcp-server rpc blob-utils string-utils variable-item defstruct uri-generic sendfile opensll openssl lookup-table list-utils stack; do \ +# chicken-install -prefix deploytarg -deploy $$i;done + +# deploytarg/libsqlite3.so : +# CSC_OPTIONS="-Ideploytarg -Ldeploytarg" $CHICKEN_INSTALL -prefix deploytarg -deploy sqlite3 + +deploy : deploytarg/mtest deploytarg/dboard $(DEPLOYHELPERS) deploytarg/nbfake deploytarg/nbfind deploytarg/apropos.so + +# deploytarg/libiupcd.so : $(CKPATH)/lib/libiupcd.so +# for i in iup im cd av call sqlite; do \ +# cp $(CKPATH)/lib/lib$$i* deploytarg/ ; \ +# done +# cp $(CKPATH)/include/*.h deploytarg + +# puts deployed megatest in directory "megatest" +deploytarg/mtest : $(OFILES) megatest.o deploytarg/apropos.so + csc -deploy $(CSCOPTS) $(OFILES) megatest.scm -o deploytarg + mv deploytarg/deploytarg deploytarg/mtest + +deploytarg/dboard : $(OFILES) $(GOFILES) dashboard.scm deploytarg/apropos.so + csc -deploy $(OFILES) $(GOFILES) dashboard.scm -o deploytarg + mv deploytarg/deploytarg deploytarg/dboard + +# DATASHAREO=configf.o common.o process.o tree.o dcommon.o margs.o launch.o gutils.o db.o synchash.o server.o \ +# megatest-version.o tdb.o ods.o mt.o keys.o +datashare-testing/sd : datashare.scm $(OFILES) + csc datashare.scm $(OFILES) -o datashare-testing/sd + +sd : datashare-testing/sd + mkdir -p /tmp/$(USER)/datashare/disk1 /tmp/$(USER)/basepath + +xterm : sd + (export BASEPATH=/tmp/$(USER)/basepath ; export PATH="$(PWD)/datashare-testing:$(PATH)" ; xterm &) + Index: TODO ================================================================== --- TODO +++ TODO @@ -1,4 +1,12 @@ -1. Confirm that branch transaction-for-sequential-writes content was added to trunk/development -2. Add a host chooser for ssh to launch-tests -3. Try making static executable +TODO +==== + +Migration to inmem db plus per run db +------------------------------------- + +. Re-work the dbstruct data structure? +.. Move main.db to global? +.. [ run-id.db inmemdb last-mod last-read last-sync inuse ] +. Re-work all queries to use run-id to dereference server +. Open main.db directly in calls to -runtests etc. No need to talk remote? Index: api.scm ================================================================== --- api.scm +++ api.scm @@ -10,104 +10,136 @@ ;;====================================================================== (declare (unit api)) (declare (uses rmt)) (declare (uses db)) + +;; allow these queries through without starting a server +;; +(define api:read-only-queries + '(get-key-val-pairs + get-keys + test-toplevel-num-items + get-test-info-by-id + test-get-rundir-from-test-id + 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-paths-matching-keynames-target-new + get-prereqs-not-met + get-count-tests-running-for-run-id + get-run-info + get-run-status + register-run + get-tests-for-run + get-test-id + get-tests-for-runs-mindata + get-run-name-from-id + get-runs + get-all-run-ids + get-prev-run-ids + get-run-ids-matching-target + get-runs-by-patt + get-steps-data + login + testmeta-get-record)) ;; These are called by the server on recipt of /api calls -(define (api:execute-requests db cmd params) +(define (api:execute-requests dbstruct cmd params) (case (string->symbol cmd) + ;; SERVERS + ((start-server) (apply server:kind-run params)) + ((kill-server) (set! *server-run* #f)) + ;; KEYS - ((get-key-val-pairs) (apply db:get-key-val-pairs db params)) - ((get-keys) (db:get-keys db)) + ((get-key-val-pairs) (apply db:get-key-val-pairs dbstruct params)) + ((get-keys) (db:get-keys dbstruct)) ;; TESTS - ;; json doesn't do vectors, convert to list - ((get-test-info-by-id) (apply db:get-test-info-by-id db params)) - ((test-get-rundir-from-test-id) (apply db:test-get-rundir-from-test-id db params)) - ((test-set-state-status-by-id) (apply db:test-set-state-status-by-id db params)) - ((get-count-tests-running) (db:get-count-tests-running db)) - ((get-count-tests-running-in-jobgroup) (apply db:get-count-tests-running-in-jobgroup db params)) - ((delete-test-records) (apply db:delete-test-records db params)) - ((delete-old-deleted-test-records) (db:delete-old-deleted-test-records db)) - ((test-set-status-state) (apply db:test-set-status-state db params)) - ((get-previous-test-run-record) (apply db:get-previous-test-run-record db params)) - ((get-matching-previous-test-run-records)(apply db:get-matching-previous-test-run-records db params)) - ((db:test-get-logfile-info) (apply db:test-get-logfile-info db params)) - ((test-get-records-for-index-file (apply db:test-get-records-for-index-file db params))) - ((get-testinfo-state-status) (apply db:get-testinfo-state-status db params)) - ((test-get-paths-matching-keynames-target-new) (apply db:test-get-paths-matching-keynames-target-new db params)) - ((get-prereqs-not-met) (apply db:get-prereqs-not-met db params)) - ((roll-up-pass-fail-counts) (apply db:roll-up-pass-fail-counts db params)) - ((update-fail-pass-counts) (apply db:general-call db 'update-pass-fail-counts params)) - ((get-count-tests-running-for-run-id) (apply db:get-count-tests-running-for-run-id db params)) + ((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)) + ((test-set-state-status-by-id) (apply db:test-set-state-status-by-id 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-records) (apply db:delete-test-records dbstruct params)) + ;; ((delete-test-step-records) (apply db:delete-test-step-records dbstruct params)) + ((delete-old-deleted-test-records) (apply db:delete-old-deleted-test-records dbstruct params)) + ((test-set-status-state) (apply db:test-set-status-state 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-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)) + ((roll-up-pass-fail-counts) (apply db:roll-up-pass-fail-counts dbstruct params)) + ((update-fail-pass-counts) (apply db:general-call dbstruct 'update-pass-fail-counts params)) + ((get-count-tests-running-for-run-id) (apply db:get-count-tests-running-for-run-id dbstruct params)) ;; RUNS - ((get-run-info) (apply db:get-run-info db params)) - ((register-run) (apply db:register-run db params)) - ((set-tests-state-status) (apply db:set-tests-state-status db params)) - ((get-tests-for-run) (apply db:get-tests-for-run db params)) - ((get-test-id) (apply db:get-test-id-not-cached db params)) - ((get-tests-for-runs-mindata) (apply db:get-tests-for-runs-mindata db params)) - ((get-run-name-from-id) (apply db:get-run-name-from-id db params)) - ((delete-run) (apply db:delete-run db params)) - ((get-runs) (apply db:get-runs db params)) - ((get-runs-by-patt) (apply db:get-runs-by-patt db params)) - ((lock/unlock-run) (apply db:lock/unlock-run db params)) - ((update-run-event_time) (apply db:update-run-event_time db params)) + ((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)) + ((register-run) (apply db:register-run dbstruct params)) + ((set-tests-state-status) (apply db:set-tests-state-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-runs-mindata) (apply db:get-tests-for-runs-mindata dbstruct params)) + ((get-run-name-from-id) (apply db:get-run-name-from-id dbstruct params)) + ((delete-run) (apply db:delete-run dbstruct params)) + ((get-runs) (apply db:get-runs 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)) + ((lock/unlock-run) (apply db:lock/unlock-run dbstruct params)) + ((update-run-event_time) (apply db:update-run-event_time dbstruct params)) + ((find-and-mark-incomplete) (apply db:find-and-mark-incomplete dbstruct params)) ;; STEPS - ((teststep-set-status!) (apply db:teststep-set-status! db params)) + ((teststep-set-status!) (apply db:teststep-set-status! dbstruct params)) ;; TEST DATA - ((test-data-rollup) (apply db:test-data-rollup db params)) - ((csv->test-data) (apply db:csv->test-data db params)) - ((get-steps-data) (apply db:get-steps-data db params)) + ((test-data-rollup) (apply db:test-data-rollup dbstruct params)) + ((csv->test-data) (apply db:csv->test-data dbstruct params)) + ((get-steps-data) (apply db:get-steps-data dbstruct params)) ;; MISC - ((login) (apply db:login db params)) + ((login) (apply db:login dbstruct params)) ((general-call) (let ((stmtname (car params)) - (realparams (cdr params))) - (db:general-call db stmtname realparams))) - ((sync-inmem->db) (db:sync-back)) - ((kill-server) - (db:sync-tables (db:tbls *inmemdb*) *inmemdb* *db*) ;; (db:sync-to *inmemdb* *db*) - (let ((hostname (car *runremote*)) - (port (cadr *runremote*)) - (pid (if (null? params) #f (car params))) - (th1 (make-thread (lambda ()(thread-sleep! 3)(debug:print 0 "Server exiting!")(exit 0)) "Server exit thread"))) - (debug:print 0 "WARNING: Server on " hostname ":" port " going down by user request!") - (debug:print-info 1 "current pid=" (current-process-id)) - (open-run-close tasks:server-deregister tasks:open-db - hostname - port: port) - (set! *server-run* #f) - (thread-sleep! 3) - (if pid - (process-signal pid signal/kill) - (thread-start! th1)) - '(#t "exit process started"))) + (run-id (cadr params)) + (realparams (cddr params))) + (db:with-db dbstruct run-id #t ;; these are all for modifying the db + (lambda (db) + (db:general-call db stmtname realparams))))) + ((sync-inmem->db) (db:sync-touched dbstruct run-id force-sync: #t)) + ((sdb-qry) (apply sdb:qry params)) ;; TESTMETA - ((testmeta-get-record) (apply db:testmeta-get-record db params)) - ((testmeta-add-record) (apply db:testmeta-add-record db params)) - ((testmeta-update-field) (apply db:testmeta-update-field db params)) + ((testmeta-get-record) (apply db:testmeta-get-record dbstruct params)) + ((testmeta-add-record) (apply db:testmeta-add-record dbstruct params)) + ((testmeta-update-field) (apply db:testmeta-update-field dbstruct params)) (else (list "ERROR" 0)))) ;; http-server send-response ;; api:process-request ;; db:* ;; ;; NB// Runs on the server as part of the server loop ;; -(define (api:process-request db $) ;; the $ is the request vars proc +(define (api:process-request dbstruct $) ;; the $ is the request vars proc (let* ((cmd ($ 'cmd)) (paramsj ($ 'params)) (params (db:string->obj paramsj)) ;; (rmt:json-str->dat paramsj)) - (res (api:execute-requests db cmd params))) + (res (api:execute-requests dbstruct cmd params))) ;; 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) Index: client.scm ================================================================== --- client.scm +++ client.scm @@ -50,38 +50,83 @@ ;; 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 -(define (client:setup #!key (numtries 3)) - (if (not *toppath*) - (if (not (setup-for-run)) - (begin - (debug:print 0 "ERROR: failed to find megatest.config, exiting") - (exit)))) - (push-directory *toppath*) ;; This is probably NOT needed - (debug:print-info 11 "*transport-type* is " *transport-type* ", *runremote* is " *runremote*) - (let* ((hostinfo (open-run-close tasks:get-best-server tasks:open-db))) - (debug:print-info 11 "CLIENT SETUP, hostinfo=" hostinfo) - (set! *transport-type* (if hostinfo - (string->symbol (tasks:hostinfo-get-transport hostinfo)) - 'fs)) - (debug:print-info 11 "Using transport type of " *transport-type* (if hostinfo (conc " to connect to " hostinfo) "")) - (case *transport-type* - ((fs)(if (not *megatest-db*)(set! *megatest-db* (open-db)))) - ((http) - (http-transport:client-connect (tasks:hostinfo-get-interface hostinfo) - (tasks:hostinfo-get-port hostinfo))) - ((zmq) - (zmq-transport:client-connect (tasks:hostinfo-get-interface hostinfo) - (tasks:hostinfo-get-port hostinfo) - (tasks:hostinfo-get-pubport hostinfo))) - (else ;; default to fs - (debug:print 0 "ERROR: unrecognised transport type " *transport-type* " attempting to continue with fs") - (set! *transport-type* 'fs) - (set! *megatest-db* (open-db)))) - (pop-directory))) +;; +;; lookup_server, need to remove *runremote* stuff +;; +(define (client:setup run-id #!key (remaining-tries 100) (failed-connects 0)) + (debug:print-info 2 "client:setup remaining-tries=" remaining-tries) + (if (<= remaining-tries 0) + (begin + (debug:print 0 "ERROR: failed to start or connect to server for run-id " run-id) + (exit 1)) + (let ((host-info (hash-table-ref/default *runremote* run-id #f))) + (if host-info + (let* ((iface (http-transport:server-dat-get-iface host-info)) + (port (http-transport:server-dat-get-port host-info)) + (start-res (http-transport:client-connect iface port)) + (ping-res (rmt:login-no-auto-client-setup start-res run-id))) + (if ping-res ;; sucessful login? + (begin + (debug:print-info 2 "client:setup, ping is good using host-info=" host-info ", remaining-tries=" remaining-tries) + ;; Why add the close-connections here? + ;; (http-transport:close-connections run-id) + (hash-table-set! *runremote* run-id start-res) + start-res) ;; return the server info + ;; have host info but no ping. shutdown the current connection and try again + (begin ;; login failed + (debug:print-info 1 "client:setup, ping is bad for start-res=" start-res " and *runremote*=" host-info) + (http-transport:close-connections run-id) + (hash-table-delete! *runremote* run-id) + (if (< remaining-tries 8) + (thread-sleep! 5) + (thread-sleep! 1)) + (client:setup run-id remaining-tries: (- remaining-tries 1))))) + ;; YUK: rename server-dat here + (let* ((server-dat (tasks:get-server (tasks:get-db) run-id))) + (debug:print-info 4 "client:setup server-dat=" server-dat ", remaining-tries=" remaining-tries) + (if server-dat + (let* ((iface (tasks:hostinfo-get-interface server-dat)) + (port (tasks:hostinfo-get-port server-dat)) + (start-res (http-transport:client-connect iface port)) + (ping-res (rmt:login-no-auto-client-setup start-res run-id))) + (if (and start-res + ping-res) + (begin + (hash-table-set! *runremote* run-id start-res) + (debug:print-info 2 "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 "client:setup, login failed, will attempt to start server ... start-res=" start-res ", run-id=" run-id ", server-dat=" server-dat) + (http-transport:close-connections run-id) + (hash-table-delete! *runremote* run-id) + (tasks:server-force-clean-run-record (tasks:get-db) + run-id + (tasks:hostinfo-get-interface server-dat) + (tasks:hostinfo-get-port server-dat) + " client:setup (server-dat = #t)") + (thread-sleep! 2) + (server:try-running run-id) + (thread-sleep! 10) ;; give server a little time to start up + (client:setup run-id remaining-tries: (- remaining-tries 1))))) + (begin ;; no server registered + (let ((num-available (tasks:num-in-available-state (tasks:get-db) run-id))) + (debug:print-info 0 "client:setup, no server registered, remaining-tries=" remaining-tries " num-available=" num-available) + (thread-sleep! 2) + (if (< num-available 2) + (begin + ;; (open-run-close tasks:server-clean-out-old-records-for-run-id tasks:open-db run-id " client:setup (server-dat=#f)") + (server:try-running run-id))) + (thread-sleep! 10) ;; give server a little time to start up + (client:setup run-id remaining-tries: (- remaining-tries 1)))))))))) + +;; keep this as a function to ease future +(define (client:start run-id server-info) + (http-transport:client-connect (tasks:hostinfo-get-interface server-info) + (tasks:hostinfo-get-port server-info))) ;; client:signal-handler (define (client:signal-handler signum) (handle-exceptions exn @@ -98,13 +143,16 @@ (thread-start! th2) (thread-start! th1) (thread-join! th2)))) ;; client:launch -(define (client:launch) +;; Need to set the signal handler somewhere other than here as this +;; routine will go away. +;; +(define (client:launch run-id) (set-signal-handler! signal/int client:signal-handler) - (if (client:setup) - (debug:print-info 2 "connected as client") - (begin - (debug:print 0 "ERROR: Failed to connect as client") - (exit)))) + (if (client:setup run-id) + (debug:print-info 2 "connected as client") + (begin + (debug:print 0 "ERROR: Failed to connect as client") + (exit)))) Index: common.scm ================================================================== --- common.scm +++ common.scm @@ -7,11 +7,11 @@ ;; This program is distributed WITHOUT ANY WARRANTY; without even the ;; implied warranty of MERCHANTABILITY or FITNESS FOR A PARTICULAR ;; PURPOSE. ;;====================================================================== -(use sqlite3 srfi-1 posix regex-case base64 format dot-locking csv-xml) +(use sqlite3 srfi-1 posix regex-case base64 format dot-locking csv-xml z3) (require-extension sqlite3 regex posix) (require-extension (srfi 18) extras tcp rpc) (import (prefix sqlite3 sqlite3:)) @@ -23,10 +23,17 @@ ;; (require-library margs) ;; (include "margs.scm") (define getenv get-environment-variable) +(define (safe-setenv key val) + (if (and (string? val)(string? key)) + (handle-exceptions + exn + (debug:print 0 "ERROR: bad value for setenv, key=" key ", value=" val) + (setenv key val)) + (debug:print 0 "ERROR: bad value for setenv, key=" key ", value=" val))) (define home (getenv "HOME")) (define user (getenv "USER")) ;; GLOBAL GLETCHES @@ -37,29 +44,43 @@ (define *already-seen-runconfig-info* #f) (define *waiting-queue* (make-hash-table)) (define *test-meta-updated* (make-hash-table)) (define *globalexitstatus* 0) ;; attempt to work around possible thread issues (define *passnum* 0) ;; when running track calls to run-tests or similar +(define *write-frequency* (make-hash-table)) ;; run-id => (vector (current-seconds) 0)) +(define *alt-log-file* #f) ;; used by -log +(define *common:denoise* (make-hash-table)) ;; for low noise printing + +;; DATABASE +(define *dbstruct-db* #f) +(define *db-stats* (make-hash-table)) ;; hash of vectors < count duration-total > +(define *db-stats-mutex* (make-mutex)) +(define *db-sync-mutex* (make-mutex)) +(define *db-multi-sync-mutex* (make-mutex)) +(define *db-local-sync* (make-hash-table)) ;; used to record last touch of db +(define *megatest-db* #f) +(define *last-db-access* (current-seconds)) ;; update when db is accessed via server +(define *db-write-access* #t) +(define *inmemdb* #f) +(define *task-db* #f) ;; (vector db path-to-db) ;; SERVER (define *my-client-signature* #f) -(define *transport-type* 'fs) -(define *megatest-db* #f) +(define *transport-type* 'http) (define *rpc:listener* #f) ;; if set up for server communication this will hold the tcp port -(define *runremote* #f) ;; if set up for server communication this will hold -(define *last-db-access* (current-seconds)) ;; update when db is accessed via server +(define *runremote* (make-hash-table)) ;; if set up for server communication this will hold (define *max-cache-size* 0) (define *logged-in-clients* (make-hash-table)) (define *client-non-blocking-mode* #f) (define *server-id* #f) (define *server-info* #f) (define *time-to-exit* #f) (define *received-response* #f) (define *default-numtries* 10) (define *server-run* #t) -(define *db-write-access* #t) -(define *inmemdb* #f) +(define *run-id* #f) +(define *server-kind-run* (make-hash-table)) (define *target* (make-hash-table)) ;; cache the target here; target is keyval1/keyval2/.../keyvalN (define *keys* (make-hash-table)) ;; cache the keys here (define *keyvals* (make-hash-table)) (define *toptest-paths* (make-hash-table)) ;; cache toptest path settings here @@ -91,10 +112,38 @@ (set! *test-info* (make-hash-table)) (set! *run-info-cache* (make-hash-table)) (set! *env-vars-by-run-id* (make-hash-table)) (set! *test-id-cache* (make-hash-table))) +;; Generic string database (normalization of sorts) +(define sdb:qry #f) ;; (make-sdb:qry)) ;; 'init #f) +;; Generic path database (normalization of sorts) +(define *fdb* #f) + +;;====================================================================== +;; U S E F U L S T U F F +;;====================================================================== + +(define (common:low-noise-print waitval . keys) + (let* ((key (string-intersperse (map conc keys) "-" )) + (lasttime (hash-table-ref/default *common:denoise* key 0)) + (currtime (current-seconds))) + (if (> (- currtime lasttime) waitval) + (begin + (hash-table-set! *common:denoise* key currtime) + #t) + #f))) + +(define (common:get-megatest-exe) + (if (getenv "MT_MEGATEST") (getenv "MT_MEGATEST") "megatest")) + +(define (common:read-encoded-string instr) + (handle-exceptions + exn + (read (open-input-string (base64:base64-decode instr))) + (read (open-input-string (z3:decode-buffer (base64:base64-decode instr)))))) + ;;====================================================================== ;; S T A T E S A N D S T A T U S E S ;;====================================================================== (define *common:std-states* @@ -200,20 +249,47 @@ (string-split patts ",")) res) #t)) ;; (map print (map car (hash-table->alist (read-config "runconfigs.config" #f #t)))) -(define (common:get-runconfig-targets) +(define (common:get-runconfig-targets #!key (configf #f)) (sort (map car (hash-table->alist - (read-config "runconfigs.config" - #f #t))) stringlist "uptime")) - (load-rx (regexp "load average:\\s+(\\d+)")) - (cpu-load #f)) - (for-each (lambda (l) - (let ((match (string-search load-rx l))) - (if match - (let ((newval (string->number (cadr match)))) - (if (number? newval) - (set! cpu-load newval)))))) - (car load-res)) - cpu-load)) + (car (common:get-cpu-load))) +;; (let* ((load-res (cmd-run->list "uptime")) +;; (load-rx (regexp "load average:\\s+(\\d+)")) +;; (cpu-load #f)) +;; (for-each (lambda (l) +;; (let ((match (string-search load-rx l))) +;; (if match +;; (let ((newval (string->number (cadr match)))) +;; (if (number? newval) +;; (set! cpu-load newval)))))) +;; (car load-res)) +;; cpu-load)) + +;; get cpu load by reading from /proc/loadavg, return all three values +;; +(define (common:get-cpu-load) + (with-input-from-file "/proc/loadavg" + (lambda ()(list (read)(read)(read))))) + +(define (common:wait-for-cpuload maxload numcpus waitdelay #!key (count 1000)) + (let* ((loadavg (common:get-cpu-load)) + (first (car loadavg)) + (next (cadr loadavg)) + (adjload (* maxload numcpus)) + (loadjmp (- first next))) + (cond + ((and (> first adjload) + (> count 0)) + (debug:print-info 0 "waiting " waitdelay " seconds due to load " first " exceeding max of " adjload) + (thread-sleep! waitdelay) + (common:wait-for-cpuload maxload numcpus waitdelay count: (- count 1))) + ((and (> loadjmp numcpus) + (> count 0)) + (debug:print-info 0 "waiting " waitdelay " seconds due to load jump " loadjmp " > numcpus " numcpus) + (thread-sleep! waitdelay) + (common:wait-for-cpuload maxload numcpus waitdelay count: (- count 1)))))) + +(define (common:get-num-cpus) + (with-input-from-file "/proc/cpuinfo" + (lambda () + (let loop ((numcpu 0) + (inl (read-line))) + (if (eof-object? inl) + numcpu + (loop (if (string-match "^processor\\s+:\\s+\\d+$" inl) + (+ numcpu 1) + numcpu) + (read-line))))))) (define (get-uname . params) (let* ((uname-res (cmd-run->list (conc "uname " (if (null? params) "-a" (car params))))) (uname #f)) (if (null? (car uname-res)) "unknown" (caar uname-res)))) -(define (save-environment-as-files fname #!key (ignorevars (list "DISPLAY" "LS_COLORS" "XKEYSYMDB" "EDITOR"))) +(define (save-environment-as-files fname #!key (ignorevars (list "USER" "HOME" "DISPLAY" "LS_COLORS" "XKEYSYMDB" "EDITOR" "MAKEFLAGS" "MAKEF"))) (let ((envvars (get-environment-variables)) - (whitesp (regexp "[^a-zA-Z0-9_\\-:;,.\\/%$]"))) + (whitesp (regexp "[^a-zA-Z0-9_\\-:,.\\/%$]"))) (with-output-to-file (conc fname ".csh") (lambda () - (for-each (lambda (key) - (if (not (member key ignorevars)) - (let* ((val (cdr key)) - (sval (if (string-search whitesp val)(conc "\"" val "\"") val))) - (print "setenv " (car key) " " sval)))) - envvars))) + (for-each (lambda (keyval) + (let* ((key (car keyval)) + (val (cdr keyval)) + (delim (if (string-search whitesp val) + "\"" + ""))) + (print (if (member key ignorevars) + "# setenv " + "setenv ") + key " " delim val delim))) + envvars))) (with-output-to-file (conc fname ".sh") (lambda () - (for-each (lambda (key) - (if (not (member key ignorevars)) - (let* ((val (cdr key)) - (sval (if (string-search whitesp val)(conc "\"" val "\"") val))) - (print "export " (car key) "=" sval)))) + (for-each (lambda (keyval) + (let* ((key (car keyval)) + (val (cdr keyval)) + (delim (if (string-search whitesp val) + "\"" + ""))) + (print (if (member key ignorevars) + "# export " + "export ") + key "=" delim val delim))) envvars))))) ;; set some env vars from an alist, return an alist with original values ;; (("VAR" "value") ...) (define (alist->env-vars lst) Index: common_records.scm ================================================================== --- common_records.scm +++ common_records.scm @@ -6,28 +6,33 @@ ;; ;; This program is distributed WITHOUT ANY WARRANTY; without even the ;; implied warranty of MERCHANTABILITY or FITNESS FOR A PARTICULAR ;; PURPOSE. ;;====================================================================== + +;; (use trace) (define (debug:calc-verbosity vstr) (cond - (vstr - (let ((debugvals (string-split vstr ","))) - (if (> (length debugvals) 1) - (map string->number debugvals) - (string->number (car debugvals))))) - ((args:get-arg "-v") 2) + ((number? vstr) vstr) + ((not (string? vstr)) 1) + ;; ((string-match "^\\s*$" vstr) 1) + (vstr (let ((debugvals (filter number? (map string->number (string-split vstr ","))))) + (cond + ((> (length debugvals) 1) debugvals) + ((> (length debugvals) 0)(car debugvals)) + (else 1)))) + ((args:get-arg "-v") 2) ((args:get-arg "-q") 0) (else 1))) ;; check verbosity, #t is ok (define (debug:check-verbosity verbosity vstr) (if (not (or (number? verbosity) (list? verbosity))) (begin - (print "ERROR: Invalid debug value " vstr) + (print "ERROR: Invalid debug value \"" vstr "\"") #f) #t)) (define (debug:debug-mode n) (or (and (number? *verbosity*) @@ -38,10 +43,12 @@ (define (debug:setup) (let ((debugstr (or (args:get-arg "-debug") (getenv "MT_DEBUG_MODE")))) (set! *verbosity* (debug:calc-verbosity debugstr)) (debug:check-verbosity *verbosity* debugstr) + ;; if we were handed a bad verbosity rule then we will override it with 1 and continue + (if (not *verbosity*)(set! *verbosity* 1)) (if (or (args:get-arg "-debug") (not (getenv "MT_DEBUG_MODE"))) (setenv "MT_DEBUG_MODE" (if (list? *verbosity*) (string-intersperse (map conc *verbosity*) ",") (conc *verbosity*)))))) @@ -51,10 +58,11 @@ (if (debug:debug-mode n) (with-output-to-port (current-error-port) (lambda () (if *logging* (db:log-event (apply conc params)) + ;; (apply print "pid:" (current-process-id) " " params) (apply print params) ))))) (define (debug:print-info n . params) (if (debug:debug-mode n) @@ -61,13 +69,14 @@ (with-output-to-port (current-error-port) (lambda () (let ((res (format#format #f "INFO: (~2d) ~a" n (apply conc params)))) (if *logging* (db:log-event res) + ;; (apply print "pid:" (current-process-id) " " "INFO: (" n ") " params) ;; res) (apply print "INFO: (" n ") " params) ;; res) )))))) ;; if a value is printable (i.e. string or number) return the value ;; else return an empty string (define-inline (printable val) (if (or (number? val)(string? val)) val "")) Index: configf.scm ================================================================== --- configf.scm +++ configf.scm @@ -105,16 +105,17 @@ "\n"))) (debug:print-info 4 "shell result:\n" outres) outres) (begin (with-output-to-port (current-error-port) - (print "ERROR: " cmd " returned bad exit code " status)) + (lambda () + (print "ERROR: " cmd " returned bad exit code " status))) "")))) ;; Lookup a value in runconfigs based on -reqtarg or -target (define (runconfigs-get config var) - (let ((targ (or (args:get-arg "-reqtarg")(args:get-arg "-target")))) + (let ((targ (or (args:get-arg "-reqtarg")(args:get-arg "-target")(getenv "MT_TARGET")))) (if targ (or (configf:lookup config targ var) (configf:lookup config "default" var)) (configf:lookup config "default" var)))) @@ -217,17 +218,11 @@ (envar (and environ-patt (string-search (regexp environ-patt) curr-section-name))) (realval (if envar (config:eval-string-in-environment val) val))) (debug:print-info 6 "read-config env setting, envar: " envar " realval: " realval " val: " val " key: " key " curr-section-name: " curr-section-name) - (if envar - (if (and envar - (string? realval) - (not (string-search (integer->char 0) realval))) - ;; (debug:print-info 4 "read-config key=" key ", val=" val ", realval=" realval) - (setenv key realval) - (debug:print 0 "ERROR: bad value for setenv, key=" key ", value=" realval))) + (if envar (safe-setenv key realval)) (hash-table-set! res curr-section-name (config:assoc-safe-add alist key realval)) (loop (configf:read-line inp res allow-system) curr-section-name key #f))) (configf:key-no-val ( x key val) (let* ((alist (hash-table-ref/default res curr-section-name '()))) (hash-table-set! res curr-section-name @@ -275,10 +270,11 @@ #f)) )) #f)) (define configf:lookup config-lookup) +(define configf:read-file read-config) (define (configf:section-vars cfgdat section) (let ((sectdat (hash-table-ref/default cfgdat section '()))) (if (null? sectdat) '() @@ -345,11 +341,11 @@ (res '())) (if (eof-object? inl) (begin (close-input-port inp) (reverse res)) - (loop (read-line inp)(cons inl))))) + (loop (read-line inp)(cons inl res))))) '())) ;;====================================================================== ;; Write a config ;; 0. Given a refererence data structure "indat" @@ -433,5 +429,58 @@ (for-each (lambda (line) (print line)) (configf:expand-multi-lines fdat)))))) +;;====================================================================== +;; refdb +;;====================================================================== + +;; reads a refdb into an assoc array of assoc arrays +;; returns (list dat msg) +(define (configf:read-refdb refdb-path) + (let ((sheets-file (conc refdb-path "/sheet-names.cfg"))) + (if (not (file-exists? sheets-file)) + (list #f (conc "ERROR: no refdb found at " refdb-path)) + (if (not (file-read-access? sheets-file)) + (list #f (conc "ERROR: refdb file not readable at " refdb-path)) + (let* ((sheets (with-input-from-file sheets-file + (lambda () + (let loop ((inl (read-line)) + (res '())) + (if (eof-object? inl) + (reverse res) + (loop (read-line)(cons inl res))))))) + (data '())) + (for-each + (lambda (sheet-name) + (let* ((dat-path (conc refdb-path "/" sheet-name ".dat")) + (ref-dat (configf:read-file dat-path #f #t)) + (ref-assoc (map (lambda (key) + (list key (hash-table-ref ref-dat key))) + (hash-table-keys ref-dat)))) + ;; (hash-table->alist ref-dat))) + (set! data (append data (list (list sheet-name ref-assoc)))))) + sheets) + (list data "NO ERRORS")))))) + +;; map over all pairs in a three level hierarchial alist and apply a function to the keys/val +;; +(define (configf:map-all-hier-alist data proc #!key (initproc1 #f)(initproc2 #f)(initproc3 #f)) + (for-each + (lambda (sheetname) + (let* ((sheettmp (assoc sheetname data)) + (sheetdat (if sheettmp (cadr sheettmp) '()))) + (if initproc1 (initproc1 sheetname)) + (for-each + (lambda (sectionname) + (let* ((sectiontmp (assoc sectionname sheetdat)) + (sectiondat (if sectiontmp (cadr sectiontmp) '()))) + (if initproc2 (initproc2 sheetname sectionname)) + (for-each + (lambda (varname) + (let* ((valtmp (assoc varname sectiondat)) + (val (if valtmp (cadr valtmp) ""))) + (proc sheetname sectionname varname val))) + (map car sectiondat)))) + (map car sheetdat)))) + (map car data))) Index: dashboard-tests.scm ================================================================== --- dashboard-tests.scm +++ dashboard-tests.scm @@ -24,15 +24,31 @@ (declare (unit dashboard-tests)) (declare (uses common)) (declare (uses db)) (declare (uses gutils)) +(declare (uses rmt)) (declare (uses ezsteps)) +;; (declare (uses sdb)) +;; (declare (uses filedb)) (include "common_records.scm") (include "db_records.scm") (include "run_records.scm") + +;;====================================================================== +;; C O M M O N +;;====================================================================== + +(define (dtests:get-pre-command #!key (default-override #f)) + (let ((cfg-ovrd (configf:lookup *configdat* "dashboard" "pre-command"))) + (or cfg-ovrd default-override "xterm -geometry 180x20 -e \""))) + +(define (dtests:get-post-command #!key (default-override #f)) + (let ((cfg-ovrd (configf:lookup *configdat* "dashboard" "post-command"))) + (or cfg-ovrd default-override ";echo Press any key to continue;bash -c 'read -n 1 -s'\" &"))) + (define (test-info-panel testdat store-label widgets) (iup:frame #:title "Test Info" ; #:expand "YES" (iup:hbox ; #:expand "YES" @@ -73,11 +89,18 @@ lbl) (store-label "testcomment" (iup:label "TestComment " #:expand "HORIZONTAL") (lambda (testdat) - (db:test-get-comment testdat))) + (let ((newcomment (db:test-get-comment testdat))) + (if *dashboard-comment-share-slot* + (if (not (equal? (iup:attribute *dashboard-comment-share-slot* "VALUE") + newcomment)) + (iup:attribute-set! *dashboard-comment-slot* + "VALUE" + newcomment))) + newcomment))) (store-label "testid" (iup:label "TestId " #:expand "HORIZONTAL") (lambda (testdat) (db:test-get-id testdat))) @@ -136,11 +159,11 @@ ;;====================================================================== (define (run-info-panel db keydat testdat runname) (let* ((run-id (db:test-get-run_id testdat)) (rundat (db:get-run-info db run-id)) (header (db:get-header rundat)) - (event_time (db:get-value-by-header (db:get-row rundat) + (event_time (db:get-value-by-header (db:get-rows rundat) (db:get-header rundat) "event_time"))) (iup:frame #:title "Megatest Run Info" ; #:expand "YES" (iup:hbox ; #:expand "YES" @@ -180,15 +203,18 @@ (iup:label "" #:expand "VERTICAL"))) (apply iup:vbox ; #:expand "YES" (list ;; NOTE: Yes, the host can change! (store-label "HostName" - (iup:label (db:test-get-host testdat) #:expand "HORIZONTAL") + (iup:label ;; (sdb:qry 'getstr + (db:test-get-host testdat) ;; ) + #:expand "HORIZONTAL") (lambda (testdat)(db:test-get-host testdat))) (store-label "Uname" (iup:label " " #:expand "HORIZONTAL") - (lambda (testdat)(db:test-get-uname testdat))) + (lambda (testdat) ;; (sdb:qry 'getstr + (db:test-get-uname testdat))) ;; ) (store-label "DiskFree" (iup:label (conc (db:test-get-diskfree testdat)) #:expand "HORIZONTAL") (lambda (testdat)(conc (db:test-get-diskfree testdat)))) (store-label "CPULoad" (iup:label (conc (db:test-get-cpuload testdat)) #:expand "HORIZONTAL") @@ -209,35 +235,41 @@ (color (car (gutils:get-color-for-state-status state status)))) ((vector-ref *state-status* 0) state color) ((vector-ref *state-status* 1) status color))) (define *dashboard-test-db* #t) +(define *dashboard-comment-share-slot* #f) ;;====================================================================== ;; Set fields ;;====================================================================== -(define (set-fields-panel db test-id testdat #!key (db #f)) +(define (set-fields-panel dbstruct run-id test-id testdat #!key (db #f)) (let ((newcomment #f) (newstatus #f) - (newstate #f)) + (newstate #f) + (wtxtbox #f)) (iup:frame #:title "Set fields" (iup:vbox (iup:hbox (iup:label "Comment:") - (iup:textbox #:action (lambda (val a b) - (db:test-set-state-status-by-id db test-id #f #f b) - ;; IDEA: Just set a variable with the proc to call? - (set! newcomment b)) - #:value (db:test-get-comment testdat) - #:expand "HORIZONTAL")) + (let ((txtbox (iup:textbox #:action (lambda (val a b) + (rmt:test-set-state-status-by-id run-id test-id #f #f b) + ;; IDEA: Just set a variable with the proc to call? + (rmt:test-set-state-status-by-id run-id test-id #f #f b) + (set! newcomment b)) + #:value (db:test-get-comment testdat) + #:expand "HORIZONTAL"))) + (set! wtxtbox txtbox) + txtbox)) + (apply iup:hbox (iup:label "STATE:" #:size "30x") (let* ((btns (map (lambda (state) (let ((btn (iup:button state #:expand "HORIZONTAL" #:size "50x" #:font "Courier New, -10" #:action (lambda (x) - (db:test-set-state-status-by-id db test-id state #f #f) + (rmt:test-set-state-status-by-id run-id test-id state #f #f) (db:test-set-state! testdat state))))) btn)) (map cadr *common:std-states*)))) ;; (list "COMPLETED" "NOT_STARTED" "RUNNING" "REMOTEHOSTSTART" "LAUNCHED" "KILLED" "KILLREQ")))) (vector-set! *state-status* 0 (lambda (state color) @@ -255,14 +287,22 @@ (let ((btn (iup:button status #:expand "HORIZONTAL" #:size "50x" #:font "Courier New, -10" #:action (lambda (x) (let ((t (iup:attribute x "TITLE"))) (if (equal? t "WAIVED") - (iup:show (dashboard-tests:waiver testdat (lambda (c) - (set! newcomment c)))) + (iup:show (dashboard-tests:waiver testdat + (if wtxtbox (iup:attribute wtxtbox "VALUE") #f) + (lambda (c) + (set! newcomment c) + (if wtxtbox + (begin + (iup:attribute-set! wtxtbox "VALUE" c) + (if (not *dashboard-comment-share-slot*) + (set! *dashboard-comment-share-slot* wtxtbox))) + )))) (begin - (open-run-close db:test-set-state-status-by-id db test-id #f status #f) + (rmt:test-set-state-status-by-id run-id test-id #f status #f) (db:test-set-status! testdat status)))))))) btn)) (map cadr *common:std-statuses*)))) ;; (list "PASS" "WARN" "FAIL" "CHECK" "n/a" "WAIVED" "SKIP")))) (vector-set! *state-status* 1 (lambda (status color) @@ -307,21 +347,21 @@ ;; #:expand "HORIZONTAL" ;; #:action (lambda (obj) ;; (print "Refresh test data " stepname)) ))) -(define (dashboard-tests:waiver testdat cmtcmd) +(define (dashboard-tests:waiver testdat ovrdval cmtcmd) (let* ((wpatt (configf:lookup *configdat* "setup" "waivercommentpatt")) (wregx (if (string? wpatt)(regexp wpatt) #f)) (wmesg (iup:label (if wpatt (conc "Comment must match pattern " wpatt) ""))) (comnt (iup:textbox #:action (lambda (val a b) (if wpatt (if (string-match wregx b) (iup:attribute-set! wmesg "TITLE" (conc "Comment matches " wpatt)) (iup:attribute-set! wmesg "TITLE" (conc "Comment does not match " wpatt)) ))) - #:value (db:test-get-comment testdat) + #:value (if ovrdval ovrdval (db:test-get-comment testdat)) #:expand "HORIZONTAL")) (dlog #f)) (set! dlog (iup:dialog ;; #:close_cb (lambda (a)(exit)) ; #:expand "YES" #:title "SET WAIVER" (iup:vbox ; #:expand "YES" @@ -339,11 +379,11 @@ (let ((comment (iup:attribute comnt "VALUE")) (test-id (db:test-get-id testdat))) (if (or (not wpatt) (string-match wregx comment)) (begin - (open-run-close db:test-set-state-status-by-id #f test-id #f "WAIVED" comment) + (rmt:test-set-state-status-by-id run-id test-id #f "WAIVED" comment) (db:test-set-status! testdat "WAIVED") (cmtcmd comment) (iup:destroy! dlog)))))) (iup:button "Cancel" #:expand "HORIZONTAL" @@ -411,12 +451,12 @@ ((eq? (tdb:step-get-event_time a)(tdb:step-get-event_time b)) (< (tdb:step-get-id a) (tdb:step-get-id b))) (else #f))))) res)) -(define (dashboard-tests:get-compressed-steps db test-id) - (let* ((steps-data (db:get-steps-for-test db test-id)) +(define (dashboard-tests:get-compressed-steps dbstruct run-id test-id) + (let* ((steps-data (db:get-steps-for-test dbstruct run-id test-id)) (comprsteps (dashboard-tests:process-steps-table steps-data))) ;; (open-run-close db:get-steps-table #f test-id work-area: work-area))) (map (lambda (x) ;; take advantage of the \n on time->string (vector (vector-ref x 0) @@ -441,38 +481,40 @@ (string rownum max-row)(set! max-row rownum)) @@ -762,11 +810,11 @@ (db:test-data-get-tol x) (db:test-data-get-status x) (db:test-data-get-units x) (db:test-data-get-type x) (db:test-data-get-comment x))) - (tdb:open-run-close-db-by-test-id-local test-id #f tdb:read-test-data test-id "%"))) + (tdb:open-run-close-db-by-test-id-local dbstruct run-id test-id #f tdb:read-test-data test-id "%"))) "\n"))) (if (not (equal? currval newval)) (iup:attribute-set! test-data "VALUE" newval ))))) ;; "TITLE" newval))))) test-data)) ;;(dashboard:run-controls) Index: dashboard.scm ================================================================== --- dashboard.scm +++ dashboard.scm @@ -16,11 +16,10 @@ (use canvas-draw) (import canvas-draw-iup) (use sqlite3 srfi-1 posix regex regex-case srfi-69) (import (prefix sqlite3 sqlite3:)) -(use trace) (declare (uses common)) (declare (uses margs)) (declare (uses keys)) (declare (uses items)) @@ -44,17 +43,17 @@ (include "megatest-fossil-hash.scm") (define help (conc "Megatest Dashboard, documentation at http://www.kiatoa.com/fossils/megatest version " megatest-version " - license GPL, Copyright (C) Matt Welland 2013 + license GPL, Copyright (C) Matt Welland 2012-2014 Usage: dashboard [options] - -h : this help - -server host:port : connect to host:port instead of db access - -test testid : control test identified by testid - -guimonitor : control panel for runs + -h : this help + -server host:port : connect to host:port instead of db access + -test run-id,test-id : control test identified by testid + -guimonitor : control panel for runs Misc -rows N : set number of rows ")) @@ -81,35 +80,27 @@ (if (args:get-arg "-h") (begin (print help) (exit))) -(if (not (setup-for-run)) +(if (not (launch:setup-for-run)) (begin (print "Failed to find megatest.config, exiting") (exit 1))) -(define *db* (open-db)) - -;; (if (args:get-arg "-host") -;; (begin -;; (set! *runremote* (string-split (args:get-arg "-host" ":"))) -;; (client:launch)) -;; (if (not (args:get-arg "-use-server")) -;; (set! *transport-type* 'fs) ;; force fs access -;; (client:launch))) +(define *dbdir* (conc (configf:lookup *configdat* "setup" "linktree") "/.db")) +(define *dbstruct-local* (make-dbr:dbstruct path: *dbdir* + local: #t)) +(define *db-file-path* (db:dbfile-path 0)) ;; HACK ALERT: this is a hack, please fix. -(define *read-only* (not (file-read-access? (conc *toppath* "/megatest.db")))) -;; (client:setup *db*) +(define *read-only* (not (file-read-access? *db-file-path*))) (define toplevel #f) (define dlg #f) (define max-test-num 0) -(define *keys* (db:get-keys *db*)) -;; (define *keys* (cdb:remote-run db:get-keys #f)) -;; (define *keys* (db:get-keys *db*)) +(define *keys* (db:get-keys *dbstruct-local*)) (define *dbkeys* (append *keys* (list "runname"))) (define *header* #f) (define *allruns* '()) @@ -118,12 +109,12 @@ (define *buttondat* (make-hash-table)) ;; (define *alltestnamelst* '()) (define *searchpatts* (make-hash-table)) (define *num-runs* 8) -(define *tot-run-count* (db:get-num-runs *db* "%")) -;; (define *tot-run-count* (db:get-num-runs *db* "%")) +(define *tot-run-count* (db:get-num-runs *dbstruct-local* "%")) +;; (define *tot-run-count* (db:get-num-runs *dbstruct-local* "%")) ;; Update management ;; (define *last-update* (current-seconds)) (define *last-db-update-time* 0) @@ -139,30 +130,41 @@ (define *examine-test-dat* (make-hash-table)) (define *exit-started* #f) (define *status-ignore-hash* (make-hash-table)) (define *state-ignore-hash* (make-hash-table)) -(define *db-file-path* (conc *toppath* "/megatest.db")) - (define *tests-sort-options* (vector (vector "Sort +a" 'testname "ASC") (vector "Sort -a" 'testname "DESC") (vector "Sort +t" 'event_time "ASC") (vector "Sort -t" 'event_time "DESC") (vector "Sort +s" 'statestatus "ASC") - (vector "Sort -s" 'statestatus "DESC"))) + (vector "Sort -s" 'statestatus "DESC") + (vector "Sort +a" 'testname "ASC"))) + +(define *tests-sort-type-index* '(("+testname" 0) + ("-testname" 1) + ("+event_time" 2) + ("-event_time" 3) + ("+statestatus" 4) + ("-statestatus" 5))) ;; Don't forget to adjust the >= below if you add to the sort-options above (define (next-sort-option) (if (>= *tests-sort-reverse* 5) (set! *tests-sort-reverse* 0) (set! *tests-sort-reverse* (+ *tests-sort-reverse* 1))) *tests-sort-reverse*) + +(define *tests-sort-reverse* + (let ((t-sort (assoc (configf:lookup *configdat* "dashboard" "testsort") *tests-sort-type-index*))) + (if t-sort + (cadr t-sort) + 3))) (define (get-curr-sort) (vector-ref *tests-sort-options* *tests-sort-reverse*)) -(define *tests-sort-reverse* 3) (define *hide-empty-runs* #f) (define *hide-not-hide* #t) ;; toggle for hide/not hide (define *hide-not-hide-button* #f) (define *hide-not-hide-tabs* #f) @@ -175,10 +177,12 @@ (define-inline (dboard:uidat-get-keycol vec)(vector-ref vec 0)) (define-inline (dboard:uidat-get-lftcol vec)(vector-ref vec 1)) (define-inline (dboard:uidat-get-header vec)(vector-ref vec 2)) (define-inline (dboard:uidat-get-runsvec vec)(vector-ref vec 3)) + +(if (get-environment-variable "MT_RUN_AREA_HOME")(change-directory (get-environment-variable "MT_RUN_AREA_HOME"))) (define (message-window msg) (iup:show (iup:dialog (iup:vbox @@ -205,11 +209,11 @@ (null? (filter (lambda (x)(> x 3)) delta)))) ;; keypatts: ( (KEY1 "abc%def")(KEY2 "%") ) (define (update-rundat runnamepatt numruns testnamepatt keypatts) (let* ((referenced-run-ids '()) - (allruns (db:get-runs *db* runnamepatt numruns ;; (+ numruns 1) ;; (/ numruns 2)) + (allruns (db:get-runs *dbstruct-local* runnamepatt numruns ;; (+ numruns 1) ;; (/ numruns 2)) *start-run-offset* keypatts)) (header (db:get-header allruns)) (runs (db:get-rows allruns)) (result '()) (maxtests 0) @@ -224,19 +228,19 @@ ;; ;; trim runs to only those that are changing often here ;; (for-each (lambda (run) (let* ((run-id (db:get-value-by-header run header "id")) - (tests (db:get-tests-for-run *db* run-id testnamepatt states statuses + (tests (db:get-tests-for-run *dbstruct-local* run-id testnamepatt states statuses #f #f *hide-not-hide* sort-by sort-order 'shortlist)) ;; NOTE: bubble-up also sets the global *all-item-test-names* ;; (tests (bubble-up tmptests priority: bubble-type)) - (key-vals (db:get-key-vals *db* run-id))) + (key-vals (db:get-key-vals *dbstruct-local* run-id))) ;; NOTE: 11/01/2013 This routine is *NOT* getting called excessively. ;; (debug:print 0 "Getting data for run " run-id " with key-vals=" key-vals) ;; Not sure this is needed? (set! referenced-run-ids (cons run-id referenced-run-ids)) (if (> (length tests) maxtests) @@ -344,13 +348,16 @@ (let ((tnames '())) (for-each (lambda (tdat) (let ((tname (vector-ref tdat 0)) ;; (db:test-get-testname tdat)) (ipath (vector-ref tdat 1))) ;; (db:test-get-item-path tdat))) (if (not (equal? ipath "")) - (if (not (member tname tnames)) + (if (and (list? tnames) + (string? tname) + (not (member tname tnames))) (set! tnames (append tnames (list tname))))))) - test-dats))) + test-dats) + tnames)) ;; Bubble up the top tests to above the items, collect the items underneath ;; all while preserving the sort order from the SQL query as best as possible. ;; (define (bubble-up test-dats #!key (priority 'itempath)) @@ -466,12 +473,18 @@ (itempath (db:test-get-item-path test)) (testfullname (test:test-get-fullname test)) (teststatus (db:test-get-status test)) (teststate (db:test-get-state test)) ;;(teststart (db:test-get-event_time test)) - (runtime (db:test-get-run_duration test)) - (buttontxt (if (equal? teststate "COMPLETED") teststatus teststate)) + ;;(runtime (db:test-get-run_duration test)) + (buttontxt (cond + ((equal? teststate "COMPLETED") teststatus) + ((and (equal? teststate "NOT_STARTED") + (member teststatus '("ZERO_ITEMS" "BLOCKED" "PREQ_FAIL" "PREQ_DISCARDED" "TIMED_OUT" "KEEP_TRYING" "TEN_STRIKES"))) + teststatus) + (else + teststate))) (button (vector-ref columndat rown)) (color (car (gutils:get-color-for-state-status teststate teststatus))) (curr-color (vector-ref buttondat 1)) ;; (iup:attribute button "BGCOLOR")) (curr-title (vector-ref buttondat 2))) ;; (iup:attribute button "TITLE"))) (if (not (equal? curr-color color)) @@ -559,11 +572,11 @@ (iup:attribute-set! lb "VALUE" newval) newval)))))) (define (dashboard:update-target-selector key-lbs #!key (action-proc #f)) (let* ((runconf-targs (common:get-runconfig-targets)) - (db-target-dat (db:get-targets *db*)) + (db-target-dat (db:get-targets *dbstruct-local*)) (header (vector-ref db-target-dat 0)) (db-targets (vector-ref db-target-dat 1)) (all-targets (append db-targets (map (lambda (x) (list->vector @@ -652,16 +665,16 @@ (set! full-cmd (conc full-cmd " -runtests " test-patt " -target " target - " :runname " + " -runname " run-name ))) ((remove-runs) (set! full-cmd (conc full-cmd - " -remove-runs :runname " + " -remove-runs -runname " run-name " -target " target " -testpatt " test-patt @@ -686,47 +699,14 @@ (hash-table-set! tests-draw-state 'scalef 8) (hash-table-set! tests-draw-state 'tests-info (make-hash-table)) (hash-table-set! tests-draw-state 'selected-tests (make-hash-table)) ;; set these (hash-table-set! tests-draw-state 'test-browse-xoffset 20) ;; (- 0 (* (/ sizex 2) (* 8 xadj)))) - (hash-table-set! tests-draw-state 'test-browse-yoffset 20))) ;; (- 0 (* (/ sizey 2) (* 8 (- 1 yadj))))))) - (let* ((scalef (hash-table-ref/default tests-draw-state 'scalef 8)) - (test-browse-xoffset (hash-table-ref tests-draw-state 'test-browse-xoffset)) - (test-browse-yoffset (hash-table-ref tests-draw-state 'test-browse-yoffset)) - (xtorig (+ test-browse-xoffset (* (/ sizex 2) scalef (- 0.5 xadj)))) ;; (- xadj 1)))) - (ytorig (+ test-browse-yoffset (* (/ sizey 2) scalef (- yadj 0.5)))) - (boxw 90) - (boxh 25) - (gapx 20) - (gapy 30) - (tests-hash (hash-table-ref tests-draw-state 'tests-info)) - (selected-tests (hash-table-ref tests-draw-state 'selected-tests ))) - ;; (print "sizex: " sizex " sizey: " sizey " font: " (canvas-font cnv) " originx: " originx " originy: " originy " xtorig: " xtorig " ytorig: " ytorig " xadj: " xadj " yadj: " yadj) - (let loop ((hed (car (reverse sorted-testnames))) - (tal (cdr (reverse sorted-testnames))) - (llx xtorig) - (lly ytorig) - (urx (+ xtorig boxw)) - (ury (+ ytorig boxh))) - ; (print "hed " hed " llx " llx " lly " lly " urx " urx " ury " ury) - (canvas-text! cnv (+ llx 5)(+ lly 5) hed) ;; (conc testname " (" xtorig "," ytorig ")")) - (canvas-rectangle! cnv llx urx lly ury) - (if (hash-table-ref/default selected-tests hed #f) - (canvas-box! cnv llx (+ llx 5) lly (+ lly 5))) - (hash-table-set! tests-hash hed (list llx urx (- sizey ury)(- sizey lly))) ;; NB// Swap ury and lly - (if (not (null? tal)) - ;; leave a column of space to the right to list items - (let ((have-room - (if #t ;; put "auto" here where some form of auto rearanging can be done - (> (* 3 (+ boxw gapx)) (- urx xtorig)) - (< urx (- sizex boxw gapx boxw))))) ;; is there room for another column? - (loop (car tal) - (cdr tal) - (if have-room (+ llx boxw gapx) xtorig) ;; have room, - (if have-room lly (+ lly boxh gapy)) - (if have-room (+ urx boxw gapx) (+ xtorig boxw)) - (if have-room ury (+ ury boxh gapy))))))))) + (hash-table-set! tests-draw-state 'test-browse-yoffset 20) ;; (- 0 (* (/ sizey 2) (* 8 (- 1 yadj))))))) + (dcommon:initial-draw-tests cnv xadj yadj sizex sizey sizexmm sizeymm originx originy tests-draw-state sorted-testnames)) + (dcommon:redraw-tests cnv xadj yadj sizex sizey sizexmm sizeymm originx originy tests-draw-state sorted-testnames)) + )) ;;====================================================================== ;; R U N C O N T R O L S ;;====================================================================== ;; @@ -809,11 +789,11 @@ (dboard:data-set-command! *data* default-cmd) lb))) (iup:frame #:title "Runname" - (let* ((default-run-name (conc "ww" (seconds->work-week/day (current-seconds)))) + (let* ((default-run-name (seconds->work-week/day (current-seconds))) (tb (iup:textbox #:expand "HORIZONTAL" #:action (lambda (obj val txt) ;; (print "obj: " obj " val: " val " unk: " unk) (dboard:data-set-run-name! *data* txt) ;; (iup:attribute obj "VALUE")) (dashboard:update-run-command)) @@ -824,11 +804,11 @@ (iup:attribute-set! tb "VALUE" val) (dboard:data-set-run-name! *data* val) (dashboard:update-run-command)))) (refresh-runs-list (lambda () (let* ((target (dboard:data-get-target-string *data*)) - (runs-for-targ (db:get-runs-by-patt *db* *keys* "%" target #f #f)) + (runs-for-targ (db:get-runs-by-patt *dbstruct-local* *keys* "%" target #f #f)) (runs-header (vector-ref runs-for-targ 0)) (runs-dat (vector-ref runs-for-targ 1)) (run-names (cons default-run-name (map (lambda (x) (db:get-value-by-header x runs-header "runname")) @@ -891,65 +871,76 @@ (iup:frame #:title "Tests and Tasks" (let* ((updater #f) (last-xadj 0) (last-yadj 0) - (canvas-obj - (iup:canvas #:action (make-canvas-action - (lambda (cnv xadj yadj) - (if (not updater) - (set! updater (lambda (xadj yadj) - ;; (print "cnv: " cnv " x: " x " y: " y) - (dashboard:draw-tests cnv xadj yadj tests-draw-state sorted-testnames)))) - (updater xadj yadj) - (set! last-xadj xadj) - (set! last-yadj yadj))) - ;; Following doesn't work - ;; #:wheel-cb (make-canvas-action - ;; (lambda (cnv xadj yadj) - ;; ;; (print "cnv: " cnv " x: " x " y: " y) - ;; (dashboard:draw-tests cnv xadj yadj tests-draw-state sorted-testnames))) - ;; #:size "50x50" - #:expand "YES" - #:scrollbar "YES" - #:posx "0.5" - #:posy "0.5" - #:button-cb (lambda (obj btn pressed x y status) - ;; (print "obj: " obj) - (let ((tests-info (hash-table-ref tests-draw-state 'tests-info)) - (selected-tests (hash-table-ref tests-draw-state 'selected-tests))) - ;; (print "x\ty\tllx\tlly\turx\tury") - (for-each (lambda (test-name) - (let* ((rec-coords (hash-table-ref tests-info test-name)) - (llx (list-ref rec-coords 0)) - (urx (list-ref rec-coords 1)) - (lly (list-ref rec-coords 2)) - (ury (list-ref rec-coords 3))) - ;; (print x "\t" y "\t" llx "\t" lly "\t" urx "\t" ury "\t" test-name " " - (if (and (eq? pressed 1) - (> x llx) - (> y lly) - (< x urx) - (< y ury)) - (let ((patterns (string-split (iup:attribute test-patterns-textbox "VALUE")))) - (let* ((selected (not (member test-name patterns))) - (newpatt-list (if selected - (cons test-name patterns) - (delete test-name patterns))) - (newpatt (string-intersperse newpatt-list "\n"))) - ;; (if cnv-obj - ;; (dashboard:draw-tests cnv-obj 0 0 tests-draw-state sorted-testnames)) - (iup:attribute-set! obj "REDRAW" "ALL") - (hash-table-set! selected-tests test-name selected) - (iup:attribute-set! test-patterns-textbox "VALUE" newpatt) - (dboard:data-set-test-patts! *data* (dboard:lines->test-patt newpatt)) - (dashboard:update-run-command) - (if updater (updater last-xadj last-yadj))))))) - (hash-table-keys tests-info))))))) + (the-cnv #f) + (canvas-obj + (iup:canvas #:action (make-canvas-action + (lambda (cnv xadj yadj) + (if (not updater) + (set! updater (lambda (xadj yadj) + ;; (print "cnv: " cnv " xadj: " xadj " yadj: " yadj) + (dashboard:draw-tests cnv xadj yadj tests-draw-state sorted-testnames) + (set! last-xadj xadj) + (set! last-yadj yadj)))) + (updater xadj yadj) + (set! the-cnv cnv) + )) + ;; Following doesn't work + #:wheel-cb (lambda (obj step x y dir) ;; dir is 4 for up and 5 for down. I think. + (let ((xadj last-xadj) + (yadj (+ last-yadj (if (> step 0) + -0.01 + 0.01)))) + ;; (print "step: " step " x: " x " y: " y " dir: \"" dir "\"") + ;; (print "the-cnv: " the-cnv " obj: " obj " xadj: " xadj " yadj: " yadj " dir: " dir) + (if the-cnv + (dashboard:draw-tests the-cnv xadj yadj tests-draw-state sorted-testnames)) + (set! last-xadj xadj) + (set! last-yadj yadj) + )) + ;; #:size "50x50" + #:expand "YES" + #:scrollbar "YES" + #:posx "0.5" + #:posy "0.5" + #:button-cb (lambda (obj btn pressed x y status) + ;; (print "obj: " obj) + (let ((tests-info (hash-table-ref tests-draw-state 'tests-info)) + (selected-tests (hash-table-ref tests-draw-state 'selected-tests))) + ;; (print "x\ty\tllx\tlly\turx\tury") + (for-each (lambda (test-name) + (let* ((rec-coords (hash-table-ref tests-info test-name)) + (llx (list-ref rec-coords 0)) + (urx (list-ref rec-coords 1)) + (lly (list-ref rec-coords 2)) + (ury (list-ref rec-coords 3))) + ;; (print x "\t" y "\t" llx "\t" lly "\t" urx "\t" ury "\t" test-name " " + (if (and (eq? pressed 1) + (> x llx) + (> y lly) + (< x urx) + (< y ury)) + (let ((patterns (string-split (iup:attribute test-patterns-textbox "VALUE")))) + (let* ((selected (not (member test-name patterns))) + (newpatt-list (if selected + (cons test-name patterns) + (delete test-name patterns))) + (newpatt (string-intersperse newpatt-list "\n"))) + ;; (if cnv-obj + ;; (dashboard:draw-tests cnv-obj 0 0 tests-draw-state sorted-testnames)) + (iup:attribute-set! obj "REDRAW" "ALL") + (hash-table-set! selected-tests test-name selected) + (iup:attribute-set! test-patterns-textbox "VALUE" newpatt) + (dboard:data-set-test-patts! *data* (dboard:lines->test-patt newpatt)) + (dashboard:update-run-command) + (if updater (updater last-xadj last-yadj))))))) + (hash-table-keys tests-info))))))) canvas-obj))) ;; (print "obj: " obj " btn: " btn " pressed: " pressed " x: " x " y: " y " status: " status)) - + (iup:frame #:title "Logs" ;; To be replaced with tabs (let ((logs-tb (iup:textbox #:expand "YES" #:multiline "YES"))) (dboard:data-set-logs-textbox! *data* logs-tb) @@ -988,17 +979,21 @@ ;; General info about the run(s) and megatest area (define (dashboard:summary db) (let ((rawconfig (read-config (conc *toppath* "/megatest.config") #f 'return-string))) (iup:vbox (iup:split - ;; #:value 500 + #:value 500 (iup:frame #:title "General Info" - (iup:hbox - (dcommon:keys-matrix rawconfig) - (dcommon:general-info) - )) + (iup:vbox + (iup:hbox + (iup:label "Area Path") + (iup:textbox #:value *toppath* #:expand "HORIZONTAL")) + (iup:hbox + (dcommon:keys-matrix rawconfig) + (dcommon:general-info) + ))) (iup:frame #:title "Server" (dcommon:servers-table))) (iup:frame #:title "Megatest config settings" @@ -1042,12 +1037,20 @@ (begin (dboard:data-set-curr-run-id! *data* run-id) (dashboard:update-run-summary-tab))) ;; (print "path: " (tree:node->path obj id) " run-id: " run-id) )))) + (cell-lookup (make-hash-table)) (run-matrix (iup:matrix - #:expand "YES")) + #:expand "YES" + #:click-cb + (lambda (obj lin col status) + (let* ((toolpath (car (argv))) + (key (conc lin ":" col)) + (test-id (hash-table-ref/default cell-lookup key -1)) + (cmd (conc toolpath " -test " test-id "&"))) + (system cmd))))) (updater (lambda () (let* ((runs-dat (db:get-runs-by-patt db *keys* "%" #f #f #f)) (runs-header (vector-ref runs-dat 0)) ;; 0 is header, 1 is list of records (run-id (dboard:data-get-curr-run-id *data*)) (tests-dat (let ((tdat (db:get-tests-for-run db run-id @@ -1111,12 +1114,13 @@ userdata: (conc "run-id: " run-id)) (hash-table-set! (dboard:data-get-path-run-ids *data*) run-path run-id) ;; (set! colnum (+ colnum 1)) )))) run-ids) - (iup:attribute-set! run-matrix "CLEARVALUE" "CONTENTS") + (iup:attribute-set! run-matrix "CLEARVALUE" "ALL") ;; NOTE: Was CONTENTS (iup:attribute-set! run-matrix "CLEARATTRIB" "CONTENTS") + (iup:attribute-set! run-matrix "RESIZEMATRIX" "YES") (iup:attribute-set! run-matrix "NUMCOL" max-col ) (iup:attribute-set! run-matrix "NUMLIN" (if (< max-row max-visible) max-visible max-row)) ;; min of 20 ;; (iup:attribute-set! run-matrix "NUMCOL_VISIBLE" max-col) ;; (iup:attribute-set! run-matrix "NUMLIN_VISIBLE" (if (> max-row max-visible) max-visible max-row)) @@ -1129,22 +1133,10 @@ (begin (set! changed #t) (iup:attribute-set! run-matrix key name))))) row-indices) - ;; Col labels - (for-each (lambda (ind) - (let* ((name (car ind)) - (num (cadr ind)) - (key (conc "0:" num))) - (if (not (equal? (iup:attribute run-matrix key) name)) - (begin - (set! changed #t) - (iup:attribute-set! run-matrix key name) - (iup:attribute-set! run-matrix "FITTOTEXT" (conc "C" num)))))) - col-indices) - ;; Cell contents (for-each (lambda (entry) (let* ((row-name (cadr entry)) (col-name (car entry)) (valuedat (caddr entry)) @@ -1155,17 +1147,32 @@ (status (list-ref valuedat 2)) (value (gutils:get-color-for-state-status state status)) (row-num (cadr (assoc row-name row-indices))) (col-num (cadr (assoc col-name col-indices))) (key (conc row-num ":" col-num))) + (hash-table-set! cell-lookup key test-id) (if (not (equal? (iup:attribute run-matrix key) (cadr value))) (begin (set! changed #t) (iup:attribute-set! run-matrix key (cadr value)) (iup:attribute-set! run-matrix (conc "BGCOLOR" key) (car value)))))) tests-mindat) + + ;; Col labels - do after setting Cell contents so they are accounted for in the size calc. + + (for-each (lambda (ind) + (let* ((name (car ind)) + (num (cadr ind)) + (key (conc "0:" num))) + (if (not (equal? (iup:attribute run-matrix key) name)) + (begin + (set! changed #t) + (iup:attribute-set! run-matrix key name) + (iup:attribute-set! run-matrix "FITTOTEXT" (conc "C" num)))))) + col-indices) (if changed (iup:attribute-set! run-matrix "REDRAW" "ALL")))))) + (set! dashboard:update-run-summary-tab updater) (dboard:data-set-runs-tree! *data* tb) (iup:split tb run-matrix))) @@ -1202,14 +1209,25 @@ ;; (mark-for-update) ;; (update-search "item-name" val)) )) (iup:vbox (iup:hbox - (iup:button "Sort -t" #:action (lambda (obj) - (next-sort-option) - (iup:attribute-set! obj "TITLE" (vector-ref (vector-ref *tests-sort-options* *tests-sort-reverse*) 0)) - (mark-for-update))) + (let* ((cmds-list '("+testname" "-testname" "+event_time" "-event_time" "+statestatus" "-statestatus")) + (lb (iup:listbox #:expand "HORIZONTAL" + #:dropdown "YES" + #:action (lambda (obj val index lbstate) + (set! *tests-sort-reverse* index) + (mark-for-update)))) + (default-cmd (car (list-ref *tests-sort-type-index* *tests-sort-reverse*)))) + (iuplistbox-fill-list lb cmds-list selected-item: default-cmd) + (mark-for-update) + ;; (set! *tests-sort-reverse* *tests-sort-reverse*0) + lb) + ;; (iup:button "Sort -t" #:action (lambda (obj) + ;; (next-sort-option) + ;; (iup:attribute-set! obj "TITLE" (vector-ref (vector-ref *tests-sort-options* *tests-sort-reverse*) 0)) + ;; (mark-for-update))) (iup:button "HideEmpty" #:action (lambda (obj) (set! *hide-empty-runs* (not *hide-empty-runs*)) (iup:attribute-set! obj "TITLE" (if *hide-empty-runs* "+HideE" "-HideE")) (mark-for-update))) (let ((hideit (iup:button "HideTests" #:action (lambda (obj) @@ -1217,11 +1235,11 @@ (iup:attribute-set! obj "TITLE" (if *hide-not-hide* "HideTests" "NotHide")) (mark-for-update))))) (set! *hide-not-hide-button* hideit) hideit)) (iup:hbox - (iup:button "Quit" #:action (lambda (obj)(if *db* (sqlite3:finalize! *db*))(exit))) + (iup:button "Quit" #:action (lambda (obj)(if *dbstruct-local* (db:close-all *dbstruct-local*))(exit))) (iup:button "Refresh" #:action (lambda (obj) (mark-for-update))) (iup:button "Collapse" #:action (lambda (obj) (let ((myname (iup:attribute obj "TITLE"))) (if (equal? myname "Collapse") @@ -1359,11 +1377,12 @@ #:fontsize "10" #:action (lambda (x) (let* ((toolpath (car (argv))) (buttndat (hash-table-ref *buttondat* button-key)) (test-id (db:test-get-id (vector-ref buttndat 3))) - (cmd (conc toolpath " -test " test-id "&"))) + (run-id (db:test-get-run_id (vector-ref buttndat 3))) + (cmd (conc toolpath " -test " run-id "," test-id "&"))) ;(print "Launching " cmd) (system cmd)))))) (hash-table-set! *buttondat* button-key (vector 0 "100 100 100" button-key #f #f)) (vector-set! testvec testnum butn) (loop runnum (+ testnum 1) testvec (cons butn res)))))) @@ -1413,35 +1432,42 @@ (iup:attribute-set! *tim* "TIME" 300) (iup:attribute-set! *tim* "RUN" "YES") ;; Move this stuff to db.scm? I'm not sure that is the right thing to do... ;; -(define *last-db-update-time* (file-modification-time (conc *toppath* "/megatest.db"))) +(define *last-db-update-time* (file-modification-time *db-file-path*)) ;; (conc *toppath* "/db/main.db"))) (define *last-recalc-ended-time* 0) (define (dashboard:been-changed) - (> (file-modification-time (conc *toppath* "/megatest.db")) *last-db-update-time*)) + (> (file-modification-time *db-file-path*) *last-db-update-time*)) (define (dashboard:set-db-update-time) - (set! *last-db-update-time* (file-modification-time (conc *toppath* "/megatest.db")))) + (set! *last-db-update-time* (file-modification-time *db-file-path*))) (define (dashboard:recalc modtime please-update-buttons last-db-update-time) (or please-update-buttons (and (> (current-milliseconds)(+ *last-recalc-ended-time* 150)) (> modtime last-db-update-time) (> (current-seconds)(+ last-db-update-time 1))))) -(define *monitor-db-path* (conc *toppath* "/db/monitor.db")) +(define *monitor-db-path* (conc *dbdir* "/monitor.db")) (define *last-monitor-update-time* 0) ;; Force creation of the db in case it isn't already there. (let ((db (tasks:open-db))) (sqlite3:finalize! db)) +(define (dashboard:get-youngest-run-db-mod-time) + (apply max (map (lambda (filen) + (file-modification-time filen)) + (glob (conc *dbdir* "/*.db"))))) + (define (dashboard:run-update x) - (let* ((modtime (file-modification-time *db-file-path*)) - (monitor-modtime (file-modification-time *monitor-db-path*)) + (let* ((modtime (dashboard:get-youngest-run-db-mod-time)) ;; (file-modification-time *db-file-path*)) + (monitor-modtime (if (file-exists? *monitor-db-path*) + (file-modification-time *monitor-db-path*) + -1)) (run-update-time (current-seconds)) (recalc (dashboard:recalc modtime *please-update-buttons* *last-db-update-time*))) (if (and (eq? *current-tab-number* 0) (> monitor-modtime *last-monitor-update-time*)) (begin @@ -1488,27 +1514,30 @@ (let ((runid (string->number (args:get-arg "-run")))) (if runid (begin (lambda (x) (on-exit (lambda () - (if *db* (sqlite3:finalize! *db*)))) - (examine-run *db* runid))) + (if *dbstruct-local* (db:close-all *dbstruct-local*)))) + (examine-run *dbstruct-local* runid))) (begin (print "ERROR: runid is not a number " (args:get-arg "-run")) (exit 1))))) - ((args:get-arg "-test") - (let ((testid (string->number (args:get-arg "-test")))) - (if (and (number? testid) - (>= testid 0)) - (examine-test testid) + ((args:get-arg "-test") ;; run-id,test-id + (let* ((dat (map string->number (string-split (args:get-arg "-test") ","))) + (run-id (car dat)) + (test-id (cadr dat))) + (if (and (number? run-id) + (number? test-id) + (>= test-id 0)) + (examine-test run-id test-id) (begin - (debug:print 3 "INFO: tried to open test with invalid test-id. " (args:get-arg "-test")) + (debug:print 3 "INFO: tried to open test with invalid run-id,test-id. " (args:get-arg "-test")) (exit 1))))) ((args:get-arg "-guimonitor") - (gui-monitor *db*)) + (gui-monitor *dbstruct-local*)) (else - (set! uidat (make-dashboard-buttons *db* *num-runs* *num-tests* *dbkeys*)) + (set! uidat (make-dashboard-buttons *dbstruct-local* *num-runs* *num-tests* *dbkeys*)) (iup:callback-set! *tim* "ACTION_CB" (lambda (x) (let ((update-is-running #f)) (mutex-lock! *update-mutex*) @@ -1522,7 +1551,27 @@ (mutex-lock! *update-mutex*) (set! *update-is-running* #f) (mutex-unlock! *update-mutex*)))) 1)))) -(iup:main-loop) -(sqlite3:finalize! *db*) +(let ((th1 (make-thread (lambda () + (thread-sleep! 1) + (set! *please-update-buttons* #t) + (dashboard:run-update 1)) "update buttons once")) + ;; need to wait for first *update-is-running* #t + ;; (let loop () + ;; (mutex-lock! *update-mutex*) + ;; (if *update-is-running* + ;; (begin + ;; (set! *please-update-buttons* #t) + ;; (mark-for-update) + ;; (print "Did redraw trigger")) "First update after startup") + ;; (mutex-unlock! *update-mutex*) + ;; (thread-sleep! 1) + ;; (if (not *please-update-buttons*) + ;; (loop)))))) + (th2 (make-thread iup:main-loop "Main loop"))) + (thread-start! th1) + (thread-start! th2) + (thread-join! th2)) + +;; (iup:main-loop)(db:close-all *dbstruct-local*) ADDED datashare-testing/.sd.config Index: datashare-testing/.sd.config ================================================================== --- /dev/null +++ datashare-testing/.sd.config @@ -0,0 +1,35 @@ +# Read in the users vars first (so the offical data cannot be overridden +[include ~/.datashare.config] + +# Read in local overrides +[include datashare.config] + +# Replace [storage] with settings entry - more secure +[settings] + +storage /tmp/#{getenv USER}/datashare/disk1 \ + /tmp/#{getenv USER}/datashare/disk2 + +basepath #{getenv BASEPATH} + +[areas] +synthesis asic/synthesis +verilog asic/verilog +customlibs custom/oalibs +megatest tools/megatest + +[quality] +0 untested +1 lightly tested +2 tested +3 full QA + +[database] +location /tmp/#{getenv USER}/datashare + +[pathmaps] +SHELF /tmp/#{getenv USER}/theshelf + +[buildmethods] +customlibs make setup;make install + ADDED datashare.scm Index: datashare.scm ================================================================== --- /dev/null +++ datashare.scm @@ -0,0 +1,817 @@ + +;; Copyright 2006-2013, Matthew Welland. +;; +;; This program is made available under the GNU GPL version 2.0 or +;; greater. See the accompanying file COPYING for details. +;; +;; This program is distributed WITHOUT ANY WARRANTY; without even the +;; implied warranty of MERCHANTABILITY or FITNESS FOR A PARTICULAR +;; PURPOSE. + +(use ssax) +(use sxml-serializer) +(use sxml-modifications) +(use regex) +(use srfi-69) +(use regex-case) +(use posix) +(use json) +(use csv) +(use srfi-18) +(use format) + +(require-library iup) +(import (prefix iup iup:)) +(require-library ini-file) +(import (prefix ini-file ini:)) + +(use canvas-draw) +(import canvas-draw-iup) + +(use sqlite3 srfi-1 posix regex regex-case srfi-69) +(import (prefix sqlite3 sqlite3:)) + +(declare (uses configf)) +(declare (uses tree)) +(declare (uses margs)) +;; (declare (uses dcommon)) +;; (declare (uses launch)) +;; (declare (uses gutils)) +;; (declare (uses db)) +;; (declare (uses synchash)) +;; (declare (uses server)) +;; (declare (uses megatest-version)) +;; (declare (uses tbd)) + +(include "megatest-fossil-hash.scm") + +;; +;; GLOBALS +;; +(define *datashare:current-tab-number* 0) +(define *args-hash* (make-hash-table)) +(define datashare:help (conc "Usage: datashare [action [params ...]] + +Note: run datashare without parameters to start the gui. + + list-areas : List the allowed areas + + list-versions : List versions available in + options : -full, -vpatt patt + + publish : Publish data for area and with version + + get : Get a link to data, put the link in destpath + options : -i iteration + + update : Update the link to data to the latest iteration. + +Part of the Megatest tool suite. +Learn more at http://www.kiatoa.com/fossils/megatest + +Version: " megatest-fossil-hash)) ;; " + +;;====================================================================== +;; RECORDS +;;====================================================================== + +;; make-vector-record "testing" datastore pkg id area version_name store_type copied source_path iteration submitter datetime storegrp datavol quality disk_id comment +;; testing +(define (make-datashare:pkg)(make-vector 15)) +(define-inline (datashare:pkg-get-id vec) (vector-ref vec 0)) +(define-inline (datashare:pkg-get-area vec) (vector-ref vec 1)) +(define-inline (datashare:pkg-get-version_name vec) (vector-ref vec 2)) +(define-inline (datashare:pkg-get-store_type vec) (vector-ref vec 3)) +(define-inline (datashare:pkg-get-copied vec) (vector-ref vec 4)) +(define-inline (datashare:pkg-get-source_path vec) (vector-ref vec 5)) +(define-inline (datashare:pkg-get-iteration vec) (vector-ref vec 6)) +(define-inline (datashare:pkg-get-submitter vec) (vector-ref vec 7)) +(define-inline (datashare:pkg-get-datetime vec) (vector-ref vec 8)) +(define-inline (datashare:pkg-get-storegrp vec) (vector-ref vec 9)) +(define-inline (datashare:pkg-get-datavol vec) (vector-ref vec 10)) +(define-inline (datashare:pkg-get-quality vec) (vector-ref vec 11)) +(define-inline (datashare:pkg-get-disk_id vec) (vector-ref vec 12)) +(define-inline (datashare:pkg-get-comment vec) (vector-ref vec 13)) +(define-inline (datashare:pkg-get-stored_path vec) (vector-ref vec 14)) +(define-inline (datashare:pkg-set-id! vec val)(vector-set! vec 0 val)) +(define-inline (datashare:pkg-set-area! vec val)(vector-set! vec 1 val)) +(define-inline (datashare:pkg-set-version_name! vec val)(vector-set! vec 2 val)) +(define-inline (datashare:pkg-set-store_type! vec val)(vector-set! vec 3 val)) +(define-inline (datashare:pkg-set-copied! vec val)(vector-set! vec 4 val)) +(define-inline (datashare:pkg-set-source_path! vec val)(vector-set! vec 5 val)) +(define-inline (datashare:pkg-set-iteration! vec val)(vector-set! vec 6 val)) +(define-inline (datashare:pkg-set-submitter! vec val)(vector-set! vec 7 val)) +(define-inline (datashare:pkg-set-datetime! vec val)(vector-set! vec 8 val)) +(define-inline (datashare:pkg-set-storegrp! vec val)(vector-set! vec 9 val)) +(define-inline (datashare:pkg-set-datavol! vec val)(vector-set! vec 10 val)) +(define-inline (datashare:pkg-set-quality! vec val)(vector-set! vec 11 val)) +(define-inline (datashare:pkg-set-disk_id! vec val)(vector-set! vec 12 val)) +(define-inline (datashare:pkg-set-comment! vec val)(vector-set! vec 13 val)) +(define-inline (datashare:pkg-set-stored_path! vec val)(vector-set! vec 14 val)) + +;;====================================================================== +;; DB +;;====================================================================== + +(define (datashare:initialize-db db) + (for-each + (lambda (qry) + (sqlite3:execute db qry)) + (list + "CREATE TABLE pkgs + (id INTEGER PRIMARY KEY, + area TEXT, + version_name TEXT, + store_type TEXT DEFAULT 'copy', + copied INTEGER DEFAULT 0, + source_path TEXT, + stored_path TEXT, + iteration INTEGER DEFAULT 0, + submitter TEXT, + datetime TIMESTAMP DEFAULT (strftime('%s','now')), + storegrp TEXT, + datavol INTEGER, + quality TEXT, + disk_id INTEGER, + comment TEXT);" + "CREATE TABLE refs + (id INTEGER PRIMARY KEY, + pkg_id INTEGER, + destlink TEXT);" + "CREATE TABLE disks + (id INTEGER PRIMARY KEY, + storegrp TEXT, + path TEXT);"))) + +(define (datashare:register-data db area version-name store-type submitter quality source-path comment) + (let ((iter-qry (sqlite3:prepare db "SELECT max(iteration) FROM pkgs WHERE area=? AND version_name=?;")) + (next-iteration 0)) + (sqlite3:with-transaction + db + (lambda () + (sqlite3:for-each-row + (lambda (iteration) + (if (and (number? iteration) + (>= iteration next-iteration)) + (set! next-iteration (+ iteration 1)))) + iter-qry area version-name) + ;; now store the data + (sqlite3:execute db "INSERT INTO pkgs (area,version_name,iteration,store_type,submitter,source_path,quality,comment) + VALUES (?,?,?,?,?,?,?,?);" + area version-name next-iteration (conc store-type) submitter source-path quality comment))) + (sqlite3:finalize! iter-qry) + next-iteration)) + +(define (datashare:get-id db area version-name iteration) + (let ((res #f)) + (sqlite3:for-each-row + (lambda (id) + (set! res id)) + db + "SELECT id FROM pkgs WHERE area=? AND version_name=? AND iteration=?;" + area version-name iteration) + res)) + +(define (datashare:set-stored-path db id path) + (sqlite3:execute db "UPDATE pkgs SET stored_path=? WHERE id=?;" path id)) + +(define (datashare:set-copied db id value) + (sqlite3:execute db "UPDATE pkgs SET copied=? WHERE id=?;" value id)) + +(define (datashare:get-pkg-record db area version-name iteration) + (let ((res #f)) + (sqlite3:for-each-row + (lambda (a . b) + (set! res (apply vector a b))) + db + "SELECT * FROM pkgs WHERE area=? AND version_name=? AND iteration=?;" + area + version-name + iteration) + res)) + +;; take version-name iteration and register or update "lastest/0" +;; +(define (datashare:set-latest db id area version-name iteration) + (let* ((rec (datashare:get-pkg-record db area version-name iteration)) + (latest-id (datashare:get-id db area "latest" 0)) + (stored-path (datashare:pkg-get-stored_path rec))) + (if latest-id ;; have a record - bump the link pointer + (datashare:set-stored-path db latest-id stored-path) + (datashare:register-data db area "latest" 'link "auto" "na" stored-path "latest data")))) + +;; set a package ref, this is the location where the link back to the stored data +;; is put. +;; +;; if there is nothing at that location then the record can be removed +;; if there are no refs for a particular pkg-id then that pkg-id is a +;; candidate for removal +;; +(define (datashare:record-pkg-ref db pkg-id dest-link) + (sqlite3:execute db "INSERT INTO refs (pkg_id,destlink) VALUES (?,?);" pkg-id dest-link)) + +(define (datashare:count-refs db pkg-id) + (let ((res 0)) + (sqlite3:for-each-row + (lambda (count) + (set! res count)) + db + "SELECT count(id) FROM refs WHERE pkg_id=?;" + pkg-id) + res)) + +;; Create the sqlite db +(define (datashare:open-db configdat) + (let ((path (configf:lookup configdat "database" "location"))) + (if (and path + (directory? path) + (file-read-access? path)) + (let* ((dbpath (conc path "/datashare.db")) + (writeable (file-write-access? dbpath)) + (dbexists (file-exists? dbpath)) + (handler (make-busy-timeout 136000))) + (handle-exceptions + exn + (begin + (debug:print 2 "ERROR: problem accessing db " dbpath + ((condition-property-accessor 'exn 'message) exn)) + (exit)) + (set! db (sqlite3:open-database dbpath))) + (if *db-write-access* (sqlite3:set-busy-handler! db handler)) + (if (not dbexists) + (begin + (datashare:initialize-db db))) + db) + (print "ERROR: invalid path for storing database: " path)))) + +(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 + (print "EXCEPTION: database overloaded or unreadable.") + (print " message: " ((condition-property-accessor 'exn 'message) exn)) + (print "exn=" (condition->list exn)) + (print " status: " ((condition-property-accessor 'sqlite3 'status) exn)) + (print-call-chain) + (thread-sleep! sleep-time) + (print "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-no-exception-handling proc idb . params) + ;; (print "open-run-close-no-exception-handling START given a db=" (if idb "yes " "no ") ", params=" params) + (let* ((db (cond + ((sqlite3:database? idb) idb) + ((not idb) (print "ERROR: cannot open-run-close with #f anymore")) + ((procedure? idb) (idb)) + (else (print "ERROR: cannot open-run-close with #f anymore")))) + (res #f)) + (set! res (apply proc db params)) + (if (not idb)(sqlite3:finalize! dbstruct)) + ;; (print "open-run-close-no-exception-handling END" ) + res)) + +(define open-run-close open-run-close-no-exception-handling) + +(define (datashare:get-pkgs db area-filter version-filter iter-filter) + (let ((res '())) + (sqlite3:for-each-row ;; replace with fold ... + (lambda (a . b) + (set! res (cons (list->vector (cons a b)) res))) + db + (conc "SELECT id,area,version_name,store_type,copied,source_path,iteration,submitter,datetime,storegrp,datavol,quality,disk_id,comment,stored_path " + " FROM pkgs WHERE area like ? AND version_name LIKE ? AND iteration " iter-filter ";") + area-filter version-filter) + (reverse res))) + +(define (datashare:get-pkg db area-name version-name #!key (iteration #f)) + (let ((dat '()) + (res #f)) + (sqlite3:for-each-row ;; replace with fold ... + (lambda (a . b) + (set! dat (cons (list->vector (cons a b)) dat))) + db + (conc "SELECT id,area,version_name,store_type,copied,source_path,iteration,submitter,datetime,storegrp,datavol,quality,disk_id,comment,stored_path " + " FROM pkgs WHERE area=? AND version_name=? ORDER BY iteration ASC;") + area-name version-name) + ;; now filter for iteration, either max if #f or specific one + (if (null? dat) + #f + (let loop ((hed (car dat)) + (tal (cdr dat)) + (cur 0)) + (let ((itr (datashare:pkg-get-iteration hed))) + (if (equal? itr iteration) ;; this is the one if iteration is specified + hed + (if (null? tal) + hed + (loop (car tal)(cdr tal))))))))) + +(define (datashare:get-versions-for-area db area-name #!key (version-patt #f)) + (let ((res '()) + (data (make-hash-table))) + (sqlite3:for-each-row + (lambda (version-name submitter iteration submitted-time comment) + ;; 0 1 2 3 4 + (hash-table-set! data version-name (vector version-name submitter iteration submitted-time comment))) + db + "SELECT version_name,submitter,iteration,datetime,comment FROM pkgs WHERE area='megatest' AND version_name != 'latest' AND version_name LIKE ? ORDER BY datetime asc;" + (or version-patt "%")) + (map (lambda (x)(hash-table-ref data x))(sort (hash-table-keys data) string-ci>=)))) + +;;====================================================================== +;; DATA IMPORT/EXPORT +;;====================================================================== + +(define (datashare:import-data configdat source-path dest-path area version iteration) + (let* ((space-avail (car dest-path)) + (disk-path (cdr dest-path)) + (targ-path (conc disk-path "/" area "/" version "/" iteration)) + (id (datashare:get-id db area version iteration)) + (db (datashare:open-db configdat))) + (if (> space-avail 10000) ;; dumb heuristic + (begin + (create-directory targ-path #t) + (datashare:set-stored-path db id targ-path) + (print "Running command: rsync -av " source-path "/ " targ-path "/") + (let ((th1 (make-thread (lambda () + (let ((pid (process-run "rsync" (list "-av" (conc source-path "/") (conc targ-path "/"))))) + (process-wait pid) + (datashare:set-copied db id "yes") + (sqlite3:finalize! db))) + "Data copy"))) + (thread-start! th1)) + #t) + (begin + (print "ERROR: Not enough space in storage area " dest-path) + (datashare:set-copied db id "no") + (sqlite3:finalize! db) + #f)))) + +(define (datashare:get-areas configdat) + (let* ((areadat (configf:get-section configdat "areas")) + (areas (if areadat (map car areadat) '()))) + areas)) + +(define (datashare:publish configdat publish-type area-name version comment spath submitter quality) + ;; input checks + (cond + ((not (member area-name (datashare:get-areas configdat))) + (cons #f (conc "Illegal area name \"" area-name "\""))) + (else + (let ((db (datashare:open-db configdat)) + (iteration (datashare:register-data db area-name version publish-type submitter quality spath comment)) + (dest-store (datashare:get-best-storage configdat))) + (if iteration + (if (eq? 'copy publish-type) + (begin + (datashare:import-data configdat spath dest-store area-name version iteration) + (let ((id (datashare:get-id db area-name version iteration))) + (datashare:set-latest db id area-name version iteration))) + (let ((id (datashare:get-id db area-name version iteration))) + (datashare:set-stored-path db id spath) + (datashare:set-copied db id "yes") + (datashare:set-copied db id "n/a") + (datashare:set-latest db id area-name version iteration))) + (print "ERROR: Failed to get an iteration number")) + (sqlite3:finalize! db) + (cons #t "Successfully saved data"))))) + +(define (datashare:get-best-storage configdat) + (let* ((storage (configf:lookup configdat "settings" "storage")) + (store-areas (if storage (string-split storage) '()))) + (print "Looking for available space in " store-areas) + (datashare:find-most-space store-areas))) + +;; (string->number (list-ref (with-input-from-pipe "df -B1000000 /tmp" (lambda ()(read-line)(string-split (read-line)))) 3)) + +(define (datashare:find-most-space paths) + (fold (lambda (area res) + ;; (print "area=" area " res=" res) + (let ((maxspace (car res)) + (currpath (cdr res))) + ;; (print currpath " " maxspace) + (if (file-write-access? area) + (let ((currspace (string->number + (list-ref + (with-input-from-pipe + ;; (conc "df --output=avail " area) + (conc "df -B1000000 " area) + ;; (lambda ()(read)(read)) + (lambda ()(read-line)(string-split (read-line)))) + 3)))) + (if (> currspace maxspace) + (cons currspace area) + res)) + res))) + (cons 0 #f) + paths)) + +;; remove existing link and if possible ... +;; create path to next of tip of target, create link back to source +(define (datashare:build-dir-make-link source target) + (if (file-exists? target)(datashare:backup-move target)) + (create-directory (pathname-directory target) #t) + (create-symbolic-link source target)) + +(define (datashare:backup-move path) + (let* ((trashdir (conc (pathname-directory path) "/.trash")) + (trashfile (conc trashdir "/" (current-seconds) "-" (pathname-file path)))) + (create-directory trashdir #t) + (if (directory? path) + (system (conc "mv " path " " trashfile)) + (file-move path trash-file)))) + +;;====================================================================== +;; GUI +;;====================================================================== + +;; The main menu +(define (datashare:main-menu) + (iup:menu ;; a menu is a special attribute to a dialog (think Gnome putting the menu at screen top) + (iup:menu-item "Files" (iup:menu ;; Note that you can use either #:action or action: for options + (iup:menu-item "Open" action: (lambda (obj) + (iup:show (iup:file-dialog)) + (print "File->open " obj))) + (iup:menu-item "Save" #:action (lambda (obj)(print "File->save " obj))) + (iup:menu-item "Exit" #:action (lambda (obj)(exit))))) + (iup:menu-item "Tools" (iup:menu + (iup:menu-item "Create new blah" #:action (lambda (obj)(print "Tools->new blah"))) + ;; (iup:menu-item "Show dialog" #:action (lambda (obj) + ;; (show message-window + ;; #:modal? #t + ;; ;; set positon using coordinates or center, start, top, left, end, bottom, right, parent-center, current + ;; ;; #:x 'mouse + ;; ;; #:y 'mouse + ;; ) + )))) + +(define (datashare:publish-view configdat) + ;; (pp (hash-table->alist configdat)) + (let* ((areas (configf:get-section configdat "areas")) + (label-size "70x") + (areas-sel (iup:listbox #:expand "HORIZONTAL" #:dropdown "YES")) + (version-tb (iup:textbox #:expand "HORIZONTAL")) ;; #:size "50x")) + (areas-sel (iup:listbox #:expand "HORIZONTAL" #:dropdown "YES")) + (component (iup:listbox #:expand "HORIZONTAL" #:dropdown "YES" )) + (version-val (iup:textbox #:expand "HORIZONTAL" #:size "50x")) + ;; (copy-link (iup:toggle #:expand "HORIZONTAL")) + ;; (iteration (iup:textbox #:expand "YES" #:size "20x")) + ;; (iteration (iup:textbox #:expand "HORIZONTAL" #:size "20x")) + (area-filter (iup:textbox #:expand "HORIZONTAL" #:value "%")) + (comment-tb (iup:textbox #:expand "YES" #:multiline "YES")) + (source-tb (iup:textbox #:expand "HORIZONTAL" + #:value (or (configf:lookup configdat "settings" "basepath") + ""))) + (publish (lambda (publish-type) + (let* ((area-num (or (string->number (iup:attribute areas-sel "VALUE")) 0)) + (area-dat (if (> area-num 0)(list-ref areas (- area-num 1))'("NOT SELECTED" "NOT SELECTED"))) + (area-path (cadr area-dat)) + (area-name (car area-dat)) + (version (iup:attribute version-tb "VALUE")) + (comment (iup:attribute comment-tb "VALUE")) + (spath (iup:attribute source-tb "VALUE")) + (submitter (current-user-name)) + (quality 2)) + (datashare:publish configdat publish-type area-name version comment spath submitter quality)))) + (copy (iup:button "Copy and Publish" + #:expand "HORIZONTAL" + #:action (lambda (obj) + (publish 'copy)))) + (link (iup:button "Link and Publish" + #:expand "HORIZONTAL" + #:action (lambda (obj) + (publish 'link)))) + (browse-btn (iup:button "Browse" + #:size "40x" + #:action (lambda (obj) + (let* ((fd (iup:file-dialog #:dialogtype "DIR")) + (top (iup:show fd #:modal? "YES"))) + (iup:attribute-set! source-tb "VALUE" + (iup:attribute fd "VALUE")) + (iup:destroy! fd)))))) + (print "areas") + ;; (pp areas) + (fold (lambda (areadat num) + ;; (print "Adding num=" num ", areadat=" areadat) + (iup:attribute-set! areas-sel (conc num) (car areadat)) + (+ 1 num)) + 1 areas) + (iup:vbox + (iup:hbox (iup:label "Area:" #:size label-size) ;; area-filter + areas-sel) + (iup:hbox (iup:label "Version:" #:size label-size) version-tb) + ;; (iup:hbox (iup:label "Link only" #:size label-size) copy-link) + ;; (iup:label "Iteration:") iteration) + (iup:hbox (iup:label "Comment:" #:size label-size) comment-tb) + (iup:hbox (iup:label "Source base path:" #:size label-size) source-tb browse-btn) + (iup:hbox copy link)))) + +(define (datashare:lst->path pathlst) + (conc "/" (string-intersperse (map conc pathlst) "/"))) + +(define (datashare:path->lst path) + (string-split path "/")) + +(define (datashare:pathdat-apply-heuristics configdat path) + (cond + ((file-exists? path) "found") + (else (conc path " not installed")))) + +(define (datashare:get-view configdat) + (iup:vbox + (iup:hbox + (let* ((label-size "60x") + ;; filter elements + (area-filter "%") + (version-filter "%") + (iter-filter ">= 0") + ;; reverse lookup from path to data for src and installed + (srcdat (make-hash-table)) ;; reverse lookup + (installed-dat (make-hash-table)) + ;; config values + (basepath (configf:lookup configdat "settings" "basepath")) + ;; gui elements + (submitter (iup:label "" #:expand "HORIZONTAL")) + (date-submitted (iup:label "" #:expand "HORIZONTAL")) + (comment (iup:label "" #:expand "HORIZONTAL")) + (copy-link (iup:label "" #:expand "HORIZONTAL")) + (quality (iup:label "" #:expand "HORIZONTAL")) + (installed-status (iup:label "" #:expand "HORIZONTAL")) + ;; misc + (curr-record #f) + ;; (source-data (iup:label "" #:expand "HORIZONTAL")) + (tb (iup:treebox + #:value 0 + #:name "Packages" + #:expand "YES" + #:addexpanded "NO" + #:selection-cb + (lambda (obj id state) + ;; (print "obj: " obj ", id: " id ", state: " state) + (let* ((path (datashare:lst->path (cdr (tree:node->path obj id)))) + (record (hash-table-ref/default srcdat path #f))) + (if record + (begin + (set! curr-record record) + (iup:attribute-set! submitter "TITLE" (datashare:pkg-get-submitter record)) + (iup:attribute-set! date-submitted "TITLE" (time->string (seconds->local-time (datashare:pkg-get-datetime record)))) + (iup:attribute-set! comment "TITLE" (datashare:pkg-get-comment record)) + (iup:attribute-set! quality "TITLE" (datashare:pkg-get-quality record)) + (iup:attribute-set! copy-link "TITLE" (datashare:pkg-get-store_type record)) + )) + ;; (print "id=" id " path=" path " record=" record);; (tree:node->path obj id) " run-id: " run-id) + )))) + (tb2 (iup:treebox + #:value 0 + #:name "Installed" + #:expand "YES" + #:addexpanded "NO" + #:selection-cb + (lambda (obj id state) + ;; (print "obj: " obj ", id: " id ", state: " state) + (let* ((path (datashare:lst->path (cdr (tree:node->path obj id)))) + (status (hash-table-ref/default installed-dat path #f))) + (iup:attribute-set! installed-status "TITLE" (if status status "")) + )))) + (refresh (lambda (obj) + (let* ((db (datashare:open-db configdat)) + (areas (or (configf:get-section configdat "areas") '()))) + ;; + ;; first update the Sources + ;; + (for-each + (lambda (pkgitem) + (let* ((pkg-path (list (datashare:pkg-get-area pkgitem) + (datashare:pkg-get-version_name pkgitem) + (datashare:pkg-get-iteration pkgitem))) + (pkg-id (datashare:pkg-get-id pkgitem)) + (path (datashare:lst->path pkg-path))) + ;; (print "tree:add-node tb=" tb ", pkg-path=" pkg-path ", pkg-id=" pkg-id) + (if (not (hash-table-ref/default srcdat path #f)) + (tree:add-node tb "Packages" pkg-path userdata: (conc "pkg-id: " pkg-id))) + ;; (print "path=" path " pkgitem=" pkgitem) + (hash-table-set! srcdat path pkgitem))) + (datashare:get-pkgs db area-filter version-filter iter-filter)) + ;; + ;; then update the installed + ;; + (for-each + (lambda (area) + (let* ((path (conc "/" (cadr area))) + (fullpath (conc basepath path))) + (if (not (hash-table-ref/default installed-dat path #f)) + (tree:add-node tb2 "Installed" (datashare:path->lst path))) + (hash-table-set! installed-dat path (datashare:pathdat-apply-heuristics configdat fullpath)))) + areas) + (sqlite3:finalize! db)))) + (apply (iup:button "Apply" + #:action + (lambda (obj) + (if curr-record + (let* ((area (datashare:pkg-get-area curr-record)) + (stored-path (datashare:pkg-get-stored_path curr-record)) + (source-type (datashare:pkg-get-store_type curr-record)) + (source-path (case source-type ;; (equal? source-type "link")) + ((link)(datashare:pkg-get-source-path curr-record)) + ((copy)stored-path) + (else #f))) + (dest-stub (configf:lookup configdat "areas" area)) + (target-path (conc basepath "/" dest-stub))) + (datashare:build-dir-make-link stored-path target-path) + (print "Creating link from " stored-path " to " target-path))))))) + (iup:vbox + (iup:hbox tb tb2) + (iup:frame + #:title "Source Info" + (iup:vbox + (iup:hbox (iup:button "Refresh" #:action refresh) apply) + (iup:hbox (iup:label "Submitter: ") ;; #:size label-size) + submitter + (iup:label "Submitted on: ") ;; #:size label-size) + date-submitted) + (iup:hbox (iup:label "Data stored: ") + copy-link + (iup:label "Quality: ") + quality) + (iup:hbox (iup:label "Comment: ") + comment))) + (iup:frame + #:title "Installed Info" + (iup:vbox + (iup:hbox (iup:label "Installed status/path: ") installed-status))) + ))))) + +(define (datashare:manage-view configdat) + (iup:vbox + (iup:hbox + (iup:button "Pushme" + #:expand "YES" + )))) + +(define (datashare:gui configdat) + (iup:show + (iup:dialog + #:title (conc "DataShare dashboard " (current-user-name) ":" (current-directory)) + #:menu (datashare:main-menu) + (let* ((tabs (iup:tabs + #:tabchangepos-cb (lambda (obj curr prev) + (set! *datashare:current-tab-number* curr)) + (datashare:publish-view configdat) + (datashare:get-view configdat) + (datashare:manage-view configdat) + ))) + ;; (set! (iup:callback tabs tabchange-cb:) (lambda (a b c)(print "SWITCHED TO TAB: " a " " b " " c))) + (iup:attribute-set! tabs "TABTITLE0" "Publish") + (iup:attribute-set! tabs "TABTITLE1" "Get") + (iup:attribute-set! tabs "TABTITLE2" "Manage") + ;; (iup:attribute-set! tabs "BGCOLOR" "190 190 190") + tabs))) + (iup:main-loop)) + +;;====================================================================== +;; MISC +;;====================================================================== + + +(define (datashare:do-as-calling-user proc) + (let ((eid (current-effective-user-id)) + (cid (current-user-id))) + (if (not (eq? eid cid)) ;; running suid + (set! (current-effective-user-id) cid)) + ;; (print "running as " (current-effective-user-id)) + (proc) + (if (not (eq? eid cid)) + (set! (current-effective-user-id) eid)))) + +(define (datashare:find name paths) + (if (null? paths) + #f + (let loop ((hed (car paths)) + (tal (cdr paths))) + (if (file-exists? (conc hed "/" name)) + hed + (if (null? tal) + #f + (loop (car tal)(cdr tal))))))) + +;;====================================================================== +;; MAIN +;;====================================================================== + +(define (datashare:load-config exe-dir exe-name) + (let* ((fname (conc exe-dir "/." exe-name ".config"))) + (ini:property-separator-patt " * *") + (ini:property-separator #\space) + (if (file-exists? fname) + ;; (ini:read-ini fname) + (read-config fname #f #t) + (make-hash-table)))) + +(define (datashare:process-action configdat action . args) + (case (string->symbol action) + ((get) + (if (< (length args) 2) + (begin + (print "ERROR: Missing arguments; " (string-intersperse args ", ")) + (exit 1)) + (let* ((basepath (configf:lookup configdat "settings" "basepath")) + (db (datashare:open-db configdat)) + (area (car args)) + (version (cadr args)) ;; iteration + (remargs (args:get-args args '("-i") '() args:arg-hash 0)) + (iteration (if (args:get-arg "-i")(string->number (args:get-arg "-i")) #f)) + (curr-record (datashare:get-pkg db area version iteration: iteration))) + (if (not curr-record) + (begin + (print "ERROR: No matching record found; area=" area ", version=" version ", iteration=" (if iteration iteration "(max)")) + (exit 1)) + (let* ((stored-path (datashare:pkg-get-stored_path curr-record)) + (source-type (datashare:pkg-get-store_type curr-record)) + (source-path (case source-type ;; (equal? source-type "link")) + ((link) (datashare:pkg-get-source-path curr-record)) + ((copy) stored-path) + (else #f))) + (dest-stub (configf:lookup configdat "areas" area)) + (target-path (conc basepath "/" dest-stub))) + (datashare:build-dir-make-link stored-path target-path) + (datashare:record-pkg-ref db (datashare:pkg-get-id curr-record) target-path) + (sqlite3:finalize! db) + (print "Creating link from " stored-path " to " target-path)))))) + ((publish) + (if (< (length args) 3) + (begin + (print "ERROR: Missing arguments; " (string-intersperse args ", ")) + (exit 1)) + (let* ((srcpath (list-ref args 0)) + (areaname (list-ref args 1)) + (version (list-ref args 2)) + (remargs (args:get-args (drop args 2) + '("-type" ;; link or copy (default is copy) + "-m") + '() + args:arg-hash + 0)) + (publish-type (if (equal? (args:get-arg "-type") "link") 'link 'copy)) + (comment (or (args:get-arg "-m") "")) + (submitter (current-user-name)) + (quality (args:get-arg "-quality")) + (publish-res (datashare:publish configdat publish-type areaname version comment srcpath submitter quality))) + (if (not (car publish-res)) + (begin + (print "ERROR: " (cdr publish-res)) + (exit 1)))))) + ((list-versions) + (let ((area-name (car args)) ;; version patt full print + (remargs (args:get-args args '("-vpatt") '("-full") args:arg-hash 0)) + (db (datashare:open-db configdat)) + (versions (datashare:get-versions-for-area db (car args) version-patt: (args:get-arg "-vpatt")))) + ;; (print "area-name=" area-name " args=" args " *args-hash*=" (hash-table->alist *args-hash*)) + (map (lambda (x) + (if (args:get-arg "-full") + (format #t + "~10a~10a~4a~27a~30a\n" + (vector-ref x 0) + (vector-ref x 1) + (vector-ref x 2) + (conc "\"" (time->string (seconds->local-time (vector-ref x 3))) "\"") + (conc "\"" (vector-ref x 4) "\"")) + (print (vector-ref x 0)))) + versions) + (sqlite3:finalize! db))))) + +;; ease debugging by loading ~/.dashboardrc - REMOVE FROM PRODUCTION! +(let ((debugcontrolf (conc (get-environment-variable "HOME") "/.datasharerc"))) + (if (file-exists? debugcontrolf) + (load debugcontrolf))) + +(define (main) + (let* ((args (argv)) + (prog (car args)) + (rema (cdr args)) + (exe-name (pathname-file (car (argv)))) + (exe-dir (or (pathname-directory prog) + (datashare:find exe-name (string-split (get-environment-variable "PATH") ":")))) + (configdat (datashare:load-config exe-dir exe-name))) + (cond + ;; one-word commands + ((eq? (length rema) 1) + (case (string->symbol (car rema)) + ((help -h -help --h --help) + (print datashare:help)) + ((list-areas) + (map print (datashare:get-areas configdat))) + (else + (print "ERROR: Unrecognised command. Try \"datashare help\"")))) + ;; multi-word commands + ((null? rema)(datashare:gui configdat)) + ((>= (length rema) 2) + (apply datashare:process-action configdat (car rema)(cdr rema))) + (else (print "ERROR: Unrecognised command. Try \"datashare help\""))))) + +(main) Index: db.scm ================================================================== --- db.scm +++ db.scm @@ -11,106 +11,351 @@ ;;====================================================================== ;; Database access ;;====================================================================== -(require-extension (srfi 18) extras tcp) ;; rpc) -;; (import (prefix rpc rpc:)) - -(use sqlite3 srfi-1 posix regex regex-case srfi-69 csv-xml s11n md5 message-digest base64 format) +(require-extension (srfi 18) extras tcp) +(use sqlite3 srfi-1 posix regex regex-case srfi-69 csv-xml s11n md5 message-digest base64 format dot-locking) (import (prefix sqlite3 sqlite3:)) (import (prefix base64 base64:)) -;; Note, try to remove this dependency -;; (use zmq) - (declare (unit db)) (declare (uses common)) (declare (uses keys)) (declare (uses ods)) -(declare (uses fs-transport)) (declare (uses client)) (declare (uses mt)) -(declare (uses filedb)) (include "common_records.scm") (include "db_records.scm") (include "key_records.scm") (include "run_records.scm") -;; timestamp type (val1 val2 ...) -;; type: meta-info, step -(define *incoming-writes* '()) -(define *completed-writes* (make-hash-table)) -(define *incoming-last-time* (current-seconds)) -(define *incoming-mutex* (make-mutex)) -(define *completed-mutex* (make-mutex)) -(define *cache-on* #f) - - - -(define (db:set-sync db) - (let* ((syncval (config-lookup *configdat* "setup" "synchronous")) - (val (cond ;; 0 | OFF | 1 | NORMAL | 2 | FULL; - ((not syncval) #f) - ((string->number syncval) - (let ((val (string->number syncval))) - (if (member val '(0 1 2)) val #f))) - ((string-match (regexp "yes" #t) syncval) 1) - ((string-match (regexp "no" #t) syncval) 0) - ((string-match (regexp "(off|normal|full)" #t) syncval) syncval) - (else - (debug:print 0 "ERROR: synchronous must be 0,1,2,OFF,NORMAL or FULL, you provided: " syncval) - #f)))) - (if val - (begin - (debug:print-info 9 "db:set-sync, setting pragma synchronous to " val) - (sqlite3:execute db (conc "PRAGMA synchronous = '" val "';")))))) - -(define (open-db) ;; (conc *toppath* "/megatest.db") (car *configinfo*))) - (if (not *toppath*) - (if (not (setup-for-run)) - (begin - (debug:print 0 "ERROR: Attempted to open db when not in megatest area. Exiting.") - (exit)))) - (let* ((dbpath (conc *toppath* "/megatest.db")) ;; fname) - (dbexists (file-exists? dbpath)) - (db (sqlite3:open-database dbpath)) ;; (never-give-up-open-db dbpath)) - (write-access (file-write-access? dbpath)) - (handler (make-busy-timeout (if (args:get-arg "-override-timeout") - (string->number (args:get-arg "-override-timeout")) - 136000)))) ;; 136000))) ;; 136000 = 2.2 minutes - (if (and dbexists - (not write-access)) - (set! *db-write-access* write-access)) ;; only unset so other db's also can use this control - (debug:print-info 11 "open-db, dbpath=" dbpath " argv=" (argv)) - (if write-access (sqlite3:set-busy-handler! db handler)) - (if (not dbexists) - (db:initialize db)) - ;; Moving db:set-sync to a call in run.scm - it is a persistent value and only needs to be set once - ;; (db:set-sync db) +(define *rundb-mutex* (make-mutex)) ;; prevent problems opening/closing rundb's +(define *number-of-writes* 0) +(define *number-non-write-queries* 0) + +;; 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 (sqlite3:database? dbstruct) ;; pass sqlite3 databases on through + dbstruct + (begin + (mutex-lock! *rundb-mutex*) + (let ((db (if (or (not run-id) + (eq? run-id 0)) + (db:open-main dbstruct) + (db:open-rundb dbstruct run-id) + ))) + ;; db prunning would go here + (mutex-unlock! *rundb-mutex*) + db)))) + +;; mod-read: +;; 'mod modified data +;; 'read read data +;; +(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-set-mtime! dbstruct (current-milliseconds)) + (dbr:dbstruct-set-rtime! dbstruct (current-milliseconds))) + (dbr:dbstruct-set-inuse! dbstruct #f) + (mutex-unlock! *rundb-mutex*)))) + +;; (db:with-db dbstruct run-id sqlite3:exec "select blah from 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* ((db (db:get-db dbstruct run-id)) + ) + ;; (proc2 (lambda () + (let ((res (apply proc db params))) + (db:done-with dbstruct run-id r/w) + res))) +;; (handle-exceptions +;; exn +;; (begin +;; (thread-sleep! 10) +;; (proc2)) +;; (proc2)))) + +;;====================================================================== +;; 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))) +;; (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 => zeroth db with name=main.db +;; +(define (db:dbfile-path run-id) + (let* (;; (toppath (dbr:dbstruct-get-path dbstruct)) + (link-tree-path (configf:lookup *configdat* "setup" "linktree")) + (fname (if (eq? run-id 0) "main.db" (conc run-id ".db"))) + (dbdir (conc link-tree-path "/.db/"))) + (handle-exceptions + exn + (begin + (debug:print 0 "ERROR: Couldn't create path to " dbdir) + (exit 1)) + (if (not (directory? dbdir))(create-directory dbdir #t))) + (conc dbdir fname))) + +;; open an sql database inside a file lock +;; +;; returns: db existed-prior-to-opening +;; +(define (db:lock-create-open fname initproc) + (if (file-exists? fname) + (let ((db (sqlite3:open-database fname))) + (sqlite3:set-busy-handler! db (make-busy-timeout 136000)) + (sqlite3:execute db "PRAGMA synchronous = 0;") + db) + (let* ((parent-dir (pathname-directory fname)) + (dir-writable (file-write-access? parent-dir))) + (if dir-writable + (let ((lock (obtain-dot-lock fname 1 5 10)) + (exists (file-exists? fname)) + (db (sqlite3:open-database fname))) + (sqlite3:set-busy-handler! db (make-busy-timeout 136000)) + (sqlite3:execute db "PRAGMA synchronous = 0;") + (if (not exists)(initproc db)) + (release-dot-lock fname) + db) + (begin + (debug:print 0 "ERROR: no such db in non-writable dir " fname) + (sqlite3:open-database fname)))))) + +;; This routine creates the db. It is only called if the db is not already opened +;; +(define (db:open-rundb dbstruct run-id) ;; (conc *toppath* "/megatest.db") (car *configinfo*))) + (let* ((local (dbr:dbstruct-get-local dbstruct)) + (rdb (if local + (dbr:dbstruct-get-localdb dbstruct run-id) + (dbr:dbstruct-get-inmem dbstruct)))) ;; (dbr:dbstruct-get-runrec dbstruct run-id 'inmem))) + (if rdb + rdb + (let* ((dbpath (db:dbfile-path run-id)) ;; (conc toppath "/db/" run-id ".db")) + (dbexists (file-exists? dbpath)) + (inmem (if local #f (db:open-inmem-db))) + (refdb (if local #f (db:open-inmem-db))) + (db (db:lock-create-open dbpath + (lambda (db) + (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) + ))) ;; add strings db to rundb, not in use yet + ;; )) ;; (sqlite3:open-database dbpath)) + (olddb (if *megatest-db* + *megatest-db* + (let ((db (db:open-megatest-db))) + (set! *megatest-db* db) + db))) + (write-access (file-write-access? dbpath)) + ;; (handler (make-busy-timeout 136000)) + ) + (if (and dbexists (not write-access)) + (set! *db-write-access* #f)) ;; only unset so other db's also can use this control + (dbr:dbstruct-set-rundb! dbstruct db) + (dbr:dbstruct-set-inuse! dbstruct #t) + (dbr:dbstruct-set-olddb! dbstruct olddb) + ;; (dbr:dbstruct-set-run-id! dbstruct run-id) + (if local + (begin + (dbr:dbstruct-set-localdb! dbstruct run-id db) ;; (dbr:dbstruct-set-inmem! dbstruct db) ;; direct access ... + db) + (begin + (dbr:dbstruct-set-inmem! dbstruct inmem) + (db:sync-tables db:sync-tests-only db inmem) + (dbr:dbstruct-set-refdb! dbstruct refdb) + (db:sync-tables db:sync-tests-only db refdb) + inmem)))))) + +;; This routine creates the db. It is only called if the db is not already ls opened +;; +(define (db:open-main dbstruct) ;; (conc *toppath* "/megatest.db") (car *configinfo*))) + (let ((mdb (dbr:dbstruct-get-main dbstruct))) + (if mdb + mdb + (let* ((dbpath (db:dbfile-path 0)) + (dbexists (file-exists? dbpath)) + (db (db:lock-create-open dbpath db:initialize-main-db)) + (olddb (db:open-megatest-db)) + (write-access (file-write-access? dbpath))) + (if (and dbexists (not write-access)) + (set! *db-write-access* #f)) + (dbr:dbstruct-set-main! dbstruct db) + (dbr:dbstruct-set-olddb! dbstruct olddb) + db)))) + +;; Make the dbstruct, setup up auxillary db's and call for main db at least once +;; +(define (db:setup run-id #!key (local #f)) + (let* ((dbdir (conc (configf:lookup *configdat* "setup" "linktree") "/.db")) + (dbstruct (make-dbr:dbstruct path: dbdir local: local))) + dbstruct)) + +;; Open the classic megatest.db file in toppath +;; +(define (db:open-megatest-db) + (let* ((dbpath (conc *toppath* "/megatest.db")) + (dbexists (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))) + (if (and dbexists (not write-access)) + (set! *db-write-access* #f)) db)) -(define (open-in-mem-db) - (let* ((path (configf:lookup *configdat* "setup" "tmpdb")) - (fname (if path (conc path "/temp-megatest.db") #f)) - (exists (and path (file-exists? fname))) - (db (if path - (begin - (create-directory path #t) - (sqlite3:open-database fname)) - (sqlite3:open-database ":memory:"))) - (handler (make-busy-timeout 3600))) - (if (or (not path) - (not exists)) - (db:initialize db)) +;; sync run to disk if touched +;; +(define (db:sync-touched dbstruct run-id #!key (force-sync #f)) + (let ((mtime (dbr:dbstruct-get-mtime dbstruct)) + (stime (dbr:dbstruct-get-stime dbstruct)) + (rundb (dbr:dbstruct-get-rundb dbstruct)) + (inmem (dbr:dbstruct-get-inmem dbstruct)) + (maindb (dbr:dbstruct-get-main dbstruct)) + (refdb (dbr:dbstruct-get-refdb dbstruct)) + (olddb (dbr:dbstruct-get-olddb dbstruct)) + ;; (runid (dbr:dbstruct-get-run-id dbstruct)) + ) + (debug:print-info 4 "Syncing for run-id: " run-id) + (if (eq? run-id 0) + ;; runid equal to 0 is main.db + (if maindb + (if (or (not (number? mtime)) + (not (number? stime)) + (> mtime stime) + force-sync) + (let ((num-synced (db:sync-tables (db:sync-main-list maindb) maindb olddb))) + (dbr:dbstruct-set-stime! dbstruct (current-milliseconds)) + num-synced) + 0) + (begin + ;; this can occur when using local access (i.e. not in a server) + ;; need a flag to turn it off. + ;; + (debug:print 3 "WARNING: call to sync main.db to megatest.db but main not initialized") + 0)) + ;; any other runid is a run + (if (or (not (number? mtime)) + (not (number? stime)) + (> mtime stime) + force-sync) + (let ((num-synced (db:sync-tables db:sync-tests-only inmem refdb rundb olddb))) + (dbr:dbstruct-set-stime! dbstruct (current-milliseconds)) + num-synced) + 0)))) + +;; close all opened run-id dbs +(define (db:close-all dbstruct) + ;; finalize main.db + (db:sync-touched dbstruct 0 force-sync: #t) + (sqlite3:finalize! (db:get-db dbstruct #f)) + (let* ((local (dbr:dbstruct-get-local dbstruct)) + (rundb (dbr:dbstruct-get-rundb dbstruct))) + (if local + (for-each + (lambda (db) + (if (sqlite3:database? db) + (sqlite3:finalize! db))) + (hash-table-values (dbr:dbstruct-get-locdbs dbstruct)))) + (if rundb + (if (sqlite3:database? rundb) + (sqlite3:finalize! rundb) + (debug:print 2 "WARNING: attempting to close databases but got " rundb " instead of a database"))))) + +(define (db:open-inmem-db) + (let* ((db (sqlite3:open-database ":memory:")) + (handler (make-busy-timeout 3600))) + (db:initialize-run-id-db db) (sqlite3:set-busy-handler! db handler) db)) -;; (define (db:sync-table tblname fields fromdb todb) +;; 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)) + (list "test_steps" + '("id" #f) + '("test_id" #f) + '("stepname" #f) + '("state" #f) + '("status" #f) + '("event_time" #f) + '("comment" #f) + '("logfile" #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)))) -(define (db:tbls db) +;; needs db to get keys, this is for syncing all tables +;; +(define (db:sync-main-list db) (let ((keys (db:get-keys db))) (list (list "keys" '("id" #f) '("fieldname" #f) @@ -119,41 +364,10 @@ (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")))) - (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)) - (list "test_steps" - '("id" #f) - '("test_id" #f) - '("stepname" #f) - '("state" #f) - '("status" #f) - '("event_time" #f) - '("comment" #f) - '("logfile" #f)) (list "test_meta" '("id" #f) '("testname" #f) '("owner" #f) '("description" #f) @@ -163,258 +377,213 @@ '("avg_disk" #f) '("tags" #f) '("jobgroup" #f))))) ;; tbls is ( ("tablename" ( "field1" [#f|proc1] ) ( "field2" [#f|proc2] ) .... ) ) -(define (db:sync-tables tbls fromdb todb) - (let ((stmts (make-hash-table)) ;; table-field => stmt - (all-stmts '()) ;; ( ( stmt1 value1 ) ( stml2 value2 )) - (numrecs (make-hash-table)) - (start-time (current-milliseconds))) - (for-each ;; table - (lambda (tabledat) - (let* ((tablename (car tabledat)) - (fields (cdr tabledat)) - (num-fields (length fields)) - (field->num (make-hash-table)) - (num->field (apply vector (map car fields))) - (full-sel (conc "SELECT " (string-intersperse (map car fields) ",") - " FROM " tablename ";")) - (full-ins (conc "INSERT OR REPLACE INTO " tablename " ( " (string-intersperse (map car fields) ",") " ) " - " VALUES ( " (string-intersperse (make-list num-fields "?") ",") " );")) - (fromdat '()) - (todat (make-hash-table)) - (count 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))) - fromdb - full-sel) - - ;; read the target table - (sqlite3:for-each-row - (lambda (a . b) - (hash-table-set! todat a (apply vector a b))) - todb - full-sel) - - ;; first pass implementation, just insert all changed rows - (let ((stmth (sqlite3:prepare todb full-ins))) - (sqlite3:with-transaction - todb - (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))) - (sqlite3:finalize! stmth)))) - tbls) - (let ((runtime (- (current-milliseconds) start-time))) - (debug:print 0 "INFO: db sync, total run time " runtime " ms") - (for-each - (lambda (dat) - (let ((tblname (car dat)) - (count (cdr dat))) - (if (> count 0) - (debug:print 0 (format #f " ~10a ~5a" tblname count))))) - (sort (hash-table->alist numrecs)(lambda (a b)(> (cdr a)(cdr b)))))))) - -;; (define (db:sync-to fromdb todb) -;; ;; strategy -;; ;; 1. Get all run-ids -;; ;; 2. For each run-id -;; ;; a. Sync that run in a transaction -;; (let ((trecchgd 0) -;; (rrecchgd 0) -;; (tmrecchgd 0)) -;; -;; ;; First sync test_meta data -;; (let ((tmgetstmt (sqlite3:prepare todb "SELECT id,testname,author,owner,description,reviewed,iterated,avg_runtime,avg_disk,tags,jobgroup FROM test_meta WHERE id=?;")) -;; (tmputstmt (sqlite3:prepare todb "INSERT OR REPLACE INTO test_meta (id,testname,author,owner,description,reviewed,iterated,avg_runtime,avg_disk,tags,jobgroup) -;; VALUES (?, ?, ?, ?, ?, ?, ?, ?, ?, ?, ?);")) -;; (tmdats (db:testmeta-get-all fromdb))) -;; ;; (debug:print 7 "Updating as many as " (length tdats) " records for run " run-id) -;; (for-each -;; (lambda (tmdat) ;; iterate over tests -;; (let ((testm-id (vector-ref tmdat 0))) -;; (sqlite3:with-transaction -;; todb -;; (lambda () -;; (let ((curr-tmdat #f)) -;; (sqlite3:for-each-row -;; (lambda (a . b) -;; (set! curr-tmdat (apply vector a b))) -;; tmgetstmt testm-id) -;; (if (not (equal? curr-tmdat tmdat)) ;; something changed -;; (begin -;; (debug:print 0 " test-id: " testm-id -;; "\ncurr-tdat: " curr-tmdat -;; "\n tdat: " tmdat) -;; (apply sqlite3:execute tmputstmt (vector->list tmdat)) -;; (set! tmrecchgd (+ tmrecchgd 1))))))))) -;; tmdats) -;; (sqlite3:finalize! tmgetstmt) -;; (sqlite3:finalize! tmputstmt)) -;; -;; ;; First sync tests data -;; (let ((run-ids (db:get-all-run-ids fromdb)) -;; (tgetstmt (sqlite3:prepare todb "SELECT id,run_id,testname,state,status,event_time,host,cpuload,diskfree,uname,rundir,item_path,run_duration,final_logf,comment FROM tests WHERE id=?;")) -;; (tputstmt (sqlite3:prepare todb "INSERT OR REPLACE INTO tests (id,run_id,testname,state,status,event_time,host,cpuload,diskfree,uname,rundir,item_path,run_duration,final_logf,comment) -;; VALUES (?, ?, ?, ?, ?, ?, ?, ?, ?, ?, ?, ?, ?, ?, ? );"))) -;; (for-each -;; (lambda (run-id) -;; (let ((tdats (db:get-all-tests-info-by-run-id fromdb run-id))) -;; ;; (debug:print 7 "Updating as many as " (length tdats) " records for run " run-id) -;; (for-each -;; (lambda (tdat) ;; iterate over tests -;; (let ((test-id (vector-ref tdat 0))) -;; (sqlite3:with-transaction -;; todb -;; (lambda () -;; (let ((curr-tdat #f)) -;; (sqlite3:for-each-row -;; (lambda (a . b) -;; (set! curr-tdat (apply vector a b))) -;; tgetstmt -;; test-id) -;; (if (not (equal? curr-tdat tdat)) ;; something changed -;; (begin -;; (debug:print 0 " test-id: " test-id -;; "\ncurr-tdat: " curr-tdat -;; "\n tdat: " tdat) -;; (apply sqlite3:execute tputstmt (vector->list tdat)) -;; (set! trecchgd (+ trecchgd 1))))))))) -;; tdats))) -;; run-ids) -;; (sqlite3:finalize! tgetstmt) -;; (sqlite3:finalize! tputstmt)) -;; -;; ;; Next sync runs table -;; (let* ((rdats '()) -;; (keys (db:get-keys fromdb)) -;; (rstdfields (conc "id," (string-intersperse keys ",") ",runname,state,status,owner,event_time,comment,fail_count,pass_count")) -;; (rnumfields (length (string-split rstdfields ","))) -;; (runslots (string-intersperse (make-list rnumfields "?") ",")) -;; (rgetstmt (sqlite3:prepare todb (conc "SELECT " rstdfields " FROM runs WHERE id=?;"))) -;; (rputstmt (sqlite3:prepare todb (conc "INSERT OR REPLACE INTO runs (" rstdfields ") VALUES ( " runslots " );")))) -;; ;; first collect all the source run data -;; (sqlite3:for-each-row -;; (lambda (a . b) -;; (set! rdats (cons (apply vector a b) rdats))) -;; fromdb -;; (conc "SELECT " rstdfields " FROM runs;")) -;; (sqlite3:with-transaction -;; todb -;; (lambda () -;; (for-each -;; (lambda (rdat) -;; (let ((run-id (vector-ref rdat 0)) -;; (curr-rdat #f)) -;; ;; first get the current value of the equivalent row from the target -;; ;; read, then insert/overwrite if different -;; (sqlite3:for-each-row -;; (lambda (a . b) -;; (set! curr-rdat (apply vector a b))) -;; rgetstmt -;; run-id) -;; (if (not (equal? curr-rdat rdat)) -;; (begin -;; (debug:print 0 " run-id: " run-id -;; "\ncurr-rdat: " curr-rdat -;; "\n rdat: " rdat) -;; (set! rrecchgd (+ rrecchgd 1)) -;; (apply sqlite3:execute rputstmt (vector->list rdat)))))) -;; rdats))) -;; (sqlite3:finalize! rgetstmt) -;; (sqlite3:finalize! rputstmt)) -;; -;; (if (> rrecchgd 0) (debug:print 0 "synced " rrecchgd " changed records in runs table")) -;; (if (> trecchgd 0) (debug:print 0 "synced " trecchgd " changed records in tests table")) -;; (if (> tmrecchgd 0) (debug:print 0 "sync'd " tmrecchgd " changed records in test_meta table")) -;; (+ rrecchgd trecchgd tmrecchgd))) - -(define (db:sync-back) - (db:sync-tables (db:tbls *inmemdb*) *inmemdb* *db*)) ;; (db:sync-to *inmemdb* *db*)) +(define (db:sync-tables tbls fromdb todb . slave-dbs) + (mutex-lock! *db-sync-mutex*) + (cond + ((not fromdb) (debug:print 3 "WARNING: db:sync-tables called with fromdb missing") -1) + ((not todb) (debug:print 3 "WARNING: db:sync-tables called with todb missing") -2) + ((not (sqlite3:database? fromdb)) + (debug:print 0 "ERROR: db:sync-tables called with fromdb not a database " fromdb) -3) + ((not (sqlite3:database? todb)) + (debug:print 0 "ERROR: db:sync-tables called with todb not a database " todb) -4) + (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)) + (num-fields (length fields)) + (field->num (make-hash-table)) + (num->field (apply vector (map car fields))) + (full-sel (conc "SELECT " (string-intersperse (map car fields) ",") + " FROM " tablename ";")) + (full-ins (conc "INSERT OR REPLACE INTO " tablename " ( " (string-intersperse (map car fields) ",") " ) " + " VALUES ( " (string-intersperse (make-list num-fields "?") ",") " );")) + (fromdat '()) + (todat (make-hash-table)) + (count 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))) + fromdb + full-sel) + + (debug:print-info 2 "found " (length fromdat) " records to sync") + + ;; read the target table + (sqlite3:for-each-row + (lambda (a . b) + (hash-table-set! todat a (apply vector a b))) + todb + full-sel) + + ;; first pass implementation, just insert all changed rows + (for-each + (lambda (targdb) + (let ((stmth (sqlite3:prepare targdb full-ins))) + (sqlite3:with-transaction + targdb + (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))) + (sqlite3:finalize! stmth))) + (append (list todb) slave-dbs)))) + tbls) + (let* ((runtime (- (current-milliseconds) start-time)) + (should-print (common:low-noise-print 30 "db sync" (> runtime 500)))) ;; low and high sync times treated as separate. + (if should-print (debug:print 0 "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 (format #f " ~10a ~5a" tblname count)))))) + (sort (hash-table->alist numrecs)(lambda (a b)(> (cdr a)(cdr b)))))) + tot-count))) + (mutex-unlock! *db-sync-mutex*)) + +;; options: +;; +;; 'killservers - kills all servers +;; 'dejunk - removes junk records +;; 'adj-testids - move test-ids into correct ranges +;; 'old2new - sync megatest.db records to .db/{main,1,2 ...}.db +;; 'new2old - sync .db/{main,1,2,3 ...}.db to megatest.db +;; 'closeall - close all opened dbs +;; +;; run-ids: '(1 2 3 ...) or #f (for all) +;; +(define (db:multi-db-sync run-ids . options) + (let* ((toppath (launch:setup-for-run)) + (dbstruct (if toppath (make-dbr:dbstruct path: toppath) #f)) + (mtdb (if toppath (db:open-megatest-db))) + (run-ids (if run-ids + run-ids + (if toppath (db:get-all-run-ids mtdb)))) + (mdb (tasks:open-db)) + (servers (tasks:get-all-servers mdb))) + + ;; kill servers + (if (member 'killservers options) + (for-each + (lambda (server) + (tasks:server-delete-record mdb (vector-ref server 0) "dbmigration") + (tasks:kill-server (vector-ref server 2)(vector-ref server 1))) + servers)) + + ;; clear out junk records + ;; + (if (member 'dejunk options) + (db:clean-up mtdb)) + + ;; adjust test-ids to fit into proper range + ;; + (if (member 'adj-testids options) + (db:prep-megatest.db-for-migration mtdb)) + + ;; sync runs, test_meta etc. + ;; + (if (member 'old2new options) + (begin + (db:sync-tables (db:sync-main-list mtdb) mtdb (db:get-db dbstruct #f)) + (for-each + (lambda (run-id) + (let ((testrecs (db:get-all-tests-info-by-run-id mtdb run-id)) + (dbstruct (if toppath (make-dbr:dbstruct path: toppath local: #t) #f))) + (debug:print 0 "INFO: Propagating " (length testrecs) " records for run-id=" run-id " to run specific db") + (db:replace-test-records dbstruct run-id testrecs) + (sqlite3:finalize! (dbr:dbstruct-get-rundb dbstruct)))) + run-ids))) + + ;; now ensure all newdb data are synced to megatest.db + (if (member 'new2old options) + (for-each + (lambda (run-id) + (let ((fromdb (if toppath (make-dbr:dbstruct path: toppath local: #t) #f))) + (if (eq? run-id 0) + (db:sync-tables (db:sync-main-list dbstruct)(db:get-db fromdb run-id) mtdb) + (db:sync-tables db:sync-tests-only (db:get-db fromdb run-id) mtdb)))) + run-ids)) + + (db:close-all dbstruct) + (sqlite3:finalize! mdb))) ;; keeping it around for debugging purposes only (define (open-run-close-no-exception-handling proc idb . params) (debug:print-info 11 "open-run-close-no-exception-handling START given a db=" (if idb "yes " "no ") ", params=" params) (if (or *db-write-access* (not (member proc *db:all-write-procs*))) - (let* ((db (cond - ((sqlite3:database? idb) idb) - ((not idb) (open-db)) - ((procedure? idb) (idb)) - (else (open-db)))) + (let* ((db (cond + ((sqlite3:database? idb) idb) + ((not idb) (debug:print 0 "ERROR: cannot open-run-close with #f anymore")) + ((procedure? idb) (idb)) + (else (debug:print 0 "ERROR: cannot open-run-close with #f anymore")))) (res #f)) (set! res (apply proc db params)) - (if (not idb)(sqlite3:finalize! db)) + (if (not idb)(sqlite3:finalize! dbstruct)) (debug:print-info 11 "open-run-close-no-exception-handling END" ) res) #f)) (define (open-run-close-exception-handling proc idb . params) (handle-exceptions exn - (begin - (debug:print 0 "EXCEPTION: database probably overloaded or unreadable.") - (debug:print 0 " " ((condition-property-accessor 'exn 'message) exn)) - (print-call-chain) - (thread-sleep! (random 120)) - (debug:print-info 0 "trying db call one more time....") - (apply open-run-close-no-exception-handling proc idb params)) + (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 "EXCEPTION: database probably overloaded or unreadable.") + (debug:print 0 " message: " ((condition-property-accessor 'exn 'message) exn)) + (print "exn=" (condition->list exn)) + (debug:print 0 " status: " ((condition-property-accessor 'sqlite3 'status) exn)) + (print-call-chain) + (thread-sleep! sleep-time) + (debug:print-info 0 "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 open-run-close-exception-handling) -(define open-run-close open-run-close-no-exception-handling) - -(define *global-delta* 0) -(define *last-global-delta-printed* 0) - -(define (open-run-close-measure proc idb . params) - (debug:print-info 11 "open-run-close-measure START, idb=" idb ", params=" params) - (let* ((start-ms (current-milliseconds)) - (db (if idb idb (open-db))) - (throttle (string->number (config-lookup *configdat* "setup" "throttle")))) - ;; (db:set-sync db) - (set! res (apply proc db params)) - (if (not idb)(sqlite3:finalize! db)) - ;; 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 1 "launch throttle factor=" *global-delta*) - (set! *last-global-delta-printed* *global-delta*))) - (debug:print-info 11 "open-run-close-measure END" ) - res)) - -(define (db:initialize db) - (debug:print-info 11 "db:initialize START") +;; (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 db) (let* ((configdat (car *configinfo*)) ;; tut tut, global warning... (keys (keys:config-get-fields configdat)) (havekeys (> (length keys) 0)) (keystr (keys->keystr keys)) (fieldstr (keys->key/field keys))) @@ -422,44 +591,74 @@ (let ((keyn key)) (if (member (string-downcase keyn) (list "runname" "state" "status" "owner" "event_time" "comment" "fail_count" "pass_count")) (begin - (print "ERROR: your key cannot be named " keyn " as this conflicts with the same named field in the runs table") - (system (conc "rm -f " dbpath)) + (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:execute db "PRAGMA synchronous = OFF;") - (db:set-sync db) - (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 INTO keys (fieldname,fieldtype) VALUES (?,?);" key "TEXT")) - keys) - (sqlite3:execute db (conc - "CREATE TABLE IF NOT EXISTS runs (id INTEGER PRIMARY KEY, " - fieldstr (if havekeys "," "") - "runname TEXT DEFAULT 'norun'," - "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," - "CONSTRAINT runsconstraint UNIQUE (runname" (if havekeys "," "") keystr "));")) - (sqlite3:execute db (conc "CREATE INDEX runs_index ON runs (runname" (if havekeys "," "") keystr ");")) - (sqlite3:execute db - "CREATE TABLE IF NOT EXISTS tests + (sqlite3:with-transaction + db + (lambda () + (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 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', + 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, + CONSTRAINT runsconstraint UNIQUE (runname" (if havekeys "," "") keystr "));")) + (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 '', + reviewed TIMESTAMP, + iterated TEXT DEFAULT '', + avg_runtime REAL, + avg_disk REAL, + tags TEXT DEFAULT '', + jobgroup TEXT DEFAULT 'default', + CONSTRAINT test_meta_constraint UNIQUE (testname));") + (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" megatest-version) + (debug:print-info 11 "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 (id INTEGER PRIMARY KEY, run_id INTEGER DEFAULT -1, testname TEXT DEFAULT 'noname', host TEXT DEFAULT 'n/a', cpuload REAL DEFAULT -1, diskfree INTEGER DEFAULT -1, uname TEXT DEFAULT 'n/a', - rundir TEXT DEFAULT 'n/a', - shortdir TEXT DEFAULT '', + rundir TEXT DEFAULT '/tmp/badname', + shortdir TEXT DEFAULT '/tmp/badname', item_path TEXT DEFAULT '', state TEXT DEFAULT 'NOT_STARTED', status TEXT DEFAULT 'FAIL', attemptnum INTEGER DEFAULT 0, final_logf TEXT DEFAULT 'logs/final.log', @@ -468,41 +667,32 @@ comment TEXT DEFAULT '', event_time TIMESTAMP DEFAULT (strftime('%s','now')), fail_count INTEGER DEFAULT 0, pass_count INTEGER DEFAULT 0, archived INTEGER DEFAULT 0, -- 0=no, 1=in progress, 2=yes - CONSTRAINT testsconstraint UNIQUE (run_id, testname, item_path) - );") - (sqlite3:execute db "CREATE INDEX tests_index ON tests (run_id, testname, item_path);") - (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 test_steps + 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);") + (sqlite3:execute db "CREATE TABLE IF NOT EXISTS test_steps (id INTEGER PRIMARY KEY, test_id INTEGER, stepname TEXT, state TEXT DEFAULT 'NOT_STARTED', status TEXT DEFAULT 'n/a', event_time TIMESTAMP, comment TEXT DEFAULT '', logfile TEXT DEFAULT '', CONSTRAINT test_steps_constraint UNIQUE (test_id,stepname,state));") - (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);") - (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 '', - reviewed TIMESTAMP DEFAULT (strftime('%s','now')), - iterated TEXT DEFAULT '', - avg_runtime REAL DEFAULT -1, - avg_disk REAL DEFAULT -1, - tags TEXT DEFAULT '', - jobgroup TEXT DEFAULT 'default', - CONSTRAINT test_meta_constraint UNIQUE (testname));") - (sqlite3:execute db "CREATE TABLE IF NOT EXISTS test_data (id INTEGER PRIMARY KEY, + ;; (sqlite3:execute db "CREATE TABLE IF NOT EXISTS test_data + ;; (id INTEGER PRIMARY KEY, + ;; reviewed TIMESTAMP DEFAULT (strftime('%s','now')), + ;; iterated TEXT DEFAULT '', + ;; avg_runtime REAL DEFAULT -1, + ;; avg_disk REAL DEFAULT -1, + ;; tags TEXT DEFAULT '', + ;; jobgroup TEXT DEFAULT 'default', + ;; CONSTRAINT test_meta_constraint UNIQUE (testname));") + (sqlite3:execute db "CREATE TABLE IF NOT EXISTS test_data (id INTEGER PRIMARY KEY, test_id INTEGER, category TEXT DEFAULT '', variable TEXT, value REAL, expected REAL, @@ -510,23 +700,30 @@ units TEXT, comment TEXT DEFAULT '', status TEXT DEFAULT 'n/a', type TEXT DEFAULT '', CONSTRAINT test_data_constraint UNIQUE (test_id,category,variable));") - ;; Must do this *after* running patch db !! No more. - (db:set-var db "MEGATEST_VERSION" megatest-version) - (debug:print-info 11 "db:initialize END") - )) + ;; Why use FULL here? This data is not that critical + ;; (sqlite3:execute db "PRAGMA synchronous = FULL;") + (sqlite3:execute db "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);"))) + db) ;;====================================================================== ;; L O G G I N G D B ;;====================================================================== (define (open-logging-db) ;; (conc *toppath* "/megatest.db") (car *configinfo*))) (let* ((dbpath (conc (if *toppath* (conc *toppath* "/") "") "logging.db")) ;; fname) (dbexists (file-exists? dbpath)) - (db (sqlite3:open-database dbpath)) ;; (never-give-up-open-db 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) @@ -535,13 +732,10 @@ (sqlite3:execute db (conc "PRAGMA synchronous = 0;")))) db)) (define (db:log-local-event . loglst) (let ((logline (apply conc loglst))) - ;; (pwd (current-directory)) - ;; (cmdline (string-intersperse (argv) " ")) - ;; (pid (current-process-id))) (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 (?,?,?,?);" @@ -551,93 +745,12 @@ (current-process-id)) (sqlite3:finalize! db) logline)) ;;====================================================================== -;; TODO: -;; put deltas into an assoc list with version numbers -;; apply all from last to current +;; D B U T I L S ;;====================================================================== -(define (patch-db db) - (handle-exceptions - exn - (begin - (print "Exception: " exn) - (print "ERROR: Possible out of date schema, attempting to add table metadata...") - (sqlite3:execute db "CREATE TABLE IF NOT EXISTS metadat (id INTEGER, var TEXT, val TEXT, - CONSTRAINT metadat_constraint UNIQUE (var));") - (if (not (db:get-var db "MEGATEST_VERSION")) - (db:set-var db "MEGATEST_VERSION" 1.17))) - (let ((mver (db:get-var db "MEGATEST_VERSION")) - (test-meta-def "CREATE TABLE IF NOT EXISTS test_meta (id INTEGER PRIMARY KEY, - testname TEXT DEFAULT '', - author TEXT DEFAULT '', - owner TEXT DEFAULT '', - description TEXT DEFAULT '', - reviewed TIMESTAMP, - iterated TEXT DEFAULT '', - avg_runtime REAL, - avg_disk REAL, - tags TEXT DEFAULT '', - CONSTRAINT test_meta_constraint UNIQUE (testname));")) - (print "Current schema version: " mver " current megatest version: " megatest-version) - (cond - ((not mver) - (print "Adding megatest-version to metadata") ;; Need to recreate the table - (sqlite3:execute db "DROP TABLE IF EXISTS metadat;") - (sqlite3:execute db "CREATE TABLE IF NOT EXISTS metadat (id INTEGER, var TEXT, val TEXT, - CONSTRAINT metadat_constraint UNIQUE (var));") - (db:set-var db "MEGATEST_VERSION" 1.17) - (patch-db)) - ((< mver 1.21) - (sqlite3:execute db "DROP TABLE IF EXISTS metadat;") - (sqlite3:execute db "CREATE TABLE IF NOT EXISTS metadat (id INTEGER, var TEXT, val TEXT, - CONSTRAINT metadat_constraint UNIQUE (var));") - (db:set-var db "MEGATEST_VERSION" 1.21) ;; set before, just in case the changes are already applied - (sqlite3:execute db test-meta-def) - ;(for-each - ; (lambda (stmt) - ; (sqlite3:execute db stmt)) - ; (list - ; "ALTER TABLE tests ADD COLUMN first_err TEXT;" - ; "ALTER TABLE tests ADD COLUMN first_warn TEXT;" - ; )) - (patch-db)) - ((< mver 1.24) - (db:set-var db "MEGATEST_VERSION" 1.24) - (sqlite3:execute db "DROP TABLE IF EXISTS test_data;") - (sqlite3:execute db "DROP TABLE IF EXISTS test_meta;") - (sqlite3:execute db test-meta-def) - (sqlite3:execute db "CREATE TABLE IF NOT EXISTS test_data (id INTEGER PRIMARY KEY, - test_id INTEGER, - category TEXT DEFAULT '', - variable TEXT, - value REAL, - expected REAL, - tol REAL, - units TEXT, - comment TEXT DEFAULT '', - status TEXT DEFAULT 'n/a', - CONSTRAINT test_data UNIQUE (test_id,category,variable));") - (print "WARNING: Table test_data and test_meta were recreated. Please do megatest -update-meta") - (patch-db)) - ((< mver 1.27) - (db:set-var db "MEGATEST_VERSION" 1.27) - (sqlite3:execute db "ALTER TABLE test_data ADD COLUMN type TEXT DEFAULT '';") - (patch-db)) - ((< mver 1.29) - (db:set-var db "MEGATEST_VERSION" 1.29) - (sqlite3:execute db "ALTER TABLE test_steps ADD COLUMN logfile TEXT DEFAULT '';") - (sqlite3:execute db "ALTER TABLE tests ADD COLUMN shortdir TEXT DEFAULT '';")) - ((< mver 1.36) - (db:set-var db "MEGATEST_VERSION" 1.36) - (sqlite3:execute db "ALTER TABLE test_meta ADD COLUMN jobgroup TEXT DEFAULT 'default';")) - ((< mver 1.37) - (db:set-var db "MEGATEST_VERSION" 1.37) - (sqlite3:execute db "ALTER TABLE tests ADD COLUMN archived INTEGER DEFAULT 0;")) - ((< mver megatest-version) - (db:set-var db "MEGATEST_VERSION" megatest-version)))))) ;;====================================================================== ;; M A I N T E N A N C E ;;====================================================================== @@ -644,59 +757,87 @@ ;; 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','LAUNCED')); - -(define (db:find-and-mark-incomplete db #!key (ovr-deadtime #f)) - (let* ((incompleted '()) +(define (db:find-and-mark-incomplete dbstruct run-id ovr-deadtime) + (let* ((db (db:get-db dbstruct run-id)) + (incompleted '()) + (oldlaunched '()) + (toplevels '()) (deadtime-str (configf:lookup *configdat* "setup" "deadtime")) (deadtime (if (and deadtime-str (string->number deadtime-str)) (string->number deadtime-str) - 7200)) ;; two hours - (run-ids (db:get-run-ids db))) ;; iterate over runs to divy up the calls + 7200))) ;; two hours (if (number? ovr-deadtime)(set! deadtime ovr-deadtime)) - (for-each - (lambda (run-id) - - ;; in RUNNING or REMOTEHOSTSTART for more than 10 minutes - ;; - ;; THIS CANNOT WORK. The run_duration is not updated in the central db due to performance concerns. - ;; The testdat.db file must be consulted. - ;; - ;; 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) - (sqlite3:for-each-row - (lambda (test-id) - (set! incompleted (cons test-id incompleted))) - db - "SELECT id 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 - ;; - (sqlite3:for-each-row - (lambda (test-id) - (set! incompleted (cons test-id incompleted))) - db - "SELECT id FROM tests WHERE run_id=? AND (strftime('%s','now') - event_time - run_duration) > ? AND state IN ('LAUNCHED');" - run-id (* 60 60 24))) - run-ids) - + + ;; 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) + (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 "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) + (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 "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. ;; - (if (> (length incompleted) 0) - (begin - (debug:print 0 "WARNING: Marking test(s); " (string-intersperse (map conc incompleted) ", ") " as INCOMPLETE") - (sqlite3:execute - db - (conc "UPDATE tests SET state='INCOMPLETE' WHERE id IN (" - (string-intersperse (map conc incompleted) ",") - ");")))))) + ;; (db:delay-if-busy) + (let* (;; (min-incompleted (filter (lambda (x) + ;; (let* ((testpath (cadr x)) + ;; (tdatpath (conc testpath "/testdat.db")) + ;; (dbexists (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 "WARNING: Marking test(s); " (string-intersperse (map conc all-ids) ", ") " as INCOMPLETE") + (sqlite3:execute + db + (conc "UPDATE tests SET state='INCOMPLETE' WHERE id IN (" + (string-intersperse (map conc all-ids) ",") + ");"))))) + + ;; Now do rollups for the toplevel tests + ;; + (for-each + (lambda (toptest) + (let ((test-name (list-ref toptest 3))) +;; (run-id (list-ref toptest 5))) + (db:general-call db 'top-test-set-per-pf-counts (list test-name run-id test-name test-name test-name)))) ;; (list run-id test-name)))) + toplevels))) ;; Clean out old junk and vacuum the database ;; ;; Ultimately do something like this: ;; @@ -706,11 +847,13 @@ ;; 2. Look at run records ;; a. If have tests that are not deleted, set state='unknown' ;; b. .... ;; (define (db:clean-up db) - (let ((count-stmt (sqlite3:prepare db "SELECT (SELECT count(id) FROM tests)+(SELECT count(id) FROM runs);")) + (debug:print 0 "WARNING: db clean up not ported to v1.60, cleanup action will be on megatest.db") + (let* (;; (db (db:get-db dbstruct #f)) + (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' @@ -734,29 +877,32 @@ (sqlite3:for-each-row (lambda (tot) (debug:print-info 0 "Records count after clean: " tot)) count-stmt))) (map sqlite3:finalize! statements) (sqlite3:finalize! count-stmt) - (db:find-and-mark-incomplete db) + ;; (db:find-and-mark-incomplete db) (sqlite3:execute db "VACUUM;"))) ;;====================================================================== -;; meta get and set vars +;; 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 db var) - (debug:print-info 11 "db:get-var START " var) +;; +;; Operates on megatestdb +;; +(define (db:get-var dbstruct var) (let* ((start-ms (current-milliseconds)) (throttle (let ((t (config-lookup *configdat* "setup" "throttle"))) (if t (string->number t) t))) (res #f)) (sqlite3:for-each-row (lambda (val) (set! res val)) - db "SELECT val FROM metadat WHERE var=?;" var) + (db:get-db dbstruct #f) + "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)))) ;; scale by 10, average with current value. @@ -765,72 +911,75 @@ 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 "launch throttle factor=" *global-delta*) (set! *last-global-delta-printed* *global-delta*))) - (debug:print-info 11 "db:get-var END " var " val=" res) res)) -(define (db:set-var db var val) - (debug:print-info 11 "db:set-var START " var " " val) - (sqlite3:execute db "INSERT OR REPLACE INTO metadat (var,val) VALUES (?,?);" var val) - (debug:print-info 11 "db:set-var END " var " " val)) - -(define (db:del-var db var) - (debug:print-info 11 "db:del-var START " var) - (sqlite3:execute db "DELETE FROM metadat WHERE var=?;" var) - (debug:print-info 11 "db:del-var END " var)) +(define (db:set-var dbstruct var val) + ;; (db:delay-if-busy) + (sqlite3:execute (db:get-db dbstruct #f) "INSERT OR REPLACE INTO metadat (var,val) VALUES (?,?);" var val)) + +(define (db:del-var dbstruct var) + ;; (db:delay-if-busy) + (sqlite3:execute (db:get-db dbstruct #f) "DELETE FROM metadat WHERE var=?;" var)) ;; 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 db) +(define (db:get-keys dbstruct) (if *db-keys* *db-keys* (let ((res '())) - (sqlite3:for-each-row - (lambda (key) - (set! res (cons key res))) - db - "SELECT fieldname FROM keys ORDER BY id DESC;") + (db:with-db dbstruct #f #f + (lambda (db) + (sqlite3:for-each-row + (lambda (key) + (set! res (cons key res))) + (db:get-db dbstruct #f) + "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) - (debug:print-info 4 "db:get-value-by-header row: " row " header: " header " field: " field) (if (null? header) #f (let loop ((hed (car header)) (tal (cdr header)) (n 0)) (if (equal? hed field) (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-name-from-id db run-id) +(define (db:get-run-name-from-id dbstruct run-id) (let ((res #f)) (sqlite3:for-each-row (lambda (runname) (set! res runname)) - db + (db:get-db dbstruct #f) "SELECT runname FROM runs WHERE id=?;" run-id) res)) -(define (db:get-run-key-val db run-id key) +(define (db:get-run-key-val dbstruct run-id key) (let ((res #f)) (sqlite3:for-each-row (lambda (val) (set! res val)) - db + (db:get-db dbstruct #f) (conc "SELECT " key " FROM runs WHERE id=?;") run-id) res)) ;; keys list to key1,key2,key3 ... @@ -852,14 +1001,16 @@ '("") patts)) comparator))) -;; register a test run with the db -(define (db:register-run db keyvals runname state status user) - (debug:print 3 "runs:register-run runname: " runname " state: " state " status: " status " user: " user) - (let* ((keys (map car keyvals)) +;; 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) + (let* ((db (db:get-db dbstruct #f)) + (keys (map car keyvals)) (keystr (keys->keystr keys)) (comma (if (> (length keys) 0) "," "")) (andstr (if (> (length keys) 0) " AND " "")) (valslots (keys->valslots keys)) ;; ?,?,? ... (allvals (append (list runname state status user) (map cadr keyvals))) @@ -867,10 +1018,11 @@ (key=?str (string-intersperse (map (lambda (k)(conc k "=?")) keys) " AND "))) (debug:print 3 "keys: " keys " allvals: " allvals " keyvals: " keyvals " key=?str is " key=?str) (debug:print 2 "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" (let ((res #f)) + ;; (db:delay-if-busy) (apply sqlite3:execute db (conc "INSERT OR IGNORE INTO runs (runname,state,status,owner,event_time" comma keystr ") VALUES (?,?,?,?,strftime('%s','now')" comma valslots ");") allvals) (apply sqlite3:for-each-row (lambda (id) (set! res id)) @@ -877,128 +1029,196 @@ db (let ((qry (conc "SELECT id FROM runs WHERE (runname=? " andstr key=?str ");"))) ;(debug:print 4 "qry: " qry) qry) qryvals) + ;; (db:delay-if-busy) (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 0 "ERROR: Called without all necessary keys") #f)))) -(define (db:get-all-run-ids db) - (let ((res '())) - (sqlite3:for-each-row - (lambda (run-id) - (set! res (cons run-id res))) - db - "SELECT DISTINCT run_id FROM tests;") - res)) - ;; 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 db runpatt count offset keypatts) +(define (db:get-runs dbstruct runpatt count offset keypatts) (let* ((res '()) - (keys (db:get-keys db)) + (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 ","))) + (string-intersperse remfields ","))) (qrystr (conc "SELECT " keystr " FROM runs WHERE (" runpattstr ") " ;; runname LIKE ? " - ;; Generate: " AND x LIKE 'keypatt' ..." - (if (null? keypatts) "" - (conc " AND " + ;; 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) - "")))) + " AND state != 'deleted' ORDER BY event_time DESC " + (if (number? count) + (conc " LIMIT " count) + "") + (if (number? offset) + (conc " OFFSET " offset) + "")))) (debug:print-info 11 "db:get-runs START qrystr: " qrystr " keypatts: " keypatts " offset: " offset " limit: " count) - (sqlite3:for-each-row - (lambda (a . x) - (set! res (cons (apply vector a x) res))) - db - qrystr - ) + (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 "db:get-runs END qrystr: " qrystr " keypatts: " keypatts " offset: " offset " limit: " count) (vector header 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 +;; +;; NOTE: THIS IS COMPLETELY UNFINISHED. IT GOES WITH rmt:get-get-paths-matching-keynames +;; +(define (db:get-run-ids-matching dbstruct keynames target res) +;; (define (db:get-runs-by-patt dbstruct keys runnamepatt targpatt offset limit) ;; test-name) + (let* ((tmp (runs:get-std-run-fields keys '("id" "runname" "state" "status" "owner" "event_time"))) + (keystr (car tmp)) + (header (cadr tmp)) + (res '()) + (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 0 "ERROR: 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 " ORDER BY event_time " + (if limit (conc " LIMIT " limit) "") + (if offset (conc " OFFSET " offset) "") + ";")) + (debug:print-info 4 "runs:get-runs-by-patt qry=" qry-str " " runnamepatt) + (db:with-db dbstruct #f #f ;; reads db, does not write to it. + (lambda (db) + (sqlite3:for-each-row + (lambda (a . r) + (set! res (cons (list->vector (cons a r)) res))) + (db:get-db dbstruct #f) + qry-str + runnamepatt))) + (vector header res))) + ;; Get all targets from the db ;; -(define (db:get-targets db) +(define (db:get-targets dbstruct) (let* ((res '()) - (keys (db:get-keys db)) + (keys (db:get-keys dbstruct)) (header keys) ;; (map key:get-fieldname keys)) (keystr (keys->keystr keys)) - (qrystr (conc "SELECT " keystr " FROM runs;")) + (qrystr (conc "SELECT " keystr " FROM runs WHERE state != 'deleted';")) (seen (make-hash-table))) (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 + (db:get-db dbstruct #f) qrystr) (debug:print-info 11 "db:get-targets END qrystr: " qrystr ) (vector header res))) ;; just get count of runs -(define (db:get-num-runs db runpatt) +(define (db:get-num-runs dbstruct runpatt) (let ((numruns 0)) (debug:print-info 11 "db:get-num-runs START " runpatt) (sqlite3:for-each-row (lambda (count) (set! numruns count)) - db + (db:get-db dbstruct #f) "SELECT COUNT(id) FROM runs WHERE runname LIKE ? AND state != 'deleted';" runpatt) (debug:print-info 11 "db:get-num-runs END " runpatt) numruns)) + +(define (db:get-all-run-ids dbstruct) + (let ((run-ids '())) + (sqlite3:for-each-row + (lambda (run-id) + (set! run-ids (cons run-id run-ids))) + (db:get-db dbstruct #f) + "SELECT id FROM runs WHERE state != 'deleted';") + (reverse run-ids))) ;; get some basic run stats ;; ;; ( (runname (( state count ) ... )) ;; ( ... -(define (db:get-run-stats db) +(define (db:get-run-stats dbstruct) (let ((totals (make-hash-table)) - (res '())) + (curr (make-hash-table)) + (res '()) + (runs-info '())) + ;; First get all the runname/run-ids (sqlite3:for-each-row - (lambda (runname state count) - (let* ((stateparts (string-split state "|")) - (newstate (conc (car stateparts) "\n" (cadr stateparts)))) - (hash-table-set! totals newstate (+ (hash-table-ref/default totals newstate 0) count)) - (set! res (cons (list runname newstate count) res)))) - db - "SELECT runname,t.state||'|'||t.status AS s,count(t.id) FROM runs AS r INNER JOIN tests AS t ON r.id=t.run_id GROUP BY s,runname ORDER BY r.event_time,s DESC;" ) - ;; (set! res (reverse res)) + (lambda (run-id runname) + (set! runs-info (cons (list run-id runname) runs-info))) + (db:get-db dbstruct #f) + "SELECT id,runname FROM runs WHERE state != 'deleted';") + ;; 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))) + (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:get-db dbstruct run-id) + "SELECT state,status,count(id) FROM tests AS t GROUP BY state,status ORDER BY state,status DESC;") + ;; 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-row runinfo)) +;; 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 db keys runnamepatt targpatt offset limit) ;; test-name) +(define (db:get-runs-by-patt dbstruct keys runnamepatt targpatt offset limit) ;; test-name) (let* ((tmp (runs:get-std-run-fields keys '("id" "runname" "state" "status" "owner" "event_time"))) (keystr (car tmp)) (header (cadr tmp)) (res '()) (key-patt "") @@ -1019,200 +1239,224 @@ (set! qry-str (conc "SELECT " keystr " FROM runs WHERE state != 'deleted' AND runname " runwildtype " ? " key-patt " ORDER BY event_time " (if limit (conc " LIMIT " limit) "") (if offset (conc " OFFSET " offset) "") ";")) (debug:print-info 4 "runs:get-runs-by-patt qry=" qry-str " " runnamepatt) - (sqlite3:for-each-row - (lambda (a . r) - (set! res (cons (list->vector (cons a r)) res))) - db - qry-str - runnamepatt) + (db:with-db dbstruct #f #f ;; reads db, does not write to it. + (lambda (db) + (sqlite3:for-each-row + (lambda (a . r) + (set! res (cons (list->vector (cons a r)) res))) + (db:get-db dbstruct #f) + qry-str + runnamepatt))) (vector header res))) -;; use (get-value-by-header (db:get-header runinfo)(db:get-row runinfo)) -(define (db:get-run-info db run-id) +;; use (get-value-by-header (db:get-header runinfo)(db:get-rows runinfo)) +(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 db)) + (keys (db:get-keys dbstruct)) (remfields (list "id" "runname" "state" "status" "owner" "event_time")) (header (append keys remfields)) (keystr (conc (keys->keystr keys) "," (string-intersperse remfields ",")))) (debug:print-info 11 "db:get-run-info run-id: " run-id " header: " header " keystr: " keystr) (sqlite3:for-each-row (lambda (a . x) (set! res (apply vector a x))) - db + (db:get-db dbstruct #f) (conc "SELECT " keystr " FROM runs WHERE id=? AND state != 'deleted';") run-id) (debug:print-info 11 "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 db run-id comment) - (sqlite3:execute db "UPDATE runs SET comment=? WHERE id=?;" comment run-id)) +(define (db:set-comment-for-run dbstruct run-id comment) + ;; (db:delay-if-busy) + (sqlite3:execute (db:get-db dbstruct #f) "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 db run-id) +(define (db:delete-run dbstruct run-id) ;; First set any related tests to DELETED - (let ((stmt1 (sqlite3:prepare db "UPDATE tests SET state='DELETED',comment='' WHERE run_id=?;")) - (stmt2 (sqlite3:prepare db "UPDATE runs SET state='deleted',comment='' WHERE id=?;"))) - (sqlite3:with-transaction - db (lambda () - (sqlite3:execute stmt1 run-id) - (sqlite3:execute stmt2 run-id))) - (sqlite3:finalize! stmt1) - (sqlite3:finalize! stmt2))) - -(define (db:update-run-event_time db run-id) - (sqlite3:execute db "UPDATE runs SET event_time=strftime('%s','now') WHERE id=?;" run-id)) - -(define (db:lock/unlock-run db run-id lock unlock user) + (let ((db (db:get-db dbstruct run-id))) + ;; (db:delay-if-busy) + (sqlite3:execute db "UPDATE tests SET state='DELETED',comment='';") + (sqlite3:execute db "DELETE FROM test_steps;") + (sqlite3:execute db "DELETE FROM test_data;") + (sqlite3:execute (db:get-db dbstruct #f) "UPDATE runs SET state='deleted',comment='' WHERE id=?;" run-id))) + +(define (db:update-run-event_time dbstruct run-id) + ;; (db:delay-if-busy) + (sqlite3:execute (db:get-db dbstruct #f) "UPDATE runs SET event_time=strftime('%s','now') WHERE id=?;" run-id)) + +(define (db:lock/unlock-run dbstruct run-id lock unlock user) (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'),?);" + (sqlite3:execute (db:get-db dbstruct #f) "UPDATE runs SET state=? WHERE id=?;" newlockval run-id) + ;; (db:delay-if-busy) + (sqlite3:execute (db:get-db dbstruct #f) "INSERT INTO access_log (user,accessed,args) VALUES(?,strftime('%s','now'),?);" user (conc newlockval " " run-id)) (debug:print-info 1 "" newlockval " run number " run-id))) -(define (db:get-run-ids db) - (let ((res '())) - (sqlite3:for-each-row - (lambda (id) - (set! res (cons id res))) - db - "SELECT id FROM runs;"))) +(define (db:set-run-status dbstruct run-id status msg) + (let ((db (db:get-db dbstruct #f))) + (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")) + (sqlite3:for-each-row + (lambda (status) + (set! res status)) + (db:get-db dbstruct #f) + "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 db run-id) - (let* ((keys (db:get-keys db)) +(define (db:get-key-val-pairs dbstruct run-id) + (let* ((keys (db:get-keys dbstruct)) (res '())) - (debug:print-info 11 "db:get-key-val-pairs START keys: " keys " run-id: " run-id) (for-each (lambda (key) (let ((qry (conc "SELECT " key " FROM runs WHERE id=?;"))) ;; (debug:print 0 "qry: " qry) (sqlite3:for-each-row (lambda (key-val) (set! res (cons (list key key-val) res))) - db qry run-id))) + (db:get-db dbstruct #f) qry run-id))) keys) - (debug:print-info 11 "db:get-key-val-pairs END keys: " keys " run-id: " run-id) (reverse res))) ;; get key vals for a given run-id -(define (db:get-key-vals db run-id) - (let ((mykeyvals (hash-table-ref/default *keyvals* run-id #f))) - (if mykeyvals - mykeyvals - (let* ((keys (db:get-keys db)) - (res '())) - (debug:print-info 11 "db:get-key-vals START keys: " keys " run-id: " run-id) - (for-each - (lambda (key) - (let ((qry (conc "SELECT " key " FROM runs WHERE id=?;"))) - ;; (debug:print 0 "qry: " qry) - (sqlite3:for-each-row - (lambda (key-val) - (set! res (cons key-val res))) - db qry run-id))) - keys) - (debug:print-info 11 "db:get-key-vals END keys: " keys " run-id: " run-id) - (let ((final-res (reverse res))) - (hash-table-set! *keyvals* run-id final-res) - final-res))))) +(define (db:get-key-vals dbstruct run-id) + (let* ((keys (db:get-keys dbstruct)) + (res '())) + (for-each + (lambda (key) + (let ((qry (conc "SELECT " key " FROM runs WHERE id=?;"))) + (sqlite3:for-each-row + (lambda (key-val) + (set! res (cons key-val res))) + (db:get-db dbstruct #f) 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 db run-id) - (let ((mytarg (hash-table-ref/default *target* run-id #f))) - (if mytarg - mytarg - (let* ((keyvals (db:get-key-vals db run-id)) - (thekey (string-intersperse (map (lambda (x)(if x x "-na-")) keyvals) "/"))) - (hash-table-set! *target* run-id thekey) - thekey)))) +(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 '())) + (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 -(define (db:get-tests-for-run db run-id testpatt states statuses offset limit not-in sort-by sort-order qryvals) - (let* ((qryvalstr (case qryvals - ((shortlist) "id,run_id,testname,item_path,state,status") - ((#f) "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 not-in - " NOT IN ('" - " IN ('") - (string-intersperse states "','") - "')"))) - (statuses-qry (if (null? statuses) - #f - (conc " status " - (if not-in - " NOT IN ('" - " IN ('") - (string-intersperse statuses "','") - "')"))) - (states-statuses-qry - (cond - ((and states-qry statuses-qry) - (conc " AND ( " states-qry " AND " statuses-qry " ) ")) - (states-qry - (conc " AND " states-qry)) - (statuses-qry - (conc " AND " statuses-qry)) - (else ""))) - (tests-match-qry (tests:match->sqlqry testpatt)) - (qry (conc "SELECT " qryvalstr - " FROM tests WHERE run_id=? AND state != 'DELETED' " - states-statuses-qry - (if tests-match-qry (conc " AND (" tests-match-qry ") ") "") - (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 "db:get-tests-for-run qry=" qry) - (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 - run-id - ) - (case qryvals - ((shortlist)(map db:test-short-record->norm res)) - ((#f) res) - (else res)))) +(define (db:get-tests-for-run dbstruct run-id testpatt states statuses offset limit not-in sort-by sort-order qryvals) + (if (not (number? run-id)) + (begin ;; no need to treat this as an error by default + (debug:print 4 "WARNING: call to db:get-tests-for-run with bad run-id=" run-id) + ;; (print-call-chain) + '()) + (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 not-in + " NOT IN ('" + " IN ('") + (string-intersperse states "','") + "')"))) + (statuses-qry (if (null? statuses) + #f + (conc " status " + (if not-in + " NOT IN ('" + " IN ('") + (string-intersperse statuses "','") + "')"))) + (states-statuses-qry + (cond + ((and states-qry statuses-qry) + (conc " AND ( " states-qry " AND " statuses-qry " ) ")) + (states-qry + (conc " AND " states-qry)) + (statuses-qry + (conc " AND " statuses-qry)) + (else ""))) + (tests-match-qry (tests:match->sqlqry testpatt)) + (qry (conc "SELECT " qryvalstr + " FROM tests WHERE run_id=? AND state != 'DELETED' " + states-statuses-qry + (if tests-match-qry (conc " AND (" tests-match-qry ") ") "") + (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 "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 + run-id + ))) + (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 @@ -1223,310 +1467,377 @@ -1 "" -1 -1 "" "-" (vector-ref inrec 3) ;; item-path -1 "-" "-")) -(define (db:get-tests-for-run-state-status db run-id testpatt) +(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 "db:get-tests-for-run qry=" qry) - (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) + (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 db test-id) +(define (db:get-testinfo-state-status dbstruct run-id test-id) (let ((res #f)) - (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) + (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:mintests-get-{id ,run_id,testname ...} -(define (db:get-tests-for-runs-mindata db run-ids testpatt states status not-in) - (db:get-tests-for-runs db run-ids testpatt states status not-in: not-in qryvals: "id,run_id,testname,state,status,event_time,item_path")) +(define (db:get-tests-for-runs-mindata dbstruct run-ids testpatt states statuses not-in) + (db:get-tests-for-runs dbstruct run-ids testpatt states statuses not-in: not-in qryvals: "id,run_id,testname,state,status,event_time,item_path")) +(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)))) + (if run-ids + run-ids + (db:get-all-run-ids dbstruct))) + res)) -;; NB // This is get tests for "runs" (note the plural!!) +;; Convert calling routines to get list of run-ids and loop, do not use the get-tests-for-runs ;; -;; 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 -;; run-ids is a list of run-ids or a single number or #f for all runs -(define (db:get-tests-for-runs db run-ids testpatt states statuses - #!key (not-in #t) - (sort-by #f) - (qryvals "id,run_id,testname,state,status,event_time,host,cpuload,diskfree,uname,rundir,item_path,run_duration,final_logf,comment")) ;; 'rundir 'event_time - (let* ((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 not-in "NOT" "") - " IN ('" - (string-intersperse states "','") - "')"))) - (statuses-qry (if (null? statuses) - #f - (conc " status " - (if not-in "NOT" "") - " IN ('" - (string-intersperse statuses "','") - "')"))) - (tests-match-qry (tests:match->sqlqry testpatt)) - (qry (conc "SELECT " qryvals - " FROM tests WHERE state != 'DELETED' " - (if run-ids - (if (list? run-ids) - (conc "AND run_id IN (" (string-intersperse (map conc run-ids) ",") ") ") - (conc "AND run_id=" run-ids " ")) - " ") ;; #f => run-ids don't filter on run-ids - (if states-qry (conc " AND " states-qry) "") - (if statuses-qry (conc " AND " statuses-qry) "") - (if tests-match-qry (conc " AND (" tests-match-qry ") ") "") - (case sort-by - ((rundir) " ORDER BY length(rundir) DESC;") - ((event_time) " ORDER BY event_time ASC;") - (else ";")) - ))) - (debug:print-info 8 "db:get-tests-for-runs qry=" qry) - (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 - ) - res)) - -(define (db:delete-test-records db test-id) - (db:general-call db 'delete-test-step-records (list test-id)) - (db:general-call db 'delete-test-data-records (list test-id)) - (sqlite3:execute db "UPDATE tests SET state='DELETED',status='n/a',comment='' WHERE id=?;" test-id)) - -(define (db:delete-tests-for-run db run-id) - (sqlite3:execute db "DELETE FROM tests WHERE run_id=?;" run-id)) - -(define (db:delete-old-deleted-test-records db) - (let ((targtime (- (current-seconds)(* 30 24 60 60)))) ;; one month in the past - (sqlite3:execute db "DELETE 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 ((db (db:get-db dbstruct run-id)) + (res '())) + (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) + ;; 0 1 2 3 4 5 6 7 8 9 10 11 12 13 14 + (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) + res))) + (db:get-db dbstruct run-id) + (conc "SELECT " db:test-record-qry-selector " FROM tests WHERE state != 'DELETED' AND run_id=?;") run-id) res)) -;; Get test data using test_id -;; Use db:test-get* to access -;; -;; Get test data using test_id -(define (db:get-test-info-by-id db test-id) - (if (not test-id) - (begin - (debug:print-info 4 "db:get-test-info-by-id called with test-id=" test-id) - #f) - (let ((res #f)) - (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 pass_count fail_count) - ;; 0 1 2 3 4 5 6 7 8 9 10 11 12 13 14 - (set! res (vector id run-id testname state status event-time host cpuload diskfree uname rundir item-path run_duration final_logf comment pass_count fail_count))) - db - "SELECT id,run_id,testname,state,status,event_time,host,cpuload,diskfree,uname,rundir,item_path,run_duration,final_logf,comment,pass_count,fail_count FROM tests WHERE id=?;" - test-id) - res))) - -;; Use db:test-get* to access -;; -;; Get test data using test_ids -(define (db:get-test-info-by-ids db test-ids) - (if (null? test-ids) - (begin - (debug:print-info 4 "db:get-test-info-by-ids called with test-ids=" test-ids) - '()) - (let ((res '())) - (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 pass_count fail_count) - ;; 0 1 2 3 4 5 6 7 8 9 10 11 12 13 14 - (set! res (cons (vector id run-id testname state status event-time host cpuload diskfree uname rundir item-path run_duration final_logf comment pass_count fail_count) - res))) - db - (conc "SELECT id,run_id,testname,state,status,event_time,host,cpuload,diskfree,uname,rundir,item_path,run_duration,final_logf,comment,pass_count,fail_count FROM tests WHERE id in (" - (string-intersperse (map conc test-ids) ",") ");")) - res))) - -(define (db:get-test-info db run-id testname item-path) - (db:get-test-info-by-id db (db:get-test-id db run-id testname item-path))) - -(define (db:test-get-rundir-from-test-id db test-id) - (let ((res #f)) ;; (hash-table-ref/default *test-paths* test-id #f))) - ;; (if res - ;; res - ;; (begin - (sqlite3:for-each-row - (lambda (tpath) - (set! res tpath)) - db - "SELECT rundir FROM tests WHERE id=?;" - test-id) - ;; (hash-table-set! *test-paths* test-id res) - 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 ");")) + (qry (sqlite3:prepare db qrystr))) + (debug:print 0 "INFO: migrating test records for run with id " run-id) + (sqlite3:with-transaction + db + (lambda () + (for-each + (lambda (rec) + ;; (debug:print 0 "INFO: Inserting values: " (string-intersperse (map conc (vector->list rec)) ",") "\n") + (apply sqlite3:execute qry (vector->list rec))) + 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)) + 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 "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 "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 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 mtdb run-id testrecs))) + run-ids))) + +;; Get test data using test_id +(define (db:get-test-info-by-id dbstruct run-id test-id) + (let ((db (db:get-db dbstruct run-id)) + (res #f)) + (sqlite3:for-each-row + (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) + ;; 0 1 2 3 4 5 6 7 8 9 10 11 12 13 14 + (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))) + (db:get-db dbstruct run-id) + (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) + (let ((db (db:get-db dbstruct run-id)) + (res '())) + (sqlite3:for-each-row + (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) + ;; 0 1 2 3 4 5 6 7 8 9 10 11 12 13 14 + (set! res (cons (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) + res))) + (db:get-db dbstruct run-id) + (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 testname item-path) + (let ((db (db:get-db dbstruct run-id)) + (res #f)) + (sqlite3:for-each-row + (lambda (a . b) + (set! res (apply vector a b))) + (db:get-db dbstruct run-id) + (conc "SELECT " db:test-record-qry-selector " FROM tests WHERE testname=? AND item_path=?;") + test-name item-path) + res)) + +(define (db:test-get-rundir-from-test-id dbstruct run-id test-id) + (db:first-result-default + (db:get-db dbstruct run-id) + "SELECT rundir FROM tests WHERE id=?;" + #f ;; default result + test-id)) ;;====================================================================== ;; S T E P S ;;====================================================================== -(define (db:teststep-set-status! db test-id teststep-name state-in status-in comment logfile) - (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 ""))) +(define (db:teststep-set-status! dbstruct run-id test-id teststep-name state-in status-in comment logfile) + (let ((db (db:get-db dbstruct run-id))) + (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) + ;; (sdb:qry 'getid + (if comment comment "") ;; ) + ;; (sdb:qry 'getid + (if logfile logfile "")))) ;; ) ;; db-get-test-steps-for-run -(define (db:get-steps-for-test db test-id) - (let* ((res '())) +(define (db:get-steps-for-test dbstruct run-id test-id) + (let* ((db (db:get-db dbstruct run-id)) + (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))) -(define (db:get-steps-data db test-id) - (let ((res '())) +(define (db:get-steps-data dbstruct run-id test-id) + (let ((db (db:get-db dbstruct run-id)) + (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; @@ -1540,12 +1851,13 @@ ;; 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 db test-id status) - (let ((fail-count 0) +(define (db:test-data-rollup dbstruct run-id test-id status) + (let ((db (db:get-db dbstruct run-id)) + (fail-count 0) (pass-count 0)) (sqlite3:for-each-row (lambda (fcount pcount) (set! fail-count fcount) (set! pass-count pcount)) @@ -1556,13 +1868,14 @@ ;; Now rollup the counts to the central megatest.db (db:general-call db '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 db 'test_data-pf-rollup (list test-id test-id test-id test-id)))) -(define (db:csv->test-data db test-id csvdata) +(define (db:csv->test-data dbstruct run-id test-id csvdata) (debug:print 4 "test-id " test-id ", csvdata: " csvdata) - (let ((csvlist (csv->list (make-csv-reader + (let ((db (db:get-db dbstruct run-id)) + (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) @@ -1617,106 +1930,48 @@ ;;====================================================================== ;; Misc. test related queries ;;====================================================================== -;; MUST BE CALLED local! -(define (db:test-get-paths-matching db keynames target fnamepatt #!key (res '())) - ;; BUG: Move the values derived from args to parameters and push to megatest.scm - (let* ((testpatt (if (args:get-arg "-testpatt")(args:get-arg "-testpatt") "%")) - (statepatt (if (args:get-arg ":state") (args:get-arg ":state") "%")) - (statuspatt (if (args:get-arg ":status") (args:get-arg ":status") "%")) - (runname (if (args:get-arg ":runname") (args:get-arg ":runname") "%")) - (paths-from-db (rmt:test-get-paths-matching-keynames-target-new keynames target res - testpatt - statepatt - statuspatt - runname))) - (if fnamepatt - (apply append - (map (lambda (p) - (if (directory-exists? p) - (glob (conc p "/" fnamepatt)) - '())) - paths-from-db)) - paths-from-db))) - -(define (db:test-get-paths-matching-keynames-target db keynames target res - #!key - (testpatt "%") - (statepatt "%") - (statuspatt "%") - (runname "%")) - (let* ((keystr (string-intersperse - (map (lambda (key val) - (conc "r." key " like '" val "'")) - keynames - (string-split target "/")) - " AND ")) - (testqry (tests:match->sqlqry testpatt)) - (qrystr (conc "SELECT t.rundir FROM tests AS t INNER JOIN runs AS r ON t.run_id=r.id WHERE " - keystr " AND r.runname LIKE '" runname "' AND " testqry - " AND t.state LIKE '" statepatt "' AND t.status LIKE '" statuspatt - "' ORDER BY t.event_time ASC;"))) - (sqlite3:for-each-row - (lambda (p) - (set! res (cons p res))) - db - qrystr) - res)) - -(define (db:test-get-paths-matching-keynames-target-new db keynames target res - testpatt - statepatt - statuspatt - runname) +(define (db:get-run-ids-matching-target dbstruct keynames target res runname testpatt statepatt statuspatt) (let* ((row-ids '()) (keystr (string-intersperse (map (lambda (key val) (conc key " like '" val "'")) keynames (string-split target "/")) " AND ")) - (testqry (tests:match->sqlqry testpatt)) - (rqry (conc "SELECT id FROM runs WHERE " keystr " AND runname LIKE '" runname "';")) - (runsqry (sqlite3:prepare db rqry)) - (tqry (conc "SELECT rundir FROM tests WHERE run_id=? AND " testqry " AND state LIKE '" statepatt "' AND status LIKE '" statuspatt "' ORDER BY event_time ASC;")) - (tstsqry (sqlite3:prepare db tqry))) - (debug:print 8 "db:test-get-paths-matching-keynames-target-new\n rqry=" rqry "\n tqry=" tqry) + ;; (testqry (tests:match->sqlqry testpatt)) + (runsqry (sqlite3:prepare (db:get-db dbstruct #f)(conc "SELECT id FROM runs WHERE " keystr " AND runname LIKE '" runname "';")))) + ;; (debug:print 8 "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) - (for-each (lambda (rid) - (sqlite3:for-each-row - (lambda (p) - (set! res (cons p res))) - tstsqry rid)) - row-ids) - (sqlite3:finalize! tstsqry) + row-ids)) + +(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 " testqry " AND state LIKE '" statepatt "' AND status LIKE '" statuspatt "' ORDER BY event_time ASC;"))) + (sqlite3:for-each-row + (lambda (p) + (set! res (cons p res))) + (db:get-db dbstruct run-id) + tstsqry) res)) -;; look through tests from matching runs for a file -(define (db:test-get-first-path-matching db keynames target fname) - ;; [refpaths] is the section where references to other megatest databases are stored - (let ((mt-paths (configf:get-section "refpaths")) - (res (db:test-get-paths-matching db keynames target fname))) - (let loop ((pathdat (if (null? paths) #f (car mt-paths))) - (tal (if (null? paths) '()(cdr mt-paths)))) - (if (not (null? res)) - (car res) ;; return first found - (if path - (let* ((db (open-db path: (cadr pathdat))) - (newres (db:test-get-paths-matching db keynames target fname))) - (debug:print-info 4 "Trying " (car pathdat) " at " (cadr pathdat)) - (sqlite3:finalize! db) - (if (not (null? newres)) - (car newres) - (if (null? tal) - #f - (loop (car tal)(cdr tal)))))))))) +(define (db:test-toplevel-num-items dbstruct run-id testname) + (let ((res 0)) + (sqlite3:for-each-row + (lambda (num-items) + (set! res num-items)) + (db:get-db dbstruct run-id) + "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 ;;====================================================================== @@ -1744,40 +1999,55 @@ (lambda ()(deserialize))) (vector #f #f #f))) ;; crude reply for when things go awry ((zmq)(with-input-from-string msg (lambda ()(deserialize)))) (else msg))) -(define (db:test-set-status-state db test-id status state msg) +(define (db:test-set-status-state dbstruct run-id test-id status state msg) + (let ((db (db:get-db dbstruct run-id))) (if (member state '("LAUNCHED" "REMOTEHOSTSTART")) (db:general-call db 'set-test-start-time (list test-id))) (if msg (db:general-call db 'state-status-msg (list state status msg test-id)) - (db:general-call db 'state-status (list state status test-id)))) + (db:general-call db 'state-status (list state status test-id))))) -(define (db:roll-up-pass-fail-counts db run-id test-name item-path status) +(define (db:roll-up-pass-fail-counts dbstruct run-id test-name item-path status) (if (and (not (equal? item-path "")) - (member status '("PASS" "WARN" "FAIL" "WAIVED" "RUNNING" "CHECK" "SKIP"))) - (begin - (db:general-call db 'update-pass-fail-counts (list run-id test-name run-id test-name run-id test-name)) + (member status '("PASS" "WARN" "FAIL" "WAIVED" "RUNNING" "CHECK" "SKIP" "LAUNCHED"))) + (let ((db (db:get-db dbstruct run-id))) + (db:general-call db 'update-pass-fail-counts (list test-name test-name test-name)) (if (equal? status "RUNNING") - (db:general-call db 'top-test-set-running (list run-id test-name)) - (db:general-call db 'top-test-set-per-pf-counts (list run-id test-name run-id test-name run-id test-name))) + (db:general-call db 'top-test-set-running (list test-name)) + (if (equal? status "LAUNCHED") + (db:general-call db 'top-test-set (list "LAUNCHED" test-name)) + (db:general-call db 'top-test-set-per-pf-counts (list test-name run-id test-name test-name test-name)))) #f) #f)) -(define (db:test-get-logfile-info db run-id test-name) +(define (db:tests-register-test dbstruct run-id test-name item-path) + (sqlite3:execute (db:get-db dbstruct run-id) 'register-test run-id test-name item-path)) +;; (let ((sleep-time (random 20)) +;; (err-status ((condition-property-accessor 'sqlite3 'status #f) exn))) +;; (case err-status +;; ((busy)(thread-sleep! 4)) +;; (else +;; (debug:print 0 "WARNING: possible problem with call to cdb:remote-run, database may be read-only and locked, waiting and trying again ...") +;; (thread-sleep! sleep-time))) + +(define (db:test-get-logfile-info dbstruct run-id test-name) (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 "Found path: " path) - (debug:print 2 "No such path: " path))) - db - "SELECT rundir,final_logf FROM tests WHERE run_id=? AND testname=? AND item_path='';" - run-id test-name) + (debug:print 2 "No such path: " path))) ;; ) + (db:get-db dbstruct run-id) + "SELECT rundir,final_logf FROM tests WHERE testname=? AND item_path='';" + test-name) 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 ;;====================================================================== @@ -1788,61 +2058,73 @@ ;; 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=?;") - '(state-status-msg "UPDATE tests SET state=?,status=?,comment=? 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=?;") + '(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=?;") - '(test-set-log "UPDATE tests SET final_logf=? WHERE id=?;") - '(test-set-rundir-by-test-id "UPDATE tests SET rundir=? WHERE id=?") - '(test-set-rundir "UPDATE tests SET rundir=? WHERE run_id=? AND testname=? AND item_path=?;") - '(delete-tests-in-state "DELETE FROM tests WHERE state=? AND run_id=?;") + 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=?;") + '(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=?;") - '(update-uname-host "UPDATE tests SET uname=?,host=? WHERE id=?;") + '(update-cpuload-diskfree "UPDATE tests SET cpuload=?,diskfree=? WHERE id=?;") ;; DONE + '(update-uname-host "UPDATE tests SET uname=?,host=? WHERE id=?;") ;; DONE '(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 roll-up-pass-fail-counts '(update-pass-fail-counts "UPDATE tests - SET fail_count=(SELECT count(id) FROM tests WHERE run_id=? AND testname=? AND item_path != '' AND status IN ('FAIL','CHECK')), - pass_count=(SELECT count(id) FROM tests WHERE run_id=? AND testname=? AND item_path != '' AND status IN ('PASS','WARN','WAIVED')) - WHERE run_id=? AND testname=? AND item_path='';") - '(top-test-set-running "UPDATE tests SET state='RUNNING' WHERE run_id=? AND testname=? AND item_path='';") - '(top-test-set-per-pf-counts "UPDATE tests - SET state=CASE - WHEN (SELECT count(id) FROM tests - WHERE run_id=? AND testname=? - AND item_path != '' - AND state in ('RUNNING','NOT_STARTED','LAUNCHED','REMOTEHOSTSTART')) > 0 THEN 'RUNNING' - ELSE 'COMPLETED' END, - status=CASE - WHEN fail_count > 0 THEN 'FAIL' - WHEN pass_count > 0 AND fail_count=0 THEN 'PASS' - WHEN (SELECT count(id) FROM tests - WHERE run_id=? AND testname=? - AND item_path != '' - AND status = 'SKIP') > 0 THEN 'SKIP' - ELSE 'UNKNOWN' END - WHERE run_id=? AND testname=? AND item_path='';") - - ;; STEPS - '(delete-test-step-records "UPDATE test_steps SET status='DELETED' WHERE id=?;") - '(delete-test-data-records "UPDATE test_data SET status='DELETED' WHERE id=?;") ;; using status since no state field - )) + SET fail_count=(SELECT count(id) FROM tests WHERE testname=? AND item_path != '' AND status IN ('FAIL','CHECK')), + pass_count=(SELECT count(id) FROM tests WHERE testname=? AND item_path != '' AND status IN ('PASS','WARN','WAIVED')) + WHERE testname=? AND item_path='';") ;; DONE + '(top-test-set "UPDATE tests SET state=? WHERE testname=? AND item_path='';") ;; DONE + '(top-test-set-running "UPDATE tests SET state='RUNNING' WHERE testname=? AND item_path='';") ;; DONE + '(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 ('TEN_STRIKES','BLOCKED') + AND state in ('RUNNING','NOT_STARTED','LAUNCHED','REMOTEHOSTSTART')) > 0 THEN 'RUNNING' + ELSE 'COMPLETED' END, + status=CASE + WHEN (SELECT count(id) FROM tests + WHERE run_id=? AND testname=? + AND item_path != '' + AND state IN ('NOT_STARTED','BLOCKED')) > 0 THEN 'FAIL' + WHEN fail_count > 0 THEN 'FAIL' + WHEN pass_count > 0 AND fail_count=0 THEN 'PASS' + WHEN (SELECT count(id) FROM tests + WHERE testname=? + AND item_path != '' + AND status = 'SKIP') > 0 THEN 'SKIP' + ELSE 'UNKNOWN' END + WHERE testname=? AND item_path='';") ;; DONE + + ;; 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:roll-up-pass-fail-counts ;; WHY NOT!? login @@ -1851,88 +2133,40 @@ sync set-verbosity killserver )) -(define (db:login db calling-path calling-version client-signature) - (if (and (equal? calling-path *toppath*) - (equal? megatest-version calling-version)) - (begin - (hash-table-set! *logged-in-clients* client-signature (current-seconds)) - '(#t "successful login")) ;; path matches - pass! Should vet the caller at this time ... - (list #f (conc "Login failed due to mismatch paths: " calling-path ", " *toppath*)))) - -(define (db:process-write db request-item) - (let ((stmt-key (vector-ref request-item 0)) - (query (vector-ref request-item 1)) - (params (vector-ref request-item 2)) - (queryh (sqlite3:prepare db query))) - (apply sqlite3:execute stmt params) - #f)) - -(define *db:process-queue-mutex* (make-mutex)) - -(define *number-of-writes* 0) -(define *writes-total-delay* 0) -(define *total-non-write-delay* 0) -(define *number-non-write-queries* 0) +(define (db:login dbstruct calling-path calling-version run-id 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 db stmtname params) (let ((query (let ((q (alist-ref (if (string? stmtname) (string->symbol stmtname) stmtname) db:queries))) - (if q (car q) #f)))) + (if q (car q) #f)))) (apply sqlite3:execute db query params) #t)) -;; 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 server-side -;; -(define (db:get-previous-test-run-record db run-id test-name item-path) - (let* ((keys (db:get-keys db)) - (selstr (string-intersperse keys ",")) - (qrystr (string-intersperse (map (lambda (x)(conc x "=?")) keys) " AND ")) - (keyvals #f)) - ;; first look up the key values from the run selected by run-id - (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) - #f - (let ((prev-run-ids '())) - (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))) - ;; 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 "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 (db:get-tests-for-run db hed (conc test-name "/" item-path) '() '() #f #f #f #f #f #f))) - (debug:print 4 "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)))))))))) - ;; 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 db run-id test-name item-path) - (let* ((keys (db:get-keys db)) +(define (db:get-matching-previous-test-run-records dbstruct run-id test-name item-path) + (let* ((db (db:get-db dbstruct #f)) + (keys (db:get-keys db)) (selstr (string-intersperse (map (lambda (x)(vector-ref x 0)) keys) ",")) (qrystr (string-intersperse (map (lambda (x)(conc (vector-ref x 0) "=?")) keys) " AND ")) (keyvals #f) (tests-hash (make-hash-table))) ;; first look up the key values from the run selected by run-id @@ -1954,11 +2188,11 @@ (debug:print 4 "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 db hed (conc test-name "/" item-path) '() '() #f #f #f #f #f #f))) + (let ((results (db:get-tests-for-run dbstruct run-id hed (conc test-name "/" item-path) '() '() #f #f #f #f #f #f))) (debug:print 4 "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) @@ -1971,55 +2205,125 @@ (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)))))))))) +;; (let* ((remtries 10) +;; (proc #f)) +;; (set! proc (lambda (remtries) +;; (if (> remtries 0) +;; (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) +;; (proc 10)) ;; we never give up on busy +;; (else +;; (debug:print 0 "EXCEPTION: database probably overloaded or unreadable.") +;; (debug:print 0 " message: " ((condition-property-accessor 'exn 'message) exn)) +;; (debug:print 0 " status: " ((condition-property-accessor 'sqlite3 'status) exn)) +;; (print-call-chain) +;; (debug:print 0 "Sleeping for " sleep-time) +;; (thread-sleep! sleep-time) +;; (debug:print-info 0 "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") +;; (proc (- remtries 1))))) +;; (apply sqlite3:execute db query params)) +;; (debug:print 0 "ERROR: too many attempts to access db were made and no sucess. query: " +;; query ", params: " params)))) +;; (proc remtries)) +(define (db:delay-if-busy #!key (count 6)) + (let ((dbfj (conc *toppath* "/megatest.db-journal"))) + (if (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 "delaying db access due to high database load.") + (thread-sleep! 12.8)))))) +;; (db:delay-if-busy) +;; (apply sqlite3:execute db query params))) +;; (db:delay-if-busy) -(define (db:test-get-records-for-index-file db run-id test-name) +(define (db:test-get-records-for-index-file dbstruct run-id test-name) (let ((res '())) (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 run_id=? AND testname=? AND item_path != '';" - run-id test-name) + (db:get-db dbstruct run-id) + "SELECT id,item_path,state,status,run_duration,final_logf,comment FROM tests WHERE testname=? AND item_path != '';" + test-name) res)) ;;====================================================================== ;; Tests meta data ;;====================================================================== ;; read the record given a testname -(define (db:testmeta-get-record db testname) +(define (db:testmeta-get-record dbstruct testname) (let ((res #f)) (sqlite3:for-each-row - (lambda (id testname author owner description reviewed iterated avg_runtime avg_disk tags) - (set! res (vector id testname author owner description reviewed iterated avg_runtime avg_disk tags))) - db "SELECT id,testname,author,owner,description,reviewed,iterated,avg_runtime,avg_disk,tags FROM test_meta WHERE testname=?;" + (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:get-db dbstruct #f) + "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 db testname) - (sqlite3:execute db "INSERT OR IGNORE INTO test_meta (testname,author,owner,description,reviewed,iterated,avg_runtime,avg_disk,tags) VALUES (?,'','','','','','','','');" testname)) +(define (db:testmeta-add-record dbstruct testname) + (db:delay-if-busy) + (sqlite3:execute (db:get-db dbstruct #f) "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 db testname field value) - (sqlite3:execute db (conc "UPDATE test_meta SET " field "=? WHERE testname=?;") value testname)) +(define (db:testmeta-update-field dbstruct testname field value) + (db:delay-if-busy) + (sqlite3:execute (db:get-db dbstruct #f) (conc "UPDATE test_meta SET " field "=? WHERE testname=?;") value testname)) -(define (db:testmeta-get-all db) +(define (db:testmeta-get-all dbstruct) (let ((res '())) (sqlite3:for-each-row (lambda (a . b) (set! res (cons (apply vector a b) res))) - db + (db:get-db dbstruct run-id) "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 +(define (db:compare-itempaths patha pathb itemmap) + (debug:print-info 6 "ITEMMAP is " itemmap) + (if itemmap + (let* ((mapparts (string-split itemmap)) + (pattern (car mapparts)) + (replacement (if (> (length mapparts) 1) (cadr mapparts) ""))) + (if replacement + (equal? (string-substitute pattern replacement patha) + (string-substitute pattern replacement pathb)) + (equal? (string-substitute pattern "" patha) + (string-substitute pattern "" pathb)))) + (equal? patha pathb))) ;; 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 @@ -2026,11 +2330,12 @@ ;; ;; 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 ]] ;; -(define (db:get-prereqs-not-met db run-id waitons ref-item-path mode) +;; (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-item-path #!key (mode '(normal))(itemmap #f)) (if (or (not waitons) (null? waitons)) '() (let* ((unmet-pre-reqs '()) (result '())) @@ -2037,11 +2342,11 @@ (for-each (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 ((tests (db:get-tests-for-run-state-status db run-id waitontest-name)) + (let ((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 (lambda (test) @@ -2051,25 +2356,25 @@ (item-path (db:test-get-item-path test)) (is-completed (equal? state "COMPLETED")) (is-running (equal? state "RUNNING")) (is-killed (equal? state "KILLED")) (is-ok (member status '("PASS" "WARN" "CHECK" "WAIVED" "SKIP"))) - (same-itempath (equal? ref-item-path item-path))) + (same-itempath (db:compare-itempaths ref-item-path item-path itemmap))) ;; (equal? ref-item-path item-path))) (set! ever-seen #t) (cond ;; case 1, non-item (parent test) is - ((and (equal? item-path "") ;; this is the parent test + ((and (equal? item-path "") ;; this is the parent test of the waiton being examined is-completed - (or is-ok (member mode '(toplevel itemmatch itemwait)))) + (or is-ok (not (null? (lset-intersection eq? mode '(toplevel)))))) ;; itemmatch itemwait)))))) (set! parent-waiton-met #t)) ;; Special case for toplevel and KILLED ((and (equal? item-path "") ;; this is the parent test is-killed - (eq? mode 'toplevel)) + (member 'toplevel mode)) (set! parent-waiton-met #t)) ;; For itemwait mode IFF the previous matching item is good the set parent-waiton-met - ((and (member mode '(itemmatch itemwait)) + ((and (not (null? (lset-intersection eq? mode '(itemmatch itemwait)))) ;; (not (equal? item-path "")) ;; this applies to both top level (to allow launching of next batch) and items same-itempath) (if (and is-completed is-ok) (set! item-waiton-met #t)) (if (and (equal? item-path "") @@ -2076,14 +2381,14 @@ (or is-completed is-running));; this is the parent, set it to run if completed or running (set! parent-waiton-met #t))) ;; normal checking of parent items, any parent or parent item not ok blocks running ((and is-completed (or is-ok - (eq? mode 'toplevel)) ;; toplevel does not block on FAIL - (and is-ok (eq? mode 'itemmatch))) ;; itemmatch blocks on not ok + (member 'toplevel mode)) ;; toplevel does not block on FAIL + (and is-ok (member 'itemmatch mode))) ;; itemmatch blocks on not ok (set! item-waiton-met #t))))) - tests) + tests) ;; both requirements, parent and item-waiton must be met to NOT add item to ;; prereq's not met list (if (not (or parent-waiton-met item-waiton-met)) (set! result (append (if (null? tests) (list waitontest-name) tests) result))) ;; if the test is not found then clearly the waiton is not met... @@ -2090,18 +2395,38 @@ ;; (if (not ever-seen)(set! result (cons waitontest-name result))))) (if (not ever-seen) (set! result (append (if (null? tests)(list waitontest-name) tests) result))))) waitons) (delete-duplicates result)))) + +;;====================================================================== +;; SQLITE3 HELPERS +;;====================================================================== + +;; 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 0 "ERROR: query " stmt " failed " ((condition-property-accessor 'exn 'message) exn)) + (print-call-chain) + default))) + (apply sqlite3:first-result db stmt params))) ;;====================================================================== ;; 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 db outputfile keypatt-alist runspatt pathmod) +(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 '()) (windows (and pathmod (substring-index "\\" pathmod))) Index: db_records.scm ================================================================== --- db_records.scm +++ db_records.scm @@ -1,5 +1,68 @@ +;;====================================================================== +;; dbstruct +;;====================================================================== + +;; +;; -path-|-megatest.db +;; |-db-|-main.db +;; |-monitor.db +;; |-sdb.db +;; |-fdb.db +;; |-1.db +;; |-.db +;; +;; +;; Accessors for a dbstruct +;; + +(define-inline (dbr:dbstruct-get-main vec) (vector-ref vec 0)) +(define-inline (dbr:dbstruct-get-strdb vec) (vector-ref vec 1)) +(define-inline (dbr:dbstruct-get-path vec) (vector-ref vec 2)) +(define-inline (dbr:dbstruct-get-local vec) (vector-ref vec 3)) +(define-inline (dbr:dbstruct-get-rundb vec) (vector-ref vec 4)) +(define-inline (dbr:dbstruct-get-inmem vec) (vector-ref vec 5)) +(define-inline (dbr:dbstruct-get-mtime vec) (vector-ref vec 6)) +(define-inline (dbr:dbstruct-get-rtime vec) (vector-ref vec 7)) +(define-inline (dbr:dbstruct-get-stime vec) (vector-ref vec 8)) +(define-inline (dbr:dbstruct-get-inuse vec) (vector-ref vec 9)) +(define-inline (dbr:dbstruct-get-refdb vec) (vector-ref vec 10)) +(define-inline (dbr:dbstruct-get-locdbs vec) (vector-ref vec 11)) +(define-inline (dbr:dbstruct-get-olddb vec) (vector-ref vec 12)) +;; (define-inline (dbr:dbstruct-get-run-id vec) (vector-ref vec 13)) + +(define-inline (dbr:dbstruct-set-main! vec val)(vector-set! vec 0 val)) +(define-inline (dbr:dbstruct-set-strdb! vec val)(vector-set! vec 1 val)) +(define-inline (dbr:dbstruct-set-path! vec val)(vector-set! vec 2 val)) +(define-inline (dbr:dbstruct-set-local! vec val)(vector-set! vec 3 val)) +(define-inline (dbr:dbstruct-set-rundb! vec val)(vector-set! vec 4 val)) +(define-inline (dbr:dbstruct-set-inmem! vec val)(vector-set! vec 5 val)) +(define-inline (dbr:dbstruct-set-mtime! vec val)(vector-set! vec 6 val)) +(define-inline (dbr:dbstruct-set-rtime! vec val)(vector-set! vec 7 val)) +(define-inline (dbr:dbstruct-set-stime! vec val)(vector-set! vec 8 val)) +(define-inline (dbr:dbstruct-set-inuse! vec val)(vector-set! vec 9 val)) +(define-inline (dbr:dbstruct-set-refdb! vec val)(vector-set! vec 10 val)) +(define-inline (dbr:dbstruct-set-locdbs! vec val)(vector-set! vec 11 val)) +(define-inline (dbr:dbstruct-set-olddb! vec val)(vector-set! vec 12 val)) +; (define-inline (dbr:dbstruct-set-run-id! vec val)(vector-set! vec 13 val)) + +;; constructor for dbstruct +;; +(define (make-dbr:dbstruct #!key (path #f)(local #f)) + (let ((v (make-vector 14 #f))) + (dbr:dbstruct-set-path! v path) + (dbr:dbstruct-set-local! v local) + (dbr:dbstruct-set-locdbs! v (make-hash-table)) + v)) + +(define (dbr:dbstruct-get-localdb v run-id) + (hash-table-ref/default (dbr:dbstruct-get-locdbs v) run-id #f)) + +(define (dbr:dbstruct-set-localdb! v run-id db) + (hash-table-set! (dbr:dbstruct-get-locdbs v) run-id db)) + + (define (make-db:test)(make-vector 20)) (define-inline (db:test-get-id vec) (vector-ref vec 0)) (define-inline (db:test-get-run_id vec) (vector-ref vec 1)) (define-inline (db:test-get-testname vec) (vector-ref vec 2)) (define-inline (db:test-get-state vec) (vector-ref vec 3)) @@ -7,10 +70,11 @@ (define-inline (db:test-get-event_time vec) (vector-ref vec 5)) (define-inline (db:test-get-host vec) (vector-ref vec 6)) (define-inline (db:test-get-cpuload vec) (vector-ref vec 7)) (define-inline (db:test-get-diskfree vec) (vector-ref vec 8)) (define-inline (db:test-get-uname vec) (vector-ref vec 9)) +;; (define-inline (db:test-get-rundir vec) (sdb:qry 'getstr (vector-ref vec 10))) (define-inline (db:test-get-rundir vec) (vector-ref vec 10)) (define-inline (db:test-get-item-path vec) (vector-ref vec 11)) (define-inline (db:test-get-run_duration vec) (vector-ref vec 12)) (define-inline (db:test-get-final_logf vec) (vector-ref vec 13)) (define-inline (db:test-get-comment vec) (vector-ref vec 14)) @@ -28,13 +92,17 @@ (define-inline (db:test-set-state! vec val)(vector-set! vec 3 val)) (define-inline (db:test-set-status! vec val)(vector-set! vec 4 val)) (define-inline (db:test-set-run_duration! vec val)(vector-set! vec 12 val)) (define-inline (db:test-set-final_logf! vec val)(vector-set! vec 13 val)) -;; get rows and header from -(define-inline (db:get-header vec)(vector-ref vec 0)) -(define-inline (db:get-rows vec)(vector-ref vec 1)) +;; Test record utility functions + +;; Is a test a toplevel? +;; +(define (db:test-get-is-toplevel vec) + (and (equal? (db:test-get-item-path vec) "") ;; test is not an item + (equal? (db:test-get-uname vec) "n/a"))) ;; test has never been run ;; make-vector-record "" db mintest id run_id testname state status event_time item_path ;; (define (make-db:mintest)(make-vector 7)) (define-inline (db:mintest-get-id vec) (vector-ref vec 0)) @@ -128,13 +196,10 @@ (define-inline (tdb:step-stable-set-start! vec val)(vector-set! vec 1 val)) (define-inline (tdb:step-stable-set-end! vec val)(vector-set! vec 2 val)) (define-inline (tdb:step-stable-set-status! vec val)(vector-set! vec 3 val)) (define-inline (tdb:step-stable-set-runtime! vec val)(vector-set! vec 4 val)) -;; use this one for db-get-run-info -(define-inline (db:get-row vec)(vector-ref vec 1)) - ;; The data structure for handing off requests via wire (define (make-cdb:packet)(make-vector 6)) (define-inline (cdb:packet-get-client-sig vec) (vector-ref vec 0)) (define-inline (cdb:packet-get-qtype vec) (vector-ref vec 1)) (define-inline (cdb:packet-get-immediate vec) (vector-ref vec 2)) Index: dcommon.scm ================================================================== --- dcommon.scm +++ dcommon.scm @@ -127,11 +127,11 @@ ;; 1. Make "data" hash-table hierarchial store of all displayed data ;; 2. Update synchash to understand "get-runs", "get-tests" etc. ;; 3. Add extraction of filters to synchash calls ;; ;; Mode is 'full or 'incremental for full refresh or incremental refresh -(define (run-update keys data runname keypatts testpatt states statuses mode window-id) +(define (dcommon:run-update keys data runname keypatts testpatt states statuses mode window-id) (let* (;; count and offset => #f so not used ;; the synchash calls modify the "data" hash (get-runs-sig (conc (client:get-signature) " get-runs")) (get-tests-sig (conc (client:get-signature) " get-tests")) (get-details-sig (conc (client:get-signature) " get-test-details")) @@ -139,11 +139,11 @@ ;; test-ids to get and display are indexed on window-id in curr-test-ids hash (test-ids (hash-table-values (dboard:data-get-curr-test-ids *data*))) (run-changes (synchash:client-get 'db:get-runs get-runs-sig (length keypatts) data runname #f #f keypatts)) (tests-detail-changes (if (not (null? test-ids)) - (synchash:client-get 'db:get-test-info-by-ids get-details-sig 0 data test-ids) + (synchash:client-get 'db:get-test-info-by-ids get-details-sig 0 data #f test-ids) '())) ;; Now can calculate the run-ids (run-hash (hash-table-ref/default data get-runs-sig #f)) (run-ids (if run-hash (filter number? (hash-table-keys run-hash)) '())) @@ -229,10 +229,11 @@ (dispname (if (string=? itempath "") testname (conc " " itempath))) (rownum (hash-table-ref/default testname-to-row fullname #f)) (test-path (append run-path (if (equal? itempath "") (list testname) (list testname itempath))))) + (print "INFONOTE: run-path: " run-path) (tree:add-node (dboard:data-get-tests-tree *data*) "Runs" test-path userdata: (conc "test-id: " test-id)) (hash-table-set! (dboard:data-get-path-test-ids *data*) test-path test-id) (if (not rownum) @@ -358,32 +359,32 @@ (define (dcommon:general-info) (let ((general-matrix (iup:matrix #:alignment1 "ALEFT" #:expand "YES" ;; "HORIZONTAL" #:numcol 1 - #:numlin 3 + #:numlin 2 #:numcol-visible 1 - #:numlin-visible 3))) - (iup:attribute-set! general-matrix "WIDTH1" "200") + #:numlin-visible 2))) + (iup:attribute-set! general-matrix "WIDTH1" "150") (iup:attribute-set! general-matrix "0:1" "About this Megatest area") ;; User (this is not always obvious - it is common to run as a different user (iup:attribute-set! general-matrix "1:0" "User") (iup:attribute-set! general-matrix "1:1" (current-user-name)) ;; Megatest area - (iup:attribute-set! general-matrix "2:0" "Area") - (iup:attribute-set! general-matrix "2:1" *toppath*) + ;; (iup:attribute-set! general-matrix "2:0" "Area") + ;; (iup:attribute-set! general-matrix "2:1" *toppath*) ;; Megatest version - (iup:attribute-set! general-matrix "3:0" "Version") - (iup:attribute-set! general-matrix "3:1" megatest-version) + (iup:attribute-set! general-matrix "2:0" "Version") + (iup:attribute-set! general-matrix "2:1" (conc megatest-version "-" (substring megatest-fossil-hash 0 4))) general-matrix)) -(define (dcommon:run-stats db) +(define (dcommon:run-stats dbstruct) (let* ((stats-matrix (iup:matrix expand: "YES")) (changed #f) (updater (lambda () - (let* ((run-stats (db:get-run-stats db)) + (let* ((run-stats (db:get-run-stats dbstruct)) (indices (common:sparse-list-generate-index run-stats)) ;; proc: set-cell)) (row-indices (car indices)) (col-indices (cadr indices)) (max-row (if (null? row-indices) 1 (apply max (map cadr row-indices)))) (max-col (if (null? col-indices) 1 @@ -445,15 +446,15 @@ (let* ((colnum 0) (rownum 0) (servers-matrix (iup:matrix #:expand "YES" #:numcol 7 #:numcol-visible 7 - #:numlin-visible 3 + #:numlin-visible 5 )) - (colnames (list "Id" "MTver" "Pid" "Host" "Interface:OutPort" "InPort" "State" "Transport")) + (colnames (list "Id" "MTver" "Pid" "Host" "Interface:OutPort" "RunTime" "State" "RunId")) (updater (lambda () - (let ((servers (open-run-close tasks:get-all-servers tasks:open-db))) + (let ((servers (tasks:get-all-servers (tasks:get-db)))) (iup:attribute-set! servers-matrix "NUMLIN" (length servers)) ;; (set! colnum 0) ;; (for-each (lambda (colname) ;; ;; (print "colnum: " colnum " colname: " colname) ;; (iup:attribute-set! servers-matrix (conc "0:" colnum) colname) @@ -466,25 +467,27 @@ (let* ((vals (list (vector-ref server 0) ;; Id (vector-ref server 9) ;; MT-Ver (vector-ref server 1) ;; Pid (vector-ref server 2) ;; Hostname (conc (vector-ref server 3) ":" (vector-ref server 4)) ;; IP:Port - (vector-ref server 5) ;; Pubport + (seconds->hr-min-sec (- (current-seconds)(vector-ref server 6))) + ;; (vector-ref server 5) ;; Pubport ;; (vector-ref server 10) ;; Last beat ;; (vector-ref server 6) ;; Start time ;; (vector-ref server 7) ;; Priority ;; (vector-ref server 8) ;; State - (if (< (vector-ref server 10) 20) ;; Status (Please redo this properly!) - "alive" - "dead") - (vector-ref server 11) ;; Transport + (vector-ref server 8) ;; State + (vector-ref server 12) ;; RunId ))) (for-each (lambda (val) - ;; (print "rownum: " rownum " colnum: " colnum " val: " val) - (iup:attribute-set! servers-matrix (conc rownum ":" colnum) val) - (iup:attribute-set! servers-matrix "FITTOTEXT" (conc "C" colnum)) - (set! colnum (+ 1 colnum))) + (let* ((row-col (conc rownum ":" colnum)) + (curr-val (iup:attribute servers-matrix row-col))) + (if (not (equal? (conc val) curr-val)) + (begin + (iup:attribute-set! servers-matrix row-col val) + (iup:attribute-set! servers-matrix "FITTOTEXT" (conc "C" colnum)))) + (set! colnum (+ 1 colnum)))) vals) (set! rownum (+ rownum 1))) (iup:attribute-set! servers-matrix "REDRAW" "ALL")) servers))))) (set! colnum 0) @@ -493,39 +496,41 @@ (iup:attribute-set! servers-matrix "FITTOTEXT" (conc "C" colnum)) (set! colnum (+ colnum 1))) colnames) (set! dashboard:update-servers-table updater) ;; (iup:attribute-set! servers-matrix "WIDTHDEF" "40") - (iup:hbox - (iup:vbox - (iup:button "Start" - ;; #:size "50x" - #:expand "YES" - #:action (lambda (obj) - (let ((cmd (conc ;; "xterm -geometry 180x20 -e \"" - "megatest -server - &"))) - ;; ";echo Press any key to continue;bash -c 'read -n 1 -s'\" &"))) - (system cmd)))) - (iup:button "Stop" - #:expand "YES" - ;; #:size "50x" - #:action (lambda (obj) - (let ((cmd (conc ;; "xterm -geometry 180x20 -e \"" - "megatest -stop-server 0 &"))) - ;; ";echo Press any key to continue;bash -c 'read -n 1 -s'\" &"))) - (system cmd)))) - (iup:button "Restart" - #:expand "YES" - ;; #:size "50x" - #:action (lambda (obj) - (let ((cmd (conc ;; "xterm -geometry 180x20 -e \"" - "megatest -stop-server 0;megatest -server - &"))) - ;; ";echo Press any key to continue;bash -c 'read -n 1 -s'\" &"))) - (system cmd))))) - servers-matrix - ))) - + ;; (iup:hbox + ;; (iup:vbox + ;; (iup:button "Start" + ;; ;; #:size "50x" + ;; #:expand "YES" + ;; #:action (lambda (obj) + ;; (let ((cmd (conc ;; "xterm -geometry 180x20 -e \"" + ;; "megatest -server - &"))) + ;; ;; ";echo Press any key to continue;bash -c 'read -n 1 -s'\" &"))) + ;; (system cmd)))) + ;; (iup:button "Stop" + ;; #:expand "YES" + ;; ;; #:size "50x" + ;; #:action (lambda (obj) + ;; (let ((cmd (conc ;; "xterm -geometry 180x20 -e \"" + ;; "megatest -stop-server 0 &"))) + ;; ;; ";echo Press any key to continue;bash -c 'read -n 1 -s'\" &"))) + ;; (system cmd)))) + ;; (iup:button "Restart" + ;; #:expand "YES" + ;; ;; #:size "50x" + ;; #:action (lambda (obj) + ;; (let ((cmd (conc ;; "xterm -geometry 180x20 -e \"" + ;; "megatest -stop-server 0;megatest -server - &"))) + ;; ;; ";echo Press any key to continue;bash -c 'read -n 1 -s'\" &"))) + ;; (system cmd))))) + ;; servers-matrix + ;; ))) + servers-matrix + )) + ;; The main menu (define (dcommon:main-menu) (iup:menu ;; a menu is a special attribute to a dialog (think Gnome putting the menu at screen top) (iup:menu-item "Files" (iup:menu ;; Note that you can use either #:action or action: for options (iup:menu-item "Open" action: (lambda (obj) @@ -541,6 +546,91 @@ ;; ;; set positon using coordinates or center, start, top, left, end, bottom, right, parent-center, current ;; ;; #:x 'mouse ;; ;; #:y 'mouse ;; ) )))) + +;;====================================================================== +;; CANVAS STUFF FOR TESTS +;;====================================================================== + +(define (dcommon:draw-test cnv x y w h name selected) + (let* ((llx x) + (lly y) + (urx (+ x w)) + (ury (+ y h))) + (canvas-text! cnv (+ llx 5)(+ lly 5) name) ;; (conc testname " (" xtorig "," ytorig ")")) + (canvas-rectangle! cnv llx urx lly ury) + (if selected (canvas-box! cnv llx (+ llx 5) lly (+ lly 5))))) + +(define (dcommon:initial-draw-tests cnv xadj yadj sizex sizey sizexmm sizeymm originx originy tests-draw-state sorted-testnames) + (let* ((scalef (hash-table-ref/default tests-draw-state 'scalef 8)) + (test-browse-xoffset (hash-table-ref tests-draw-state 'test-browse-xoffset)) + (test-browse-yoffset (hash-table-ref tests-draw-state 'test-browse-yoffset)) + (xtorig (+ test-browse-xoffset (* (/ sizex 2) scalef (- 0.5 xadj)))) ;; (- xadj 1)))) + (ytorig (+ test-browse-yoffset (* (/ sizey 2) scalef (- yadj 0.5)))) + (boxw 90) ;; default, overriden by length estimate below + (boxh 25) + (gapx 20) + (gapy 30) + (tests-hash (hash-table-ref tests-draw-state 'tests-info)) + (selected-tests (hash-table-ref tests-draw-state 'selected-tests ))) + (hash-table-set! tests-draw-state 'xtorig xtorig) + (hash-table-set! tests-draw-state 'ytorig ytorig) + (let ((longest-str (if (null? sorted-testnames) " " (car (sort sorted-testnames (lambda (a b)(>= (string-length a)(string-length b)))))))) + (let-values (((x-max y-max) (canvas-text-size cnv longest-str))) + (if (> x-max boxw)(set! boxw (+ 10 x-max))))) + ;; (print "sizex: " sizex " sizey: " sizey " font: " (canvas-font cnv) " originx: " originx " originy: " originy " xtorig: " xtorig " ytorig: " ytorig " xadj: " xadj " yadj: " yadj) + (if (not (null? sorted-testnames)) + (let loop ((hed (car (reverse sorted-testnames))) + (tal (cdr (reverse sorted-testnames))) + (llx xtorig) + (lly ytorig) + (urx (+ xtorig boxw)) + (ury (+ ytorig boxh))) + ; (print "hed " hed " llx " llx " lly " lly " urx " urx " ury " ury) + (dcommon:draw-test cnv llx lly boxw boxh hed (hash-table-ref/default selected-tests hed #f)) + ;; data used by mouse click calc. keep the wacky order for now. + (hash-table-set! tests-hash hed (list llx urx (- sizey ury)(- sizey lly) lly boxw boxh)) + ;; (list llx lly boxw boxh)) ;; NB// Swap ury and lly + (if (not (null? tal)) + ;; leave a column of space to the right to list items + (let ((have-room + (if #t ;; put "auto" here where some form of auto rearanging can be done + (> (* 3 (+ boxw gapx)) (- urx xtorig)) + (< urx (- sizex boxw gapx boxw))))) ;; is there room for another column? + (loop (car tal) + (cdr tal) + (if have-room (+ llx boxw gapx) xtorig) ;; have room, + (if have-room lly (+ lly boxh gapy)) + (if have-room (+ urx boxw gapx) (+ xtorig boxw)) + (if have-room ury (+ ury boxh gapy))))))))) + +(define (dcommon:redraw-tests cnv xadj yadj sizex sizey sizexmm sizeymm originx originy tests-draw-state sorted-testnames) + (let* ((scalef (hash-table-ref/default tests-draw-state 'scalef 8)) + (test-browse-xoffset (hash-table-ref tests-draw-state 'test-browse-xoffset)) + (test-browse-yoffset (hash-table-ref tests-draw-state 'test-browse-yoffset)) + (xtorig (+ test-browse-xoffset (* (/ sizex 2) scalef (- 0.5 xadj)))) ;; (- xadj 1)))) + (ytorig (+ test-browse-yoffset (* (/ sizey 2) scalef (- yadj 0.5)))) + (xdelta (- (hash-table-ref tests-draw-state 'xtorig) xtorig)) + (ydelta (- (hash-table-ref tests-draw-state 'ytorig) ytorig)) + (tests-hash (hash-table-ref tests-draw-state 'tests-info)) + (selected-tests (hash-table-ref tests-draw-state 'selected-tests ))) + (hash-table-set! tests-draw-state 'xtorig xtorig) + (hash-table-set! tests-draw-state 'ytorig ytorig) + (if (not (null? sorted-testnames)) + (let loop ((hed (car (reverse sorted-testnames))) + (tal (cdr (reverse sorted-testnames)))) + (let* ((tvals (hash-table-ref tests-hash hed)) + (llx (+ xdelta (list-ref tvals 0))) + (lly (+ ydelta (list-ref tvals 4))) + (boxw (list-ref tvals 5)) + (boxh (list-ref tvals 6)) + (urx (+ llx boxw)) + (ury (+ lly boxh))) + (dcommon:draw-test cnv llx lly boxw boxh hed (hash-table-ref/default selected-tests hed #f)) + (hash-table-set! tests-hash hed (list llx urx (- sizey ury)(- sizey lly) lly boxw boxh)) + (if (not (null? tal)) + ;; leave a column of space to the right to list items + (loop (car tal) + (cdr tal)))))))) Index: docs/html/megatest.html ================================================================== --- docs/html/megatest.html +++ docs/html/megatest.html @@ -2,11 +2,11 @@ - + Megatest User Manual
@@ -782,11 +782,11 @@
Note: The monitor is usable but incomplete as of Megatest v1.31. Click on the “Monitor” button on the dashboard to start the monitor and give it a try.
-figure monitor-state-diagram.png +figure monitor-state-diagram.png

14 Reference

@@ -1708,10 +1708,10 @@ B References
Index: docs/html/monitor-state-diagram.png ================================================================== --- docs/html/monitor-state-diagram.png +++ docs/html/monitor-state-diagram.png cannot compute difference between binary files Index: docs/manual/Makefile ================================================================== --- docs/manual/Makefile +++ docs/manual/Makefile @@ -1,7 +1,14 @@ +all : server.pdf megatest_manual.html client.pdf megatest_manual.html : megatest_manual.txt getting_started.txt writing_tests.txt reference.txt ../plan.txt asciidoc megatest_manual.txt dos2unix megatest_manual.html +server.pdf : server.dot + dot -Tpdf server.dot > server.pdf + +client.pdf : client.dot + dot -Tpdf client.dot > client.pdf + clean: rm -f megatest_manual.html ADDED docs/manual/client.dot Index: docs/manual/client.dot ================================================================== --- /dev/null +++ docs/manual/client.dot @@ -0,0 +1,35 @@ +digraph G { + + // put client after server so server_start node is visible + // + subgraph cluster_2 { + node [style=filled,shape=box]; + + "client:setup start" -> runremote_lookup_server; + runremote_lookup_server -> login_attempt [label="have server"]; + runremote_lookup_server -> monitordb_lookup_server [label="no server"]; + + monitordb_lookup_server -> login_attempt [label="have server"]; + monitordb_lookup_server -> server_start_remote [label="no server"]; + + server_start_remote -> delay_2_sec; + delay_2_sec -> runremote_lookup_server; + + login_attempt -> "rmt:send-receive_start" [label="login sucessful"]; + "rmt:send-receive_start" -> "rmt:send-receive_start"; + + "rmt:send-receive_start" -> runremote_lookup_server [label=exception]; + login_attempt -> clear_runremote [label="login failed"]; + + "remove_running > 5s" -> runremote_lookup_server; + + subgraph cluster_3 { + node [style=filled]; + clear_runremote -> "remove_running > 5s"; + } + + label = "client:setup"; + color=green; + } + +} Index: docs/manual/howto.txt ================================================================== --- docs/manual/howto.txt +++ docs/manual/howto.txt @@ -5,10 +5,33 @@ Tricks ------ This section is a compendium of a various useful tricks for debugging, configuring and generally getting the most out of Megatest. + +Limiting your running jobs +-------------------------- + +The following example will limit a test in the jobgroup "group1" to no more than 10 tests simultaneously. + +In your testconfig: + +---------------- +[test_meta] +jobgroup group1 +---------------- + +In your megatest.config: + +--------------- +[jobgroups] +group1 10 +custdes 4 +--------------- + + + Debugging Tricks ---------------- Examining The Environment @@ -17,11 +40,11 @@ During Config File Processing ^^^^^^^^^^^^^^^^^^^^^^^^^^^^^ Organising Your Tests and Tasks ^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^ -/nfs/ch/disks/ch_unienv_disk005/qa_mrwellan/interim/src/megatest/tests/fdktestqa/testqa + ---------------------------- [tests-paths] 1 #{get misc parent}/simplerun/tests ---------------------------- @@ -34,15 +57,13 @@ ------------------- runscript main.csh ------------------- - -ww30.2 -cellname/LVS/cellname.LAYOUT_ERRORS - -Error: text open - -ww31.3 -cellname/LVS/cellname.LAYOUT_ERRORS - -Error: text open +Debugging Server Problems +~~~~~~~~~~~~~~~~~~~~~~~~~ + +---------------- +sudo lsof -i +sudo netstat -lptu +sudo netstat -tulpn +---------------- Index: docs/manual/megatest_manual.html ================================================================== --- docs/manual/megatest_manual.html +++ docs/manual/megatest_manual.html @@ -1,1424 +1,1196 @@ - - - - - -The Megatest Users Manual - - - - - -
-
-

Preface

-
-

This book is organised as three sub-books; getting started, writing tests and reference.

-
-

Why Megatest?

-

The Megatest project was started for two reasons, the first was an -immediate and pressing need for a generalized tool to manage a suite -of regression tests and the second was the fact that the author had -written or maintained several such tools at different companies over -the years and it seemed a good thing to have a single open source -tool, flexible enough to meet the needs of any team doing continuous -integrating and or running a complex suite of tests for release -qualification.

-
-
-

Megatest Design Philosophy

-

Megatest is intended to provide the minimum needed resources to make -writing a suite of tests and tasks for implementing continuous build -for software, design engineering or process control (via owlfs for -example) without being specialized for any specific problem -space. Megatest in of itself does not know what constitutes a PASS or -FAIL of a test. In most cases megatest is best used in conjunction -with logpro or a similar tool to parse, analyze and decide on the test -outcome.

-
-
-

Megatest Architecture

-

All data to specify the tests and configure the system is stored in -plain text files. All system state is stored in an sqlite3 -database. Tests are launched using the launching system available for -the distributed compute platform in use. A template script is provided -which can launch jobs on local and remote Linux hosts. Currently -megatest uses the network filesystem to call home to your master -sqlite3 database.

-
-
-
-

Road Map

-

Note: This road-map is tentative and subject to change without notice.

-
-

ww32

-
    -
  1. -

    -Rerun step and or subsequent steps from gui -

    -
    2. -
  2. -

    -Refresh test area files from gui -

    -
    3. -
  3. -

    -Clean and re-run button -

    -
    4. -
  4. -

    -Clean up STATE and STATUS handling. -

    -
      -
    1. -

      -Dashboard and Test control panel are reverse order - choose and fix -

      -
      2. -
    2. -

      -Move seldom used states and status to drop down selector -

      -
      3. -
    -
    5. -
  5. -

    -Access test control panel when clicking on Run Summary tests -

    -
    6. -
  6. -

    -Feature: -generate-index-tree -

    -
    7. -
  7. -

    -Change specifing of state and status to use STATE1/STATUS1,STATE2/STATUS2 -

    -
    8. -
-
-
-

ww33

-
    -
  1. -

    -http api available for use with Perl, Ruby etc. scripts -

    -
    2. -
  2. -

    -megatest.config setup entries for: -

    -
      -
    1. -

      -run launching (e.g. /bin/sh %CMD% > /dev/null) -

      -
      2. -
    2. -

      -browser "konqueror %FNAME% -

      -
      3. -
    -
    3. -
-
-
-

ww34

-
    -
  1. -

    -Mark dependent tests for clean/rerun -rerun-downstream -

    -
    2. -
  2. -

    -On run start check for defunct tests in RUNNING, LAUNCHED or REMOTEHOSTSTART and correct or notify -

    -
    3. -
  3. -

    -Fix: refresh of gui sometimes fails on last item (race condition?) -

    -
    4. -
-
-
-

ww35

-
    -
  1. -

    -refdb: Add export of csv, json and sexp -

    -
    2. -
  2. -

    -Convert to using call-with-environment-variables where possible. Should allow handling of parallel runs in same process. -

    -
    3. -
  3. -

    -Re-work text interface wizards. Several bugs on record. Possibly convert to gui based. -

    -
    4. -
  4. -

    -Add to testconfig requirements section; launchlimiter scriptname, calls scriptname to check if ok to launch test -

    -
    5. -
  5. -

    -Refactor Run Summary view, currently very clumsy -

    -
    6. -
  6. -

    -Add option to show steps in Run Summary view -

    -
    7. -
-
-
-

ww36

-
    -
  1. -

    -Refactor guis for resizeablity -

    -
    2. -
  2. -

    -Add filters to Run Summary view and Run Control view -

    -
    3. -
  3. -

    -Add to megatest.config or testconfig; rerunok STATE/STATUS,STATE/STATUS… -

    -
    4. -
  4. -

    -Launch gates for diskspace; /path/one>1G,/path/two>200M,/tmp>5G,#{scheme toppath}>1G -

    -
    5. -
-
-
-

Bin List

-
    -
  1. -

    -Quality improvements -

    -
      -
    1. -

      -Server stutters occasionally -

      -
      2. -
    2. -

      -Large number of items or tests still has some issues. -

      -
      3. -
    3. -

      -Code refactoring -

      -
      4. -
    4. -

      -Replace remote process with true API using json (supports Web app also) -

      -
      5. -
    -
    2. -
  2. -

    -Streamline the gui -

    -
      -
    1. -

      -Everything resizable -

      -
      2. -
    2. -

      -Less clutter -

      -
      3. -
    3. -

      -Tool tips -

      -
      4. -
    4. -

      -Filters on Run Summary, Summary and Run Control panel -

      -
      5. -
    5. -

      -Built in log viewer (partially implemented) -

      -
      6. -
    6. -

      -Refactor the test control panel -

      -
      7. -
    -
    3. -
  3. -

    -Help and documentation -

    -
      -
    1. -

      -Complete the user manual (I’ve been working on this lately). -

      -
      2. -
    2. -

      -Online help in the gui -

      -
      3. -
    -
    4. -
  4. -

    -Streamlined install -

    -
      -
    1. -

      -Deployed version (download a location independent ready to run binary bundle) -

      -
      2. -
    2. -

      -Install Makefile (in progress, needed for Mike to install on VMs) -

      -
      3. -
    3. -

      -Added option to compile IUP (needed for VMs) -

      -
      4. -
    -
    5. -
  5. -

    -Server side run launching -

    -
    6. -
  6. -

    -Support for re-running, cleaning etc. of individual steps (ezsteps makes this very easy to implement). -

    -
    7. -
  7. -

    -Launch process needs built in daemonizing (easy to do, just need to test it thoroughly). -

    -
    8. -
  8. -

    -Wizards for creating tests, regression areas (current ones are text only and limited). -

    -
    9. -
  9. -

    -Fully functional built in web service (currently you can browse runs but it is very simplistic). -

    -
    10. -
  10. -

    -Wildcards in runconfigs: e.g. [p1271/9/%/%] -

    -
    11. -
  11. -

    -Gui panels for editing megatest.config and runconfigs.config -

    -
    12. -
  12. -

    -Fully isolated tests (no use of NFS to see regression area files) -

    -
    13. -
  13. -

    -Windows version -

    -
    14. -
-
-

Getting Started

-
-
Getting started with Megatest
-
-

How to install Megatest and set it up for running your regressions and continuous integration process.

-
-
-

Installation

-
-
-

Dependencies

-

Chicken scheme and a number of "eggs" are required for building -Megatest. See the script installall.sch in the utils directory of the -distribution for a mostly automated way to install everything needed -for building Megatest on Linux.

-


[An example footnote.]

-

And now for something completely different: monkeys, lions and -tigers (Bengal and Siberian) using the alternative syntax index -entries. - - - -Note that multi-entry terms generate separate index entries.

-

Here are a couple of image examples: an -images/smallnew.png - -example inline image followed by an example block image:

-
-
-Tiger image -
-
Figure 1. Tiger block image
-
-

Followed by an example table:

-
- - --- - - - - - - - - - - - - - - - -
Table 1. An example table
Option Description

-a USER GROUP

Add USER to GROUP.

-R GROUP

Disables access to GROUP.

-
-
-
Example 1. An example example
-
-

Lorum ipum…

-
-
-
-

Sub-section with Anchor

-

Sub-section at level 2.

-
-

Chapter Sub-section

-

Sub-section at level 3.

-
-
Chapter Sub-section
-

Sub-section at level 4.

-

This is the maximum sub-section depth supported by the distributed -AsciiDoc configuration. -
[A second example footnote.]

-
-
-
-
-
-
-

The Second Chapter

-
-

An example link to anchor at start of the first sub-section.

-

An example link to a bibliography entry [taoup].

-
-
-

Writing Tests

-
-

The First Chapter of the Second Part

-
-

Chapters grouped into book parts are at level 1 and can contain -sub-sections.

-
-
-

Reference

-
-

The First Chapter of the Second Part

-
-

Chapters grouped into book parts are at level 1 and can contain -sub-sections.

-
-
-
-

The testconfig File

-
-
-

Setup section

-
-

Header

-
-
-
[setup]
-
-

The runscript method is a brute force way to run scripts where the -user is responsible for setting STATE and STATUS

-
-
-
runscript main.csh
-
-
-
-
-

Requirements section

-
-

Header

-
-
-
[requirements]
-
-
-
-

Wait on Other Tests

-
-
-
# A normal waiton waits for the prior tests to be COMPLETED
-# and PASS, CHECK or WAIVED
-waiton test1 test2
-
-
-
-

Mode

-

The default (i.e. if mode is not specified) is normal. All pre-dependent tests -must be COMPLETED and PASS, CHECK or WAIVED before the test will start

-
-
-
mode   normal
-
-

The toplevel mode requires only that the prior tests are COMPLETED.

-
-
-
mode toplevel
-
-

A item based waiton will start items in a test when the -same-named item is COMPLETED and PASS, CHECK or WAIVED -in the prior test

-
-
-
mode itemmatch
-
-
-
-
# With a toplevel test you may wish to generate your list
-# of tests to run dynamically
-#
-# waiton #{shell get-valid-tests-to-run.sh}
-
-
-
-

Run time limit

-
-
-
runtimelim 1h 2m 3s  # this will automatically kill the test if it runs for more than 1h 2m and 3s
-
-
-
-

Skip

-
-
-

Header

-
-
-
[skip]
-
-
-
-

Skip on Still-running Tests

-
-
-
# NB// If the prevrunning line exists with *any* value the test will
-# automatically SKIP if the same-named test is currently RUNNING
-
-prevrunning x
-
-
-
-

Skip if a File Exists

-
-
-
fileexists /path/to/a/file # skip if /path/to/a/file exists
-
-
-
-

Controlled waiver propagation

-

If test is FAIL and previous test in run with same MT_TARGET is WAIVED then apply the following rules from the testconfig: -If a waiver check is specified in the testconfig apply the check and if it passes then set this FAIL to WAIVED

-

Waiver check has two parts, 1) a list of waiver, rulename, filepatterns and 2) the rulename script spec (note that "diff" and "logpro" are predefined)

-
-
-
###### EXAMPLE FROM testconfig #########
-# matching file(s) will be diff'd with previous run and logpro applied
-# if PASS or WARN result from logpro then WAIVER state is set
-#
-[waivers]
-# logpro_file    rulename      input_glob
-waiver_1         logpro        lookittmp.log
-
-[waiver_rules]
-
-# This builtin rule is the default if there is no <waivername>.logpro file
-# diff   diff %file1% %file2%
-
-# This builtin rule is applied if a <waivername>.logpro file exists
-# logpro diff %file1% %file2% | logpro %waivername%.logpro %waivername%.html
-
-
-
-
-

Ezsteps

-

To transfer the environment to the next step you can do the following:

-
-
-
$MT_MEGATEST -env2file .ezsteps/${stepname}
-
-
-
-
-
-

Appendix A: Example Appendix

-
-

One or more optional appendixes go here at section level zero.

-
-

Appendix Sub-section

-
- - - -
-
Note
-		Preface and appendix subsections start out of sequence at level -2 (level 1 is skipped). This only applies to multi-part book -documents.
-
-
-
-
-
-

Example Bibliography

-
-

The bibliography list is a style of AsciiDoc bulleted list.

-
    -
  • -

    -[taoup] Eric Steven Raymond. The Art of Unix - Programming. Addison-Wesley. ISBN 0-13-142901-9. -

    -
    • -
  • -

    -[walsh-muellner] Norman Walsh & Leonard Muellner. - DocBook - The Definitive Guide. O’Reilly & Associates. 1999. - ISBN 1-56592-580-7. -

    -
    • -
-
-
-
-

Example Glossary

-
-

Glossaries are optional. Glossaries entries are an example of a style -of AsciiDoc labeled lists.

-
-
-A glossary term -
-
-

- The corresponding (indented) definition. -

-
-
-A second glossary term -
-
-

- The corresponding (indented) definition. -

-
-
-
-
-
-

Example Colophon

-
-

Text at the end of a book describing facts about its production.

-
-
-
-

Example Index

-
-
-
-
-
- - - + + + + + +The Megatest Users Manual + + + + + +
+
+

Preface

+
+

This book is organised as three sub-books; getting started, writing tests and reference.

+
+

Why Megatest?

+

The Megatest project was started for two reasons, the first was an +immediate and pressing need for a generalized tool to manage a suite +of regression tests and the second was the fact that the author had +written or maintained several such tools at different companies over +the years and it seemed a good thing to have a single open source +tool, flexible enough to meet the needs of any team doing continuous +integrating and or running a complex suite of tests for release +qualification.

+
+
+

Megatest Design Philosophy

+

Megatest is intended to provide the minimum needed resources to make +writing a suite of tests and tasks for implementing continuous build +for software, design engineering or process control (via owlfs for +example) without being specialized for any specific problem +space. Megatest in of itself does not know what constitutes a PASS or +FAIL of a test. In most cases megatest is best used in conjunction +with logpro or a similar tool to parse, analyze and decide on the test +outcome.

+
+
+

Megatest Architecture

+

All data to specify the tests and configure the system is stored in +plain text files. All system state is stored in an sqlite3 +database. Tests are launched using the launching system available for +the distributed compute platform in use. A template script is provided +which can launch jobs on local and remote Linux hosts. Currently +megatest uses the network filesystem to call home to your master +sqlite3 database.

+
+
+
+

Road Map

+

Note 1: This road-map is tentative and subject to change without notice.

+

Note 2: Starting over. Old plan is commented out.

+
+

Current Items

+
+
+

ww05 - migrate to inmem-db

+

Keep as much the same as possible. Add internal reference to almost +eliminate contention on db(s).

+
    +
  1. +

    +Add internal reference db +

    +
    2. +
  2. +

    +Verify that actions are accessing correct db +

    +
      +
    1. +

      +-runtests - inmem +

      +
      2. +
    2. +

      +-list-runs - local (but not megatest.db) +

      +
      3. +
    3. +

      +dashboard - local (but not megatest.db) +

      +
      4. +
    +
    3. +
  3. +

    +Mirror db to /var/tmp… +

    +
    4. +
  4. +

    +Dashboard read db from per-run db. +

    +
    5. +
  5. +

    +Dashboard read db from /var/tmp +

    +
    6. +
  6. +

    +Runs register in tasks table in monitor.db +

    +
    7. +
  7. +

    +Server polls tasks table for next action (in addition?) +

    +
    8. +
  8. +

    +Change run loop to execute in server, triggered by call to polling of tasks table +

    +
    9. +
+
+
+
+

Getting Started

+
+
Getting started with Megatest
+
+

How to install Megatest and set it up for running your regressions and continuous integration process.

+
+
+

Installation

+
+
+

Dependencies

+

Chicken scheme and a number of "eggs" are required for building +Megatest. See the script installall.sch in the utils directory of the +distribution for a mostly automated way to install everything needed +for building Megatest on Linux.

+


[An example footnote.]

+

And now for something completely different: monkeys, lions and +tigers (Bengal and Siberian) using the alternative syntax index +entries. + + + +Note that multi-entry terms generate separate index entries.

+

Here are a couple of image examples: an +images/smallnew.png + +example inline image followed by an example block image:

+
+
+Tiger image +
+
Figure 1. Tiger block image
+
+

Followed by an example table:

+
+ + +++ + + + + + + + + + + + + + + + +
Table 1. An example table
Option Description

-a USER GROUP

Add USER to GROUP.

-R GROUP

Disables access to GROUP.

+
+
+
Example 1. An example example
+
+

Lorum ipum…

+
+
+
+

Sub-section with Anchor

+

Sub-section at level 2.

+
+

Chapter Sub-section

+

Sub-section at level 3.

+
+
Chapter Sub-section
+

Sub-section at level 4.

+

This is the maximum sub-section depth supported by the distributed +AsciiDoc configuration. +
[A second example footnote.]

+
+
+
+
+
+
+

The Second Chapter

+
+

An example link to anchor at start of the first sub-section.

+

An example link to a bibliography entry [taoup].

+
+
+

Writing Tests

+
+

The First Chapter of the Second Part

+
+

Chapters grouped into book parts are at level 1 and can contain +sub-sections.

+
+
+

How To Do Things

+
+

Tricks

+
+

This section is a compendium of a various useful tricks for debugging, +configuring and generally getting the most out of Megatest.

+
+
+
+

Debugging Tricks

+
+
+

Examining The Environment

+
+

During Config File Processing

+
+
+

Organising Your Tests and Tasks

+
+
+
[tests-paths]
+1 #{get misc parent}/simplerun/tests
+
+
+
+
[setup]
+
+

The runscript method is a brute force way to run scripts where the +user is responsible for setting STATE and STATUS

+
+
+
runscript main.csh
+
+
+
+
+
+
+

Tricks

+
+

This section is a compendium of a various useful tricks for debugging, +configuring and generally getting the most out of Megatest.

+
+
+
+

Debugging Tricks

+
+
+

Examining The Environment

+
+

During Config File Processing

+
+
+

Organising Your Tests and Tasks

+

/nfs/ch/disks/ch_unienv_disk005/qa_mrwellan/interim/src/megatest/tests/fdktestqa/testqa

+
+
+
[tests-paths]
+1 #{get misc parent}/simplerun/tests
+
+
+
+
[setup]
+
+

The runscript method is a brute force way to run scripts where the +user is responsible for setting STATE and STATUS

+
+
+
runscript main.csh
+
+

ww30.2 +cellname/LVS/cellname.LAYOUT_ERRORS

+

Error: text open

+

ww31.3 +cellname/LVS/cellname.LAYOUT_ERRORS

+

Error: text open +Reference

+
+
+

Chapters grouped into book parts are at level 1 and can contain +sub-sections.

+
+
+
[setup]
+
+

The runscript method is a brute force way to run scripts where the +user is responsible for setting STATE and STATUS

+
+
+
runscript main.csh
+
+
+
+
[requirements]
+
+
+
+
# A normal waiton waits for the prior tests to be COMPLETED
+# and PASS, CHECK or WAIVED
+waiton test1 test2
+
+

The default (i.e. if mode is not specified) is normal. All pre-dependent tests +must be COMPLETED and PASS, CHECK or WAIVED before the test will start

+
+
+
mode   normal
+
+

The toplevel mode requires only that the prior tests are COMPLETED.

+
+
+
mode toplevel
+
+

A item based waiton will start items in a test when the +same-named item is COMPLETED and PASS, CHECK or WAIVED +in the prior test

+
+
+
mode itemmatch
+
+
+
+
# With a toplevel test you may wish to generate your list
+# of tests to run dynamically
+#
+# waiton #{shell get-valid-tests-to-run.sh}
+
+
+
+
runtimelim 1h 2m 3s  # this will automatically kill the test if it runs for more than 1h 2m and 3s
+
+
+
+
[skip]
+
+
+
+
# NB// If the prevrunning line exists with *any* value the test will
+# automatically SKIP if the same-named test is currently RUNNING
+
+prevrunning x
+
+
+
+
fileexists /path/to/a/file # skip if /path/to/a/file exists
+
+

If test is FAIL and previous test in run with same MT_TARGET is WAIVED then apply the following rules from the testconfig: +If a waiver check is specified in the testconfig apply the check and if it passes then set this FAIL to WAIVED

+

Waiver check has two parts, 1) a list of waiver, rulename, filepatterns and 2) the rulename script spec (note that "diff" and "logpro" are predefined)

+
+
+
###### EXAMPLE FROM testconfig #########
+# matching file(s) will be diff'd with previous run and logpro applied
+# if PASS or WARN result from logpro then WAIVER state is set
+#
+[waivers]
+# logpro_file    rulename      input_glob
+waiver_1         logpro        lookittmp.log
+
+[waiver_rules]
+
+# This builtin rule is the default if there is no <waivername>.logpro file
+# diff   diff %file1% %file2%
+
+# This builtin rule is applied if a <waivername>.logpro file exists
+# logpro diff %file1% %file2% | logpro %waivername%.logpro %waivername%.html
+
+

To transfer the environment to the next step you can do the following:

+
+
+
$MT_MEGATEST -env2file .ezsteps/${stepname}
+
+
+

Megatest Internals

+
+
+server.png +
+
+
+

One or more optional appendixes go here at section level zero.

+
+ + + +
+
Note
+		Preface and appendix subsections start out of sequence at level +2 (level 1 is skipped). This only applies to multi-part book +documents.
+
+

The bibliography list is a style of AsciiDoc bulleted list.

+
    +
  • +

    +[taoup] Eric Steven Raymond. The Art of Unix + Programming. Addison-Wesley. ISBN 0-13-142901-9. +

    +
    • +
  • +

    +[walsh-muellner] Norman Walsh & Leonard Muellner. + DocBook - The Definitive Guide. O’Reilly & Associates. 1999. + ISBN 1-56592-580-7. +

    +
    • +
+

Glossaries are optional. Glossaries entries are an example of a style +of AsciiDoc labeled lists.

+
+
+A glossary term +
+
+

+ The corresponding (indented) definition. +

+
+
+A second glossary term +
+
+

+ The corresponding (indented) definition. +

+
+
+

Text at the end of a book describing facts about its production.

+
+
+
+
+
+
+
+ + + Index: docs/manual/megatest_manual.txt ================================================================== --- docs/manual/megatest_manual.txt +++ docs/manual/megatest_manual.txt @@ -48,10 +48,19 @@ include::../plan.txt[] include::getting_started.txt[] include::writing_tests.txt[] include::howto.txt[] include::reference.txt[] + +Megatest Internals +~~~~~~~~~~~~~~~~~~ + +["graphviz", "server.png"] +---------------------------------------------------------------------- +include::server.dot[] +---------------------------------------------------------------------- + [appendix] Example Appendix ================ One or more optional appendixes go here at section level zero. Index: docs/manual/reference.txt ================================================================== --- docs/manual/reference.txt +++ docs/manual/reference.txt @@ -2,10 +2,11 @@ Reference ========= The First Chapter of the Second Part ------------------------------------ + Chapters grouped into book parts are at level 1 and can contain sub-sections. The testconfig File ------------------- ADDED docs/manual/server.dot Index: docs/manual/server.dot ================================================================== --- /dev/null +++ docs/manual/server.dot @@ -0,0 +1,62 @@ +digraph G { + + subgraph cluster_1 { + node [style=filled,shape=box]; + + check_available_queue -> remove_entries_over_10s_old; + remove_entries_over_10s_old -> set_available [label="num_avail < 3"]; + remove_entries_over_10s_old -> exit [label="num_avail > 2"]; + + set_available -> delay_2s; + delay_2s -> check_place_in_queue; + + check_place_in_queue -> "http:transport-launch" [label="at head"]; + check_place_in_queue -> exit [label="not at head"]; + + "client:login" -> "server:shutdown" [label="login failed"]; + "server:shutdown" -> exit; + + subgraph cluster_2 { + "http:transport-launch" -> "http:transport-run"; + "http:transport-launch" -> "http:transport-keep-running"; + + "http:transport-keep-running" -> "tests running?"; + "tests running?" -> "client:login" [label=yes]; + "tests running?" -> "server:shutdown" [label=no]; + "client:login" -> delay_5s [label="login ok"]; + delay_5s -> "http:transport-keep-running"; + } + + // start_server -> "server_running?"; + // "server_running?" -> set_available [label="no"]; + // "server_running?" -> delay_2s [label="yes"]; + // delay_2s -> "still_running?"; + // "still_running?" -> ping_server [label=yes]; + // "still_running?" -> set_available [label=no]; + // ping_server -> exit [label=alive]; + // ping_server -> remove_server_record [label=dead]; + // remove_server_record -> set_available; + // set_available -> avail_delay [label="delay 3s"]; + // avail_delay -> "first_in_queue?"; + // + // "first_in_queue?" -> set_running [label=yes]; + // set_running -> get_next_port -> handle_requests; + // "first_in_queue?" -> "dead_entry_in_queue?" [label=no]; + // "dead_entry_in_queue?" -> "server_running?" [label=no]; + // "dead_entry_in_queue?" -> "remove_dead_entries" [label=yes]; + // remove_dead_entries -> "server_running?"; + // + // handle_requests -> start_shutdown [label="no traffic\nno running tests"]; + // handle_requests -> shutdown_request; + // start_shutdown -> shutdown_delay; + // shutdown_request -> shutdown_delay; + // shutdown_delay -> exit; + + label = "server:launch"; + color=brown; + } + +// client_start_server -> start_server; +// handle_requests -> read_write; +// read_write -> handle_requests; +} ADDED docs/manual/server.pdf Index: docs/manual/server.pdf ================================================================== --- /dev/null +++ docs/manual/server.pdf cannot compute difference between binary files ADDED docs/manual/server.png Index: docs/manual/server.png ================================================================== --- /dev/null +++ docs/manual/server.png cannot compute difference between binary files ADDED docs/megatest-state-status.dot Index: docs/megatest-state-status.dot ================================================================== --- /dev/null +++ docs/megatest-state-status.dot @@ -0,0 +1,47 @@ +digraph megatest_state_status { + ranksep=0.05 + // rankdir=LR + +node [shape=box,style=filled]; + +// subgraph cluster_notstarted { +// label="Not started"; + + "NOT_STARTED FAILS" [ + label = "{ NOT_STARTED/FAILS |{ NO_ITEMS | FAIL_PREREQ | FAIL_TIMEOUT }}"; + shape= "record"; + ] + +"NOT_STARTED n/a" -> "LAUNCHED n/a" [label=" launch"]; +"NOT_STARTED WAIT" -> "LAUNCHED n/a" + + "NOT_STARTED n/a"; + "NOT_STARTED WAIT" [ + label = "{NOT_STARTED WAIT|{ NO_SLOTS | WAIT_PREREQ}}"; + shape = "record"; +] + +// struct3 [shape=record,label="hello\nworld |{ b |{c| d|e}| f}| g | h"]; + + "NOT_STARTED n/a" -> "NOT_STARTED FAILS"; + "NOT_STARTED n/a" -> "NOT_STARTED WAIT"; + + "RUNNING" [ + shape="record"; + label="{RUNNING|{n/a| PASS | FAIL}}"; + ] + + "COMPLETED" [ + shape="record"; + label = "{COMPLETED|{PASS | FAIL | CHECK| SKIP}}"; + ] + + +"RUNNING" -> "COMPLETED"; +"RUNNING" -> "INCOMPLETE" [label="test dead for > 24hrs"]; + + +"LAUNCHED n/a" -> "REMOTEHOSTSTART n/a" -> "RUNNING"; + +} + Index: docs/megatest-training.odp ================================================================== --- docs/megatest-training.odp +++ docs/megatest-training.odp cannot compute difference between binary files Index: docs/megatest-training.pdf ================================================================== --- docs/megatest-training.pdf +++ docs/megatest-training.pdf cannot compute difference between binary files Index: docs/plan.txt ================================================================== --- docs/plan.txt +++ docs/plan.txt @@ -1,83 +1,107 @@ Road Map ======== -Note: This road-map is tentative and subject to change without notice. - -ww32 -~~~~ - -. Rerun step and or subsequent steps from gui -. Refresh test area files from gui -. Clean and re-run button -. Clean up STATE and STATUS handling. -.. Dashboard and Test control panel are reverse order - choose and fix -.. Move seldom used states and status to drop down selector -. Access test control panel when clicking on Run Summary tests -. Feature: -generate-index-tree -. Change specifing of state and status to use STATE1/STATUS1,STATE2/STATUS2 - -ww33 -~~~~ - -. http api available for use with Perl, Ruby etc. scripts -. megatest.config setup entries for: -.. run launching (e.g. /bin/sh %CMD% > /dev/null) -.. browser "konqueror %FNAME% - -ww34 -~~~~ - -. Mark dependent tests for clean/rerun -rerun-downstream -. On run start check for defunct tests in RUNNING, LAUNCHED or REMOTEHOSTSTART and correct or notify -. Fix: refresh of gui sometimes fails on last item (race condition?) - -ww35 -~~~~ - -. refdb: Add export of csv, json and sexp -. Convert to using call-with-environment-variables where possible. Should allow handling of parallel runs in same process. -. Re-work text interface wizards. Several bugs on record. Possibly convert to gui based. -. Add to testconfig requirements section; launchlimiter scriptname, calls scriptname to check if ok to launch test -. Refactor Run Summary view, currently very clumsy -. Add option to show steps in Run Summary view - -ww36 -~~~~ - -. Refactor guis for resizeablity -. Add filters to Run Summary view and Run Control view -. Add to megatest.config or testconfig; rerunok STATE/STATUS,STATE/STATUS... -. Launch gates for diskspace; /path/one>1G,/path/two>200M,/tmp>5G,#{scheme *toppath*}>1G - -Bin List -~~~~~~~~ - -. Quality improvements -.. Server stutters occasionally -.. Large number of items or tests still has some issues. -.. Code refactoring -.. Replace remote process with true API using json (supports Web app also) -. Streamline the gui -.. Everything resizable -.. Less clutter -.. Tool tips -.. Filters on Run Summary, Summary and Run Control panel -.. Built in log viewer (partially implemented) -.. Refactor the test control panel -. Help and documentation -.. Complete the user manual (I’ve been working on this lately). -.. Online help in the gui -. Streamlined install -.. Deployed version (download a location independent ready to run binary bundle) -.. Install Makefile (in progress, needed for Mike to install on VMs) -.. Added option to compile IUP (needed for VMs) -. Server side run launching -. Support for re-running, cleaning etc. of individual steps (ezsteps makes this very easy to implement). -. Launch process needs built in daemonizing (easy to do, just need to test it thoroughly). -. Wizards for creating tests, regression areas (current ones are text only and limited). -. Fully functional built in web service (currently you can browse runs but it is very simplistic). -. Wildcards in runconfigs: e.g. [p1271/9/%/%] -. Gui panels for editing megatest.config and runconfigs.config -. Fully isolated tests (no use of NFS to see regression area files) -. Windows version +Note 1: This road-map is tentative and subject to change without notice. + +Note 2: Starting over. Old plan is commented out. + +Current Items +------------- + +ww05 - migrate to inmem-db +~~~~~~~~~~~~~~~~~~~~~~~~~~ + +Keep as much the same as possible. Add internal reference to almost +eliminate contention on db(s). + +. Add internal reference db +. Verify that actions are accessing correct db +.. -runtests - inmem +.. -list-runs - local (but not megatest.db) +.. dashboard - local (but not megatest.db) +. Mirror db to /var/tmp... +. Dashboard read db from per-run db. +. Dashboard read db from /var/tmp +. Runs register in tasks table in monitor.db +. Server polls tasks table for next action (in addition?) +. Change run loop to execute in server, triggered by call to polling of tasks table + + +// ww32 +// ~~~~ +// +// . Rerun step and or subsequent steps from gui +// . Refresh test area files from gui +// . Clean and re-run button +// . Clean up STATE and STATUS handling. +// .. Dashboard and Test control panel are reverse order - choose and fix +// .. Move seldom used states and status to drop down selector +// . Access test control panel when clicking on Run Summary tests +// . Feature: -generate-index-tree +// . Change specifing of state and status to use STATE1/STATUS1,STATE2/STATUS2 +// +// ww33 +// ~~~~ +// +// . http api available for use with Perl, Ruby etc. scripts +// . megatest.config setup entries for: +// .. run launching (e.g. /bin/sh %CMD% > /dev/null) +// .. browser "konqueror %FNAME% +// +// ww34 +// ~~~~ +// +// . Mark dependent tests for clean/rerun -rerun-downstream +// . On run start check for defunct tests in RUNNING, LAUNCHED or REMOTEHOSTSTART and correct or notify +// . Fix: refresh of gui sometimes fails on last item (race condition?) +// +// ww35 +// ~~~~ +// +// . refdb: Add export of csv, json and sexp +// . Convert to using call-with-environment-variables where possible. Should allow handling of parallel runs in same process. +// . Re-work text interface wizards. Several bugs on record. Possibly convert to gui based. +// . Add to testconfig requirements section; launchlimiter scriptname, calls scriptname to check if ok to launch test +// . Refactor Run Summary view, currently very clumsy +// . Add option to show steps in Run Summary view +// +// ww36 +// ~~~~ +// +// . Refactor guis for resizeablity +// . Add filters to Run Summary view and Run Control view +// . Add to megatest.config or testconfig; rerunok STATE/STATUS,STATE/STATUS... +// . Launch gates for diskspace; /path/one>1G,/path/two>200M,/tmp>5G,#{scheme *toppath*}>1G +// +// Bin List +// ~~~~~~~~ +// +// . Quality improvements +// .. Server stutters occasionally +// .. Large number of items or tests still has some issues. +// .. Code refactoring +// .. Replace remote process with true API using json (supports Web app also) +// . Streamline the gui +// .. Everything resizable +// .. Less clutter +// .. Tool tips +// .. Filters on Run Summary, Summary and Run Control panel +// .. Built in log viewer (partially implemented) +// .. Refactor the test control panel +// . Help and documentation +// .. Complete the user manual (I’ve been working on this lately). +// .. Online help in the gui +// . Streamlined install +// .. Deployed version (download a location independent ready to run binary bundle) +// .. Install Makefile (in progress, needed for Mike to install on VMs) +// .. Added option to compile IUP (needed for VMs) +// . Server side run launching +// . Support for re-running, cleaning etc. of individual steps (ezsteps makes this very easy to implement). +// . Launch process needs built in daemonizing (easy to do, just need to test it thoroughly). +// . Wizards for creating tests, regression areas (current ones are text only and limited). +// . Fully functional built in web service (currently you can browse runs but it is very simplistic). +// . Wildcards in runconfigs: e.g. [p1271/9/%/%] +// . Gui panels for editing megatest.config and runconfigs.config +// . Fully isolated tests (no use of NFS to see regression area files) +// . Windows version ADDED docs/results.pdf Index: docs/results.pdf ================================================================== --- /dev/null +++ docs/results.pdf cannot compute difference between binary files ADDED example/cfg/machines.dat Index: example/cfg/machines.dat ================================================================== --- /dev/null +++ example/cfg/machines.dat @@ -0,0 +1,16 @@ +[] +[maxload] +zeus 0.40000000000000002 +xena 0.20000000000000001 +myth2 0.01 +hades 1 +[minfree] +zeus 1000 +xena 20000 +myth2 300000 +hades 4000000 +[reqprocs] +zeus mfsmount mythbackend mfschunkserver +xena mfsmount +myth2 mfsmount mythfrontend mfschunkserver +hades mfsmount mfsmetalogger mfschunkserver ADDED example/cfg/sheet-names.cfg Index: example/cfg/sheet-names.cfg ================================================================== --- /dev/null +++ example/cfg/sheet-names.cfg @@ -0,0 +1,1 @@ +machines ADDED example/cfg/sxml/_sheets.sxml Index: example/cfg/sxml/_sheets.sxml ================================================================== --- /dev/null +++ example/cfg/sxml/_sheets.sxml @@ -0,0 +1,47 @@ +((@ (http://www.w3.org/2001/XMLSchema-instance:schemaLocation + "http://www.gnumeric.org/v9.xsd")) + (http://www.gnumeric.org/v10.dtd:Version + (@ (Minor "17") (Major "10") (Full "1.10.17") (Epoch "1"))) + (http://www.gnumeric.org/v10.dtd:Attributes + (http://www.gnumeric.org/v10.dtd:Attribute + (http://www.gnumeric.org/v10.dtd:type "4") + (http://www.gnumeric.org/v10.dtd:name + "WorkbookView::show_horizontal_scrollbar") + (http://www.gnumeric.org/v10.dtd:value "TRUE")) + (http://www.gnumeric.org/v10.dtd:Attribute + (http://www.gnumeric.org/v10.dtd:type "4") + (http://www.gnumeric.org/v10.dtd:name + "WorkbookView::show_vertical_scrollbar") + (http://www.gnumeric.org/v10.dtd:value "TRUE")) + (http://www.gnumeric.org/v10.dtd:Attribute + (http://www.gnumeric.org/v10.dtd:type "4") + (http://www.gnumeric.org/v10.dtd:name "WorkbookView::show_notebook_tabs") + (http://www.gnumeric.org/v10.dtd:value "TRUE")) + (http://www.gnumeric.org/v10.dtd:Attribute + (http://www.gnumeric.org/v10.dtd:type "4") + (http://www.gnumeric.org/v10.dtd:name "WorkbookView::do_auto_completion") + (http://www.gnumeric.org/v10.dtd:value "TRUE")) + (http://www.gnumeric.org/v10.dtd:Attribute + (http://www.gnumeric.org/v10.dtd:type "4") + (http://www.gnumeric.org/v10.dtd:name "WorkbookView::is_protected") + (http://www.gnumeric.org/v10.dtd:value "FALSE"))) + (urn:oasis:names:tc:opendocument:xmlns:office:1.0:document-meta + (@ (urn:oasis:names:tc:opendocument:xmlns:office:1.0:version "1.2")) + (urn:oasis:names:tc:opendocument:xmlns:office:1.0:meta + (http://purl.org/dc/elements/1.1/:date "2014-02-14T06:16:26Z") + (urn:oasis:names:tc:opendocument:xmlns:meta:1.0:creation-date + "2014-02-14T06:16:17Z"))) + (http://www.gnumeric.org/v10.dtd:Calculation + (@ (MaxIterations "100") + (ManualRecalc "0") + (IterationTolerance "0.001") + (FloatRadix "2") + (FloatDigits "53") + (EnableIteration "1"))) + (http://www.gnumeric.org/v10.dtd:SheetNameIndex + (http://www.gnumeric.org/v10.dtd:SheetName + (@ (http://www.gnumeric.org/v10.dtd:Rows "65536") + (http://www.gnumeric.org/v10.dtd:Cols "256")) + "machines")) + (http://www.gnumeric.org/v10.dtd:Geometry (@ (Width "835") (Height "320"))) + (http://www.gnumeric.org/v10.dtd:UIData (@ (SelectedTab "0")))) ADDED example/cfg/sxml/_workbook.sxml Index: example/cfg/sxml/_workbook.sxml ================================================================== --- /dev/null +++ example/cfg/sxml/_workbook.sxml @@ -0,0 +1,1 @@ +(*TOP* (*PI* xml "version=\"1.0\" encoding=\"UTF-8\"")) ADDED example/cfg/sxml/machines.sxml Index: example/cfg/sxml/machines.sxml ================================================================== --- /dev/null +++ example/cfg/sxml/machines.sxml @@ -0,0 +1,105 @@ +(http://www.gnumeric.org/v10.dtd:Sheet + (@ (Visibility "GNM_SHEET_VISIBILITY_VISIBLE") + (OutlineSymbolsRight "1") + (OutlineSymbolsBelow "1") + (HideZero "0") + (HideRowHeader "0") + (HideGrid "0") + (HideColHeader "0") + (GridColor "0:0:0") + (DisplayOutlines "1") + (DisplayFormulas "0")) + (http://www.gnumeric.org/v10.dtd:MaxCol "3") + (http://www.gnumeric.org/v10.dtd:MaxRow "4") + (http://www.gnumeric.org/v10.dtd:Zoom "1") + (http://www.gnumeric.org/v10.dtd:Names + (http://www.gnumeric.org/v10.dtd:Name + (http://www.gnumeric.org/v10.dtd:name "Print_Area") + (http://www.gnumeric.org/v10.dtd:value "#REF!") + (http://www.gnumeric.org/v10.dtd:position "A1")) + (http://www.gnumeric.org/v10.dtd:Name + (http://www.gnumeric.org/v10.dtd:name "Sheet_Title") + (http://www.gnumeric.org/v10.dtd:value "\"machines\"") + (http://www.gnumeric.org/v10.dtd:position "A1"))) + (http://www.gnumeric.org/v10.dtd:PrintInformation + (http://www.gnumeric.org/v10.dtd:Margins + (http://www.gnumeric.org/v10.dtd:top (@ (PrefUnit "mm") (Points "120"))) + (http://www.gnumeric.org/v10.dtd:bottom + (@ (PrefUnit "mm") (Points "120"))) + (http://www.gnumeric.org/v10.dtd:left (@ (PrefUnit "mm") (Points "72"))) + (http://www.gnumeric.org/v10.dtd:right (@ (PrefUnit "mm") (Points "72"))) + (http://www.gnumeric.org/v10.dtd:header + (@ (PrefUnit "mm") (Points "72"))) + (http://www.gnumeric.org/v10.dtd:footer + (@ (PrefUnit "mm") (Points "72")))) + (http://www.gnumeric.org/v10.dtd:Scale + (@ (type "percentage") (percentage "100"))) + (http://www.gnumeric.org/v10.dtd:vcenter (@ (value "0"))) + (http://www.gnumeric.org/v10.dtd:hcenter (@ (value "0"))) + (http://www.gnumeric.org/v10.dtd:grid (@ (value "0"))) + (http://www.gnumeric.org/v10.dtd:even_if_only_styles (@ (value "0"))) + (http://www.gnumeric.org/v10.dtd:monochrome (@ (value "0"))) + (http://www.gnumeric.org/v10.dtd:draft (@ (value "0"))) + (http://www.gnumeric.org/v10.dtd:titles (@ (value "0"))) + (http://www.gnumeric.org/v10.dtd:do_not_print (@ (value "0"))) + (http://www.gnumeric.org/v10.dtd:print_range (@ (value "0"))) + (http://www.gnumeric.org/v10.dtd:order "d_then_r") + (http://www.gnumeric.org/v10.dtd:orientation "portrait") + (http://www.gnumeric.org/v10.dtd:Header + (@ (Right "") (Middle "&[TAB]") (Left ""))) + (http://www.gnumeric.org/v10.dtd:Footer + (@ (Right "") (Middle "Page &[PAGE]") (Left ""))) + (http://www.gnumeric.org/v10.dtd:paper "na_letter") + (http://www.gnumeric.org/v10.dtd:comments "in_place") + (http://www.gnumeric.org/v10.dtd:errors "as_displayed")) + (http://www.gnumeric.org/v10.dtd:Styles + (http://www.gnumeric.org/v10.dtd:StyleRegion + (@ (startRow "0") (startCol "0") (endRow "65535") (endCol "255")) + (http://www.gnumeric.org/v10.dtd:Style + (@ (WrapText "0") + (VAlign "2") + (ShrinkToFit "0") + (Shade "0") + (Rotation "0") + (PatternColor "0:0:0") + (Locked "1") + (Indent "0") + (Hidden "0") + (HAlign "1") + (Format "General") + (Fore "0:0:0") + (Back "FFFF:FFFF:FFFF")) + (http://www.gnumeric.org/v10.dtd:Font + (@ (Unit "10") + (Underline "0") + (StrikeThrough "0") + (Script "0") + (Italic "0") + (Bold "0")) + "Sans")))) + (http://www.gnumeric.org/v10.dtd:Cols + (@ (DefaultSizePts "48")) + (http://www.gnumeric.org/v10.dtd:ColInfo (@ (Unit "48") (No "0"))) + (http://www.gnumeric.org/v10.dtd:ColInfo + (@ (Unit "52.5") (No "1") (HardSize "1"))) + (http://www.gnumeric.org/v10.dtd:ColInfo (@ (Unit "48") (No "2"))) + (http://www.gnumeric.org/v10.dtd:ColInfo + (@ (Unit "182.2") (No "3") (HardSize "1")))) + (http://www.gnumeric.org/v10.dtd:Rows + (@ (DefaultSizePts "12.75")) + (http://www.gnumeric.org/v10.dtd:RowInfo + (@ (Unit "13.5") (No "0") (Count "5")))) + (http://www.gnumeric.org/v10.dtd:Selections + (@ (CursorRow "4") (CursorCol "0")) + (http://www.gnumeric.org/v10.dtd:Selection + (@ (startRow "4") (startCol "0") (endRow "4") (endCol "0")))) + (http://www.gnumeric.org/v10.dtd:SheetLayout (@ (TopLeft "A1"))) + (http://www.gnumeric.org/v10.dtd:Solver + (@ (ProgramR "0") + (ProblemType "0") + (NonNeg "1") + (ModelType "0") + (MaxTime "60") + (MaxIter "1000") + (Discr "0") + (AutoScale "0")))) Index: example/megatest.config ================================================================== --- example/megatest.config +++ example/megatest.config @@ -1,8 +1,8 @@ [fields] -PLATFORM TEXT -OS TEXT +CFG_TYPE This is the refdb to use. +RUN_TYPE Can be: full or quick [setup] # Adjust max_concurrent_jobs to limit parallel jobs max_concurrent_jobs 50 @@ -9,16 +9,14 @@ # This is your link path, best to set it and then not change it linktree #{getenv PWD}/linktree # Job tools control how your jobs are launched [jobtools] -useshell yes -launcher nbfind - -# You can override environment variables for all your tests here -[env-override] -EXAMPLE_VAR example value +launcher nbfake # As you run more tests you may need to add additional disks # the names are arbitrary but must be unique [disks] disk0 #{getenv PWD}/runs + +[include local.megatest.config] + Index: example/runconfigs.config ================================================================== --- example/runconfigs.config +++ example/runconfigs.config @@ -1,6 +1,9 @@ [default] ALLTESTS see this variable # Your variables here are grouped by targets [SYSTEM/RELEASE] -[SYSTEM_val/RELEASE_val] +[cfg/default] ANOTHERVAR only defined if target is SYSTEM_val/RELEASE_val + +[include local.runconfigs.config] + DELETED example/tests/checkspace/checkspace.logpro Index: example/tests/checkspace/checkspace.logpro ================================================================== --- example/tests/checkspace/checkspace.logpro +++ /dev/null @@ -1,3 +0,0 @@ -(expect:error in "LogFileBody" = 0 "Any error" #/err/i) -(expect:required in "LogFileBody" = 1 "Sucess signature" #/adequate space/) - DELETED example/tests/checkspace/checkspace.sh Index: example/tests/checkspace/checkspace.sh ================================================================== --- example/tests/checkspace/checkspace.sh +++ /dev/null @@ -1,8 +0,0 @@ -#!/bin/bash -e -freespace=`df -k $DIRECTORY | grep $DIRECTORY | awk '{print $4}'` -if [[ $freespace -lt $REQUIRED ]];then - echo "ERROR: insufficient space on $DIRECTORY" - exit 1 -else - echo "There is adequate space on $DIRECTORY" -fi DELETED example/tests/checkspace/testconfig Index: example/tests/checkspace/testconfig ================================================================== --- example/tests/checkspace/testconfig +++ /dev/null @@ -1,9 +0,0 @@ -# Add steps here. Format is "stepname script" -[ezsteps] -checkspace checkspace.sh - -# Iteration for your tests are controlled by the items section -[itemstable] -DIRECTORY /tmp /opt -REQUIRED 1000000 100000 - ADDED example/tests/diskspace/diskspace.logpro Index: example/tests/diskspace/diskspace.logpro ================================================================== --- /dev/null +++ example/tests/diskspace/diskspace.logpro @@ -0,0 +1,6 @@ +;; Analyze the output from diskspace.sh +;; +(expect:error in "LogFileBody" = 0 "Insufficient space" #/ERROR: available space is less/) +(expect:error in "LogFileBody" = 0 "Any error" #/err/i) +(expect:required in "LogFileBody" > 1 "Sucess signature" #/INFO: space available/) + ADDED example/tests/diskspace/diskspace.sh Index: example/tests/diskspace/diskspace.sh ================================================================== --- /dev/null +++ example/tests/diskspace/diskspace.sh @@ -0,0 +1,24 @@ +#!/bin/bash -e + +filter=`refdb lookup $MT_RUN_AREA_HOME/$CFG_TYPE machines $TARGETHOST filter` + +echo "Using filter: $filter" + +diskareas=`mount | egrep 'ext|mfs|nfs'| egrep -v "$filter" | awk '{print $3}'` + +for dirname in $diskareas;do + + echo "dirname: $dirname" + + # measure the free space + freespace=`df -P -k $dirname | grep $dirname | awk '{print $4}'` + + # get the minfree allowed from the refdb + minfree=`refdb lookup $MT_RUN_AREA_HOME/$CFG_TYPE machines $TARGETHOST minfree` + + if [[ "$freespace" -lt "$minfree" ]];then + echo "ERROR: available space $freespace is less than minimum allowed of $minfree on $dirname" + else + echo "INFO: space available of $freespace k on $dirname meets required minimum of $minfree." + fi +done ADDED example/tests/diskspace/hostname.logpro Index: example/tests/diskspace/hostname.logpro ================================================================== --- /dev/null +++ example/tests/diskspace/hostname.logpro @@ -0,0 +1,4 @@ +(define hostname (get-host-name)) + +(expect:required in "LogFileBody" > 0 (conc "Hostname matches " hostname) (regexp (conc "^" hostname "$"))) + ADDED example/tests/diskspace/testconfig Index: example/tests/diskspace/testconfig ================================================================== --- /dev/null +++ example/tests/diskspace/testconfig @@ -0,0 +1,12 @@ +# Add steps here. Format is "stepname script" +[ezsteps] +hostname hostname +diskspace diskspace.sh + +[requirements] +waiton ping +mode itemwait + +# Iteration for your tests are controlled by the items section +[items] +TARGETHOST [system refdb getrownames $CFG_TYPE machines] ADDED example/tests/ping/ping.logpro Index: example/tests/ping/ping.logpro ================================================================== --- /dev/null +++ example/tests/ping/ping.logpro @@ -0,0 +1,3 @@ +(expect:error in "LogFileBody" = 0 "Any error" #/err/i) +(expect:required in "LogFileBody" = 5 "Successful pings" #/bytes from.*/) + ADDED example/tests/ping/testconfig Index: example/tests/ping/testconfig ================================================================== --- /dev/null +++ example/tests/ping/testconfig @@ -0,0 +1,7 @@ +# Add steps here. Format is "stepname script" +[ezsteps] +ping ping -c 5 $PINGHOST + +# Iteration for your tests are controlled by the items section +[items] +PINGHOST [system refdb getrownames $CFG_TYPE machines] Index: ezsteps.scm ================================================================== --- ezsteps.scm +++ ezsteps.scm @@ -16,24 +16,28 @@ (declare (unit ezsteps)) (declare (uses db)) (declare (uses common)) (declare (uses items)) (declare (uses runconfig)) +;; (declare (uses sdb)) +;; (declare (uses filedb)) (include "common_records.scm") (include "key_records.scm") (include "db_records.scm") (include "run_records.scm") (define (ezsteps:run-from testdat start-step-name run-one) - (let* ((test-run-dir (db:test-get-rundir testdat)) + (let* ((test-run-dir ;; (filedb:get-path *fdb* + (db:test-get-rundir testdat)) ;; ) (testconfig (read-config (conc test-run-dir "/testconfig") #f #t environ-patt: "pre-launch-env-vars")) (ezstepslst (hash-table-ref/default testconfig "ezsteps" '())) (run-mutex (make-mutex)) (rollup-status 0) (exit-info (vector #t #t #t)) (test-id (db:test-get-id testdat)) + (run-id (db:test-get-run_id testdat)) (test-name (db:test-get-testname testdat)) (kill-job #f)) ;; for future use (on re-factoring with launch.scm code (let loop ((count 5)) (if (file-exists? test-run-dir) (push-directory test-run-dir) @@ -77,11 +81,11 @@ ;; call the command using mt_ezstep (set! script (conc "mt_ezstep " stepname " " (if prevstep prevstep "-") " " stepcmd)) (debug:print 4 "script: " script) - (rmt:teststep-set-status! #f test-id stepname "start" "-" #f #f) + (rmt:teststep-set-status! run-id test-id stepname "start" "-" #f #f) ;; now launch (let ((pid (process-run script))) (let processloop ((i 0)) (let-values (((pid-val exit-status exit-code)(process-wait pid #t))) (mutex-lock! run-mutex) @@ -94,11 +98,11 @@ (thread-sleep! 1) (processloop (+ i 1)))) )) (let ((exinfo (vector-ref exit-info 2)) (logfna (if logpro-used (conc stepname ".html") ""))) - (rmt:teststep-set-status! #f test-id stepname "end" exinfo #f logfna)) + (rmt:teststep-set-status! run-id test-id stepname "end" exinfo #f logfna)) (if logpro-used (rmt:test-set-log! test-id (conc stepname ".html"))) ;; set the test final status (let* ((this-step-status (cond ((and (eq? (vector-ref exit-info 2) 2) logpro-used) 'warn) @@ -136,11 +140,11 @@ (debug:print 4 "WARNING: a prior step failed, stopping at " ezstep))) ;; Once done with step/steps update the test record ;; (let* ((item-path (db:test-get-item-path testdat)) ;; (item-list->path itemdat)) - (testinfo (cdb:get-test-info-by-id *runremote* test-id))) ;; refresh the testdat, call it iteminfo in case need prev/curr + (testinfo (rmt:get-testinfo-by-id run-id test-id))) ;; refresh the testdat, call it iteminfo in case need prev/curr ;; Am I completed? (if (equal? (db:test-get-state testinfo) "RUNNING") ;; (not (equal? (db:test-get-state testinfo) "COMPLETED")) (let ((new-state (if kill-job "KILLED" "COMPLETED") ;; (if (eq? (vector-ref exit-info 2) 0) ;; exited with "good" status ;; "COMPLETED" ;; (db:test-get-state testinfo))) ;; else preseve the state as set within the test Index: filedb.scm ================================================================== --- filedb.scm +++ filedb.scm @@ -23,11 +23,11 @@ (filedb:fdb-set-db! fdb db) (filedb:fdb-set-dbpath! fdb dbpath) (filedb:fdb-set-pathcache! fdb (make-hash-table)) (filedb:fdb-set-idcache! fdb (make-hash-table)) (filedb:fdb-set-partcache! fdb (make-hash-table)) - ;(sqlite3:set-busy-timeout! db 1000000) + (sqlite3:set-busy-handler! db (make-busy-timeout 136000)) (if (not dbexists) (begin (sqlite3:execute db "PRAGMA synchronous = OFF;") (sqlite3:execute db "CREATE TABLE names (id INTEGER PRIMARY KEY,name TEST);") ;; for future use - change path in paths table to path_id (sqlite3:execute db "CREATE INDEX name_index ON names (name);") @@ -40,12 +40,20 @@ gid INTEGER DEFAULT -1, size INTEGER DEFAULT -1, mtime INTEGER DEFAULT -1);") (sqlite3:execute db "CREATE INDEX path_index ON paths (path,parent_id);") (sqlite3:execute db "CREATE TABLE bases (id INTEGER PRIMARY KEY,base TEXT, updated TIMESTAMP);"))) + ;; close the sqlite3 db and open it as needed + (filedb:finalize-db! fdb) + (filedb:fdb-set-db! fdb #f) fdb)) +(define (filedb:reopen-db fdb) + (let ((db (sqlite3:open-database (filedb:fdb-get-dbpath fdb)))) + (filedb:fdb-set-db! fdb db) + (sqlite3:set-busy-handler! db (make-busy-timeout 136000)))) + (define (filedb:finalize-db! fdb) (sqlite3:finalize! (filedb:fdb-get-db fdb))) (define (filedb:get-current-time-string) (string-chomp (time->string (seconds->local-time (current-seconds))))) @@ -108,10 +116,11 @@ (define (filedb:register-path fdb path #!key (save-stat #f)) (let* ((db (filedb:fdb-get-db fdb)) (pathcache (filedb:fdb-get-pathcache fdb)) (stat (if save-stat (file-stat path #t))) (id (hash-table-ref/default pathcache path #f))) + (if (not db)(filedb:reopen-db fdb)) (if id id (let ((plist (string-split path "/"))) (let loop ((head (car plist)) (tail (cdr plist)) (parent 0)) @@ -214,10 +223,11 @@ (define (filedb:get-path fdb id) (let* ((db (filedb:fdb-get-db fdb)) (idcache (filedb:fdb-get-idcache fdb)) (path (hash-table-ref/default idcache id #f))) + (if (not db)(filedb:reopen-db fdb)) (if path path (let loop ((curr-id id) (path "")) (let ((path-record (filedb:get-path-record fdb curr-id))) (if (not path-record) #f ;; this id has no path DELETED fs-transport.scm Index: fs-transport.scm ================================================================== --- fs-transport.scm +++ /dev/null @@ -1,44 +0,0 @@ - -;; Copyright 2006-2012, Matthew Welland. -;; -;; This program is made available under the GNU GPL version 2.0 or -;; greater. See the accompanying file COPYING for details. -;; -;; This program is distributed WITHOUT ANY WARRANTY; without even the -;; implied warranty of MERCHANTABILITY or FITNESS FOR A PARTICULAR -;; PURPOSE. - -(require-extension (srfi 18) extras tcp s11n) - -(use sqlite3 srfi-1 posix regex regex-case srfi-69 hostinfo md5 message-digest) -(import (prefix sqlite3 sqlite3:)) - -(use spiffy uri-common intarweb http-client spiffy-request-vars) - -(tcp-buffer-size 2048) - -(declare (unit fs-transport)) - -(declare (uses common)) -(declare (uses db)) -(declare (uses tests)) -(declare (uses tasks)) ;; tasks are where stuff is maintained about what is running. - -(include "common_records.scm") -(include "db_records.scm") - - -;;====================================================================== -;; F S T R A N S P O R T S E R V E R -;;====================================================================== - -;; There is no "server" per se but a convience routine to make it non -;; necessary to be reopening the db over and over again. -;; - -(define (fs:process-queue-item packet) - (if (not *megatest-db*) ;; we will require that (setup-for-run) has already been called - (set! *megatest-db* (open-db))) - (debug:print-info 11 "fs:process-queue-item called with packet=" packet) - (db:process-queue-item *megatest-db* packet)) - Index: http-transport.scm ================================================================== --- http-transport.scm +++ http-transport.scm @@ -25,10 +25,11 @@ (declare (uses db)) (declare (uses tests)) (declare (uses tasks)) ;; tasks are where stuff is maintained about what is running. (declare (uses server)) (declare (uses daemon)) +(declare (uses portlogger)) (include "common_records.scm") (include "db_records.scm") (define (http-transport:make-server-url hostport) @@ -58,36 +59,23 @@ (string-intersperse (map number->string (u8vector->list (if res res (hostname->ip hostname)))) "."))) -(define (http-transport:run hostn) +(define (http-transport:run hostn run-id server-id) (debug:print 2 "Attempting to start the server ...") - (if (not *toppath*) - (if (not (setup-for-run)) - (begin - (debug:print 0 "ERROR: cannot find megatest.config, cannot start server, exiting") - (exit)))) - (let* (;; (iface (if (string=? "-" hostn) - ;; #f ;; (get-host-name) - ;; hostn)) - (db #f) ;; (open-db)) ;; we don't want the server to be opening and closing the db unnecesarily + (let* ((db #f) ;; (open-db)) ;; we don't want the server to be opening and closing the db unnecesarily (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 (if (and (args:get-arg "-port") - (string->number (args:get-arg "-port"))) - (string->number (args:get-arg "-port")) - (if (and (config-lookup *configdat* "server" "port") - (string->number (config-lookup *configdat* "server" "port"))) - (string->number (config-lookup *configdat* "server" "port")) - (+ 5000 (random 1001))))) - (link-tree-path (config-lookup *configdat* "setup" "linktree"))) - (set! db *inmemdb*) + (start-port (portlogger:open-run-close portlogger:find-port)) + (link-tree-path (configf:lookup *configdat* "setup" "linktree"))) + ;; (set! db *inmemdb*) + (debug:print-info 0 "portlogger recommended port: " start-port) (root-path (if link-tree-path link-tree-path (current-directory))) ;; WARNING: SECURITY HOLE. FIX ASAP! (handle-directory spiffy-directory-listing) ;; http-transport:handle-directory) ;; simple-directory-handler) @@ -100,36 +88,36 @@ (dat ($ 'dat)) (res #f)) (cond ((equal? (uri-path (request-uri (current-request))) '(/ "api")) - (send-response body: (api:process-request db $) ;; the $ is the request vars proc + (send-response body: (api:process-request *inmemdb* $) ;; the $ is the request vars proc headers: '((content-type text/plain))) (mutex-lock! *heartbeat-mutex*) (set! *last-db-access* (current-seconds)) (mutex-unlock! *heartbeat-mutex*)) ;; This is the /ctrl path where data is handed to the server and ;; responses - ((equal? (uri-path (request-uri (current-request))) - '(/ "ctrl")) - (let* ((packet (db:string->obj dat)) - (qtype (cdb:packet-get-qtype packet))) - (debug:print-info 12 "server=> received packet=" packet) - (if (not (member qtype '(sync ping))) - (begin - (mutex-lock! *heartbeat-mutex*) - (set! *last-db-access* (current-seconds)) - (mutex-unlock! *heartbeat-mutex*))) - ;; (mutex-lock! *db:process-queue-mutex*) ;; trying a mutex - ;; (set! res (open-run-close db:process-queue-item open-db packet)) - (set! res (db:process-queue-item db packet)) - ;; (mutex-unlock! *db:process-queue-mutex*) - (debug:print-info 11 "Return value from db:process-queue-item is " res) - (send-response body: (conc "ctrl data\n" - res - "") - headers: '((content-type text/plain))))) + ;; ((equal? (uri-path (request-uri (current-request))) + ;; '(/ "ctrl")) + ;; (let* ((packet (db:string->obj dat)) + ;; (qtype (cdb:packet-get-qtype packet))) + ;; (debug:print-info 12 "server=> received packet=" packet) + ;; (if (not (member qtype '(sync ping))) + ;; (begin + ;; (mutex-lock! *heartbeat-mutex*) + ;; (set! *last-db-access* (current-seconds)) + ;; (mutex-unlock! *heartbeat-mutex*))) + ;; ;; (mutex-lock! *db:process-queue-mutex*) ;; trying a mutex + ;; ;; (set! res (open-run-close db:process-queue-item open-db packet)) + ;; (set! res (db:process-queue-item db packet)) + ;; ;; (mutex-unlock! *db:process-queue-mutex*) + ;; (debug:print-info 11 "Return value from db:process-queue-item is " res) + ;; (send-response body: (conc "ctrl data\n" + ;; res + ;; "") + ;; headers: '((content-type text/plain))))) ((equal? (uri-path (request-uri (current-request))) '(/ "")) (send-response body: (http-transport:main-page))) ((equal? (uri-path (request-uri (current-request))) '(/ "runs")) @@ -141,40 +129,56 @@ ((equal? (uri-path (request-uri (current-request))) '(/ "hey")) (send-response body: "hey there!\n" headers: '((content-type text/plain)))) (else (continue)))))))) - (http-transport:try-start-server ipaddrstr start-port))) + (http-transport:try-start-server run-id ipaddrstr start-port server-id))) ;; This is recursively run by http-transport:run until sucessful ;; -(define (http-transport:try-start-server ipaddrstr portnum) - (handle-exceptions - exn - (begin - (print-error-message exn) - (if (< portnum 9000) - (begin - (debug:print 0 "WARNING: failed to start on portnum: " portnum ", trying next port") - (thread-sleep! 0.1) - ;; (open-run-close tasks:remove-server-records tasks:open-db) - (open-run-close tasks:server-delete tasks:open-db ipaddrstr portnum) - (http-transport:try-start-server ipaddrstr (+ portnum 1))) - (print "ERROR: Tried and tried but could not start the server"))) - ;; any error in following steps will result in a retry - (set! *runremote* (list ipaddrstr portnum)) - ;; (open-run-close tasks:remove-server-records tasks:open-db) - (open-run-close tasks:server-register - tasks:open-db - (current-process-id) - ipaddrstr portnum 0 'startup 'http) - (debug:print 1 "INFO: Trying to start server on " ipaddrstr ":" portnum) - ;; This starts the spiffy server - ;; NEED WAY TO SET IP TO #f TO BIND ALL - (start-server bind-address: ipaddrstr port: portnum) - (open-run-close tasks:server-delete tasks:open-db ipaddrstr portnum) - (debug:print 1 "INFO: server has been stopped"))) +(define (http-transport:try-start-server run-id ipaddrstr portnum server-id) + (let ((config-hostname (configf:lookup *configdat* "server" "hostname"))) + (debug:print-info 0 "http-transport:try-start-server run-id=" run-id " ipaddrsstr=" ipaddrstr " portnum=" portnum " server-id=" server-id " config-hostname=" config-hostname) + (handle-exceptions + exn + (begin + (print-error-message exn) + (if (< portnum 64000) + (begin + (debug:print 0 "WARNING: attempt to start server failed. Trying again ...") + (debug:print 0 " message: " ((condition-property-accessor 'exn 'message) exn)) + (debug:print 0 "exn=" (condition->list exn)) + (portlogger:open-run-close portlogger:set-failed portnum) + (debug:print 0 "WARNING: failed to start on portnum: " portnum ", trying next port") + (thread-sleep! 0.1) + + ;; get_next_port goes here + (http-transport:try-start-server run-id + ipaddrstr + (portlogger:open-run-close portlogger:find-port) + server-id)) + (begin + (tasks:server-force-clean-run-record (tasks:get-db) run-id ipaddrstr portnum " http-transport:try-start-server") + (print "ERROR: Tried and tried but could not start the server")))) + ;; any error in following steps will result in a retry + (set! *server-info* (list ipaddrstr portnum)) + (tasks:server-set-interface-port + (tasks:get-db) + server-id + ipaddrstr portnum) + (debug:print 0 "INFO: Trying to start server on " ipaddrstr ":" portnum) + ;; This starts the spiffy server + ;; NEED WAY TO SET IP TO #f TO BIND ALL + ;; (start-server bind-address: ipaddrstr port: portnum) + (if config-hostname ;; this is a hint to bind directly + (start-server port: portnum bind-address: (if (equal? config-hostname "-") + ipaddrstr + config-hostname)) + (start-server port: portnum)) + ;; (portlogger:open-run-close portlogger:set-port portnum "released") + (tasks:server-force-clean-run-record (tasks:get-db) run-id ipaddrstr portnum " http-transport:try-start-server") + (debug:print 1 "INFO: server has been stopped")))) ;;====================================================================== ;; S E R V E R U T I L I T I E S ;;====================================================================== @@ -181,10 +185,13 @@ ;;====================================================================== ;; C L I E N T S ;;====================================================================== (define *http-mutex* (make-mutex)) + +;; NOTE: Large block of code from 32436b426188080f72fceb6894af541fbad9921e removed here +;; I'm pretty sure it is defunct. ;; This next block all imported en-mass from the api branch (define *http-requests-in-progress* 0) (define *http-connections-next-cleanup* (current-seconds)) @@ -226,258 +233,225 @@ (define (http-transport:inc-requests-and-prep-to-close-all-connections) (mutex-lock! *http-mutex*) (set! *http-requests-in-progress* (+ 1 *http-requests-in-progress*))) -;; (system "megatest -list-servers | grep alive || megatest -server - -daemonize && sleep 4") - -;; -;; -;; 1 Hello, world! Goodbye Dolly -;; Send msg to serverdat and receive result -(define (http-transport:client-send-receive serverdat msg #!key (numretries 30)) - (let* (;; (url (http-transport:make-server-url serverdat)) - (fullurl (if (list? serverdat) - (caddr serverdat) - (begin - (debug:print 0 "FATAL ERROR: http-transport:client-send-receive called with no server info") - (exit 1)))) ;; (conc url "/ctrl")) ;; (conc url "/?dat=" msg))) - (res #f)) - (handle-exceptions - exn - (begin - (print "ERROR IN http-transport:client-send-receive " ((condition-property-accessor 'exn 'message) exn)) - (thread-sleep! 2) - (if (> numretries 0) - (http-transport:client-send-receive serverdat msg numretries: (- numretries 1)))) - (begin - (debug:print-info 11 "fullurl=" fullurl "\n") - ;; set up the http-client here - (max-retry-attempts 5) - ;; consider all requests indempotent - (retry-request? (lambda (request) - #t)) ;; (thread-sleep! (/ (if (> numretries 100) 100 numretries) 10)) - ;; (set! numretries (- numretries 1)) - ;; #t)) - ;; send the data and get the response - ;; extract the needed info from the http data and - ;; process and return it. - (let* ((send-recieve (lambda () - (mutex-lock! *http-mutex*) - (set! res (with-input-from-request - fullurl - (list (cons 'dat msg)) - read-string)) - (close-all-connections!) - (mutex-unlock! *http-mutex*))) - (time-out (lambda () - (thread-sleep! 45) - (if (not res) - (begin - (debug:print 0 "WARNING: communication with the server timed out.") - (mutex-unlock! *http-mutex*) - (http-transport:client-send-receive serverdat msg numretries: (- numretries 1)) - (if (< numretries 3) ;; on last try just exit - (begin - (debug:print 0 "ERROR: communication with the server timed out. Giving up.") - (exit 1))))))) - (th1 (make-thread send-recieve "with-input-from-request")) - (th2 (make-thread time-out "time out"))) - (thread-start! th1) - (thread-start! th2) - (thread-join! th1) - (thread-terminate! th2) - (debug:print-info 11 "got res=" res) - (let ((match (string-search (regexp "(.*)<.body>") res))) - (debug:print-info 11 "match=" match) - (let ((final (cadr match))) - (debug:print-info 11 "final=" final) - final))))))) - -;; Send "cmd" with json payload "params" to serverdat and receive result -;; -(define (http-transport:client-api-send-receive serverdat cmd params #!key (numretries 30)) - (let* ((fullurl (if (list? serverdat) - (cadddr serverdat) ;; this is the uri for /api - (begin - (debug:print 0 "FATAL ERROR: http-transport:client-send-receive called with no server info") - (exit 1)))) - (res #f)) - (handle-exceptions - exn - (begin - ;; TODO: Send this output to a log file so it isn't lost when running as daemon - (print "ERROR IN http-transport:client-send-receive " ((condition-property-accessor 'exn 'message) exn)) - (thread-sleep! 2) - (if (> numretries 0) - (http-transport:client-api-send-receive serverdat cmd params numretries: (- numretries 1)))) - (begin - (debug:print-info 11 "fullurl=" fullurl "\n") - ;; set up the http-client here - (max-retry-attempts 5) - ;; consider all requests indempotent - (retry-request? (lambda (request) - #t)) ;; (thread-sleep! (/ (if (> numretries 100) 100 numretries) 10)) - ;; (set! numretries (- numretries 1)) - ;; #t)) - ;; send the data and get the response - ;; extract the needed info from the http data and - ;; process and return it. - - ;; (with-input-from-request "http://localhost/echo-service" - ;; '((test . "value")) read-string) - - (let* ((send-recieve (lambda () - ;; (let ((dat #f) - ;; (cleanup (http-transport:get-time-to-cleanup))) - ;; (if cleanup - ;; (http-transport:inc-requests-and-prep-to-close-all-connections) - ;; (http-transport:inc-requests-count)) - ;; ;; Do the actual data transfer NB// KEPP THIS IN SYNC WITH http-transport:client-send-receive - (mutex-lock! *http-mutex*) - (set! res (with-input-from-request ;; was dat - fullurl - (list (cons 'key "thekey") - (cons 'cmd cmd) - (cons 'params params)) - read-string)) - ;; Shouldn't this be a call to the managed call-all-connections stuff above? - (close-all-connections!) - (mutex-unlock! *http-mutex*) - )) - ;; (if cleanup - ;; ;; mutex already set - ;; (begin - ;; (set! res dat) - ;; (http-transport:dec-requests-count-and-close-all-connections)) - ;; (http-transport:dec-requests-count - ;; (lambda () - ;; (set! res dat))))))) - (time-out (lambda () - (thread-sleep! 45) - (if (not res) - (begin - (debug:print 0 "WARNING: communication with the server timed out.") - (mutex-unlock! *http-mutex*) - (http-transport:client-api-send-receive serverdat cmd params numretries: (- numretries 1)) - (if (< numretries 3) ;; on last try just exit - (begin - (debug:print 0 "ERROR: communication with the server timed out. Giving up.") - (exit 1))))))) +;; Send "cmd" with json payload "params" to serverdat and receive result +;; +(define (http-transport:client-api-send-receive run-id serverdat cmd params #!key (numretries 3)) + (let* ((fullurl (if (vector? serverdat) + (http-transport:server-dat-get-api-req serverdat) + (begin + (debug:print 0 "FATAL ERROR: http-transport:client-api-send-receive called with no server info") + (exit 1)))) + (res #f)) + (handle-exceptions + exn + (if (> numretries 0) + (begin + (mutex-unlock! *http-mutex*) + (thread-sleep! 1) + (close-all-connections!) + (debug:print 0 "WARNING: Failed to communicate with server, trying again, numretries left: " numretries) + (http-transport:client-api-send-receive run-id serverdat cmd params numretries: (- numretries 1))) + (begin + (mutex-unlock! *http-mutex*) + #f)) + (begin + (debug:print-info 11 "fullurl=" fullurl ", cmd=" cmd ", params=" params ", run-id=" run-id "\n") + ;; set up the http-client here + (max-retry-attempts 1) + ;; consider all requests indempotent + (retry-request? (lambda (request) + #f)) + ;; send the data and get the response + ;; extract the needed info from the http data and + ;; process and return it. + (let* ((send-recieve (lambda () + (mutex-lock! *http-mutex*) + ;; (condition-case (with-input-from-request "http://localhost"; #f read-lines) + ;; ((exn http client-error) e (print e))) + (set! res (with-input-from-request ;; was dat + fullurl + (list (cons 'key "thekey") + (cons 'cmd cmd) + (cons 'params params)) + read-string)) + ;; Shouldn't this be a call to the managed call-all-connections stuff above? + (close-all-connections!) + (mutex-unlock! *http-mutex*) + )) + (time-out (lambda () + (thread-sleep! 45) + #f)) (th1 (make-thread send-recieve "with-input-from-request")) (th2 (make-thread time-out "time out"))) (thread-start! th1) (thread-start! th2) (thread-join! th1) (thread-terminate! th2) (debug:print-info 11 "got res=" res) res))))) +;; careful closing of connections stored in *runremote* +;; +(define (http-transport:close-connections run-id) + (let* ((server-dat (hash-table-ref/default *runremote* run-id #f))) + (if (vector? server-dat) + (let ((api-dat (http-transport:server-dat-get-api-uri server-dat))) + (close-connection! api-dat) + #t) + #f))) + + +(define (make-http-transport:server-dat)(make-vector 5)) +(define (http-transport:server-dat-get-iface vec) (vector-ref vec 0)) +(define (http-transport:server-dat-get-port vec) (vector-ref vec 1)) +(define (http-transport:server-dat-get-api-uri vec) (vector-ref vec 2)) +(define (http-transport:server-dat-get-api-url vec) (vector-ref vec 3)) +(define (http-transport:server-dat-get-api-req vec) (vector-ref vec 4)) + +(define (http-transport:server-dat-make-url vec) + (if (and (http-transport:server-dat-get-iface vec) + (http-transport:server-dat-get-port vec)) + (conc "http://" + (http-transport:server-dat-get-iface vec) + ":" + (http-transport:server-dat-get-port vec)) + #f)) + +;; +;; connect +;; (define (http-transport:client-connect iface port) - (let* ((login-res #f) - (uri-dat (make-request method: 'POST uri: (uri-reference (conc "http://" iface ":" port "/ctrl")))) - (uri-api-dat (make-request method: 'POST uri: (uri-reference (conc "http://" iface ":" port "/api")))) - (serverdat (list iface port uri-dat uri-api-dat))) - (set! *runremote* serverdat) ;; may or may not be good ... - (set! login-res (rmt:login)) - (if (and (list? login-res) - (car login-res)) - (begin - (debug:print-info 2 "Logged in and connected to " iface ":" port) - (set! *runremote* serverdat) - serverdat) - (begin - (debug:print-info 0 "ERROR: Failed to login or connect to " iface ":" port) - (exit 1))))) -;; (set! *runremote* #f) -;; (set! *transport-type* 'fs) -;; #f)))) - + (let* ((api-url (conc "http://" iface ":" port "/api")) + (api-uri (uri-reference (conc "http://" iface ":" port "/api"))) + (api-req (make-request method: 'POST uri: api-uri)) + (server-dat (vector iface port api-uri api-url api-req))) + server-dat)) ;; run http-transport:keep-running in a parallel thread to monitor that the db is being ;; used and to shutdown after sometime if it is not. ;; -(define (http-transport:keep-running) +(define (http-transport:keep-running server-id run-id) ;; if none running or if > 20 seconds since ;; server last used then start shutdown ;; This thread waits for the server to come alive - (let* ((server-info (let loop () + (let* ((server-info (let loop ((start-time (current-seconds)) + (changed #t) + (last-sdat "not this")) (let ((sdat #f)) + (thread-sleep! 0.01) + (debug:print-info 0 "Waiting for server alive signal") (mutex-lock! *heartbeat-mutex*) - (set! sdat *runremote*) + (set! sdat *server-info*) (mutex-unlock! *heartbeat-mutex*) - (if sdat + (if (and sdat + (not changed) + (> (- (current-seconds) start-time) 2)) sdat (begin + (debug:print-info 0 "Still waiting, last-sdat=" last-sdat) (sleep 4) - (loop)))))) + (loop start-time + (equal? sdat last-sdat) + sdat)))))) (iface (car server-info)) (port (cadr server-info)) (last-access 0) (tdb (tasks:open-db)) - (spid ;;(open-run-close tasks:server-get-server-id tasks:open-db #f iface port #f)) - (tasks:server-get-server-id tdb #f iface port #f)) - (server-timeout (let ((tmo (config-lookup *configdat* "server" "timeout"))) + (server-timeout (let ((tmo (configf:lookup *configdat* "server" "timeout"))) (if (and (string? tmo) (string->number tmo)) (* 60 60 (string->number tmo)) - ;; default to three days - (* 3 24 60 60))))) - (debug:print-info 2 "server-timeout: " server-timeout ", server pid: " spid " on " iface ":" port) - (let loop ((count 0)) + ;; (* 3 24 60 60) ;; default to three days + (* 60 1) ;; default to one minute + ;; (* 60 60 25) ;; default to 25 hours + )))) + (let loop ((count 0) + (server-state 'available)) ;; Use this opportunity to sync the inmemdb to db (let ((start-time (current-milliseconds)) (sync-time #f) (rem-time #f)) - (if *inmemdb* (db:sync-tables (db:tbls *inmemdb*) *inmemdb* *db*)) ;; (db:sync-to *inmemdb* *db*)) + + (if *inmemdb* (db:sync-touched *inmemdb* *run-id* force-sync: #t)) (set! sync-time (- (current-milliseconds) start-time)) - (debug:print 0 "SYNC: time= " sync-time) (set! rem-time (quotient (- 4000 sync-time) 1000)) - (if (and (< rem-time 4) - (> rem-time 0)) - (thread-sleep! rem-time))) + (debug:print 2 "SYNC: time= " sync-time ", rem-time=" rem-time) + + ;; + ;; set_running after our first pass through and start the db + ;; + (if (eq? server-state 'available) + (begin + (tasks:server-set-state! tdb server-id "dbprep") + (thread-sleep! 5) ;; give some margin for queries to complete before switching from file based access to server based access + (set! *inmemdb* (db:setup run-id)) + (tasks:server-set-state! tdb server-id "running"))) - ;; (thread-sleep! 4) ;; no need to do this very often - + (if (and (<= rem-time 4) + (> rem-time 0)) + (thread-sleep! rem-time) + (thread-sleep! 4))) ;; fallback for if the math is changed ... + (if (< count 1) ;; 3x3 = 9 secs aprox - (loop (+ count 1))) + (loop (+ count 1) 'running)) ;; Check that iface and port have not changed (can happen if server port collides) (mutex-lock! *heartbeat-mutex*) - (set! sdat *runremote*) + (set! sdat *server-info*) (mutex-unlock! *heartbeat-mutex*) (if (or (not (equal? sdat (list iface port))) - (not spid)) + (not server-id)) (begin (debug:print-info 0 "interface changed, refreshing iface and port info") (set! iface (car sdat)) - (set! port (cadr sdat)) - (set! spid (tasks:server-get-server-id tdb #f iface port #f)))) - - ;; NOTE: Get rid of this mechanism! It really is not needed... - ;; (open-run-close tasks:server-update-heartbeat tasks:open-db spid) - (tasks:server-update-heartbeat tdb spid) - - ;; (if ;; (or (> numrunning 0) ;; stay alive for two days after last access + (set! port (cadr sdat)))) + + ;; Transfer *last-db-access* to last-access to use in checking that we are still alive (mutex-lock! *heartbeat-mutex*) (set! last-access *last-db-access*) (mutex-unlock! *heartbeat-mutex*) + ;; (debug:print 11 "last-access=" last-access ", server-timeout=" server-timeout) + ;; + ;; no_traffic, no running tests, if server 0, no running servers + ;; + ;; (let ((wait-on-running (configf:lookup *configdat* "server" "wait-on-running"))) ;; wait on running tasks (if not true then exit on time out) + ;; (if (and *server-run* + ;; (or (> (+ last-access server-timeout) (current-seconds))) +;; (and (eq? run-id 0) +;; (> (tasks:num-servers-non-zero-running tdb) 0)) +;; (and (not (eq? run-id 0)) ;; only makes sense in non-zero run-id servers +;; (> (db:get-count-tests-actually-running *inmemdb* run-id) 0)) +;; )) (begin (debug:print-info 0 "Server continuing, seconds since last db access: " (- (current-seconds) last-access)) - (loop 0)) + ;; + ;; Consider implementing some smarts here to re-insert the record or kill self is + ;; the db indicates so + ;; + ;; (if (tasks:server-am-i-the-server? tdb run-id) + ;; (tasks:server-set-state! tdb server-id "running")) + ;; + (loop 0 server-state)) (begin (debug:print-info 0 "Starting to shutdown the server.") ;; need to delete only *my* server entry (future use) (set! *time-to-exit* #t) - (if *inmemdb* (db:sync-tables (db:tbls *inmemdb*) *inmemdb* *db*)) ;; (db:sync-to *inmemdb* *db*)) - (open-run-close tasks:server-deregister-self tasks:open-db (get-host-name)) - (thread-sleep! 1) + (if *inmemdb* (db:sync-touched *inmemdb* *run-id* force-sync: #t)) + ;; + ;; start_shutdown + ;; + (tasks:server-set-state! tdb server-id "shutting-down") + (portlogger:open-run-close portlogger:set-port port "released") + (thread-sleep! 5) (debug:print-info 0 "Max cached queries was " *max-cache-size*) (debug:print-info 0 "Number of cached writes " *number-of-writes*) (debug:print-info 0 "Average cached write time " (if (eq? *number-of-writes* 0) "n/a (no writes)" @@ -490,73 +464,75 @@ "n/a (no queries)" (/ *total-non-write-delay* *number-non-write-queries*)) " ms") (debug:print-info 0 "Server shutdown complete. Exiting") + (tasks:server-delete-record tdb server-id " http-transport:keep-running") (exit)))))) ;; all routes though here end in exit ... -(define (http-transport:launch) - (if (not *toppath*) - (if (not (setup-for-run)) - (begin - (debug:print 0 "ERROR: cannot find megatest.config, exiting") - (exit)))) - (debug:print-info 2 "Starting the standalone server") +;; +;; start_server? +;; +(define (http-transport:launch run-id) + (set! *run-id* run-id) (if (args:get-arg "-daemonize") - (daemon:ize)) - (let ((hostinfo (open-run-close tasks:get-best-server tasks:open-db))) - (debug:print 11 "http-transport:launch hostinfo=" hostinfo) - ;; #(1 "143.182.207.24" 5736 -1 "http" 22771 "hostname") - (if hostinfo - (debug:print-info 2 "NOT starting new server, one is already running on " (vector-ref hostinfo 1) ":" (vector-ref hostinfo 2)) - (if *toppath* - (let* ((th2 (make-thread (lambda () - (http-transport:run - (if (args:get-arg "-server") - (args:get-arg "-server") - "-"))) "Server run")) - (th3 (make-thread http-transport:keep-running "Keep running"))) -;; (th1 (make-thread server:write-queue-handler "write queue"))) - (set! *cache-on* #t) - (set! *db* (open-db)) - (set! *inmemdb* (open-in-mem-db)) - (db:sync-tables (db:tbls *db*) *db* *inmemdb*) ;; (db:sync-to *db* *inmemdb*) - - (thread-start! th2) - (thread-start! th3) - ;; (thread-start! th1) - (set! *didsomething* #t) - (thread-join! th2)) - (debug:print 0 "ERROR: Failed to setup for megatest"))) - (exit))) - -;; (use trace) -;; (trace http-transport:keep-running -;; tasks:server-update-heartbeat -;; tasks:server-get-server-id) -;; tasks:get-best-server -;; http-transport:run -;; http-transport:launch -;; http-transport:try-start-server -;; http-transport:client-send-receive -;; http-transport:make-server-url -;; tasks:server-register -;; tasks:server-delete -;; start-server -;; hostname->ip -;; with-input-from-request -;; tasks:server-deregister-self) + (begin + (daemon:ize) + (if *alt-log-file* ;; we should re-connect to this port, I think daemon:ize disrupts it + (begin + (current-error-port *alt-log-file*) + (current-output-port *alt-log-file*))))) + (if (server:check-if-running run-id) + (begin + (debug:print 0 "INFO: Server for run-id " run-id " already running") + (exit 0))) + (let loop ((server-id (tasks:server-lock-slot (tasks:get-db) run-id)) + (remtries 4)) + (if (not server-id) + (if (> remtries 0) + (begin + (thread-sleep! 2) + (loop (tasks:server-lock-slot (tasks:get-db) 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 "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 (tasks:get-db) " http-transport:launch") + )) + (let* ((th2 (make-thread (lambda () + (debug:print-info 0 "Server run thread started") + (http-transport:run + (if (args:get-arg "-server") + (args:get-arg "-server") + "-") + run-id + server-id)) "Server run")) + (th3 (make-thread (lambda () + (debug:print-info 0 "Server monitor thread started") + (http-transport:keep-running server-id run-id)) + "Keep running"))) + ;; Database connection + + + ;; don't start the db here + + ;; (set! *inmemdb* (db:setup run-id)) + + + (thread-start! th2) + (thread-start! th3) + (set! *didsomething* #t) + (thread-join! th2) + (exit))))) (define (http-transport:server-signal-handler signum) (handle-exceptions exn (debug:print " ... exiting ...") (let ((th1 (make-thread (lambda () (thread-sleep! 1)) - ;; (if (not *received-response*) - ;; (receive-message* *runremote*))) ;; flush out last call if applicable "eat response")) (th2 (make-thread (lambda () (debug:print 0 "ERROR: Received ^C, attempting clean exit. Please be patient and wait a few seconds before hitting ^C again.") (thread-sleep! 3) ;; give the flush three seconds to do it's stuff (debug:print 0 " Done.") Index: launch.scm ================================================================== --- launch.scm +++ launch.scm @@ -11,19 +11,21 @@ ;;====================================================================== ;; launch a task - this runs on the originating host, tests themselves ;; ;;====================================================================== -(use regex regex-case base64 sqlite3 srfi-18) +(use regex regex-case base64 sqlite3 srfi-18 directory-utils posix-extras z3) (import (prefix base64 base64:)) (import (prefix sqlite3 sqlite3:)) (declare (unit launch)) (declare (uses common)) (declare (uses configf)) (declare (uses db)) +;; (declare (uses sdb)) (declare (uses tdb)) +;; (declare (uses filedb)) (include "common_records.scm") (include "key_records.scm") (include "db_records.scm") @@ -46,15 +48,15 @@ ;; if handed a string, process it, else look for MT_CMDINFO (define (launch:get-cmdinfo-assoc-list #!key (encoded-cmd #f)) (let ((enccmd (if encoded-cmd encoded-cmd (getenv "MT_CMDINFO")))) (if enccmd - (read (open-input-string (base64:base64-decode enccmd))) + (common:read-encoded-string enccmd) '()))) (define (launch:execute encoded-cmd) - (let* ((cmdinfo (read (open-input-string (base64:base64-decode encoded-cmd))))) + (let* ((cmdinfo (common:read-encoded-string encoded-cmd))) (setenv "MT_CMDINFO" encoded-cmd) (if (list? cmdinfo) ;; ((testpath /tmp/mrwellan/jazzmind/src/example_run/tests/sqlitespeed) ;; (test-name sqlitespeed) (runscript runscript.rb) (db-host localhost) (run-id 1)) (let* ((testpath (assoc/default 'testpath cmdinfo)) ;; testpath is the test spec area (top-path (assoc/default 'toppath cmdinfo)) @@ -73,10 +75,11 @@ (env-ovrd (assoc/default 'env-ovrd cmdinfo)) (set-vars (assoc/default 'set-vars cmdinfo)) ;; pre-overrides from -setvar (runname (assoc/default 'runname cmdinfo)) (megatest (assoc/default 'megatest cmdinfo)) (runtlim (assoc/default 'runtlim cmdinfo)) + (item-path (item-list->path itemdat)) (mt-bindir-path (assoc/default 'mt-bindir-path cmdinfo)) (keys #f) (keyvals #f) (fullrunscript (if (not runscript) #f @@ -87,16 +90,45 @@ (file-execute-access? fulln)) fulln runscript))))) ;; assume it is on the path (rollup-status 0)) (change-directory top-path) + + ;; Do not run the test if it is REMOVING, RUNNING, KILLREQ or REMOTEHOSTSTART, + ;; Mark the test as REMOTEHOSTSTART *IMMEDIATELY* + ;; + (let ((test-info (rmt:get-testinfo-state-status run-id test-id))) + (if (not (member (db:test-get-state test-info) '("REMOVING" "REMOTEHOSTSTART" "RUNNING" "KILLREQ"))) + (tests:test-force-state-status! run-id test-id "REMOTEHOSTSTART" "n/a") + (debug:print 0 "ERROR: test state is " (db:test-get-state test-info) ", cannot proceed"))) + (debug:print 2 "Exectuing " test-name " (id: " test-id ") on " (get-host-name)) - ;; Setup the *runremote* global var - (if *runremote* (debug:print 2 "ERROR: I'm not expecting *runremote* to be set at this time")) - ;; (set! *runremote* runremote) - ;; (set! *transport-type* (string->symbol transport)) (set! keys (rmt:get-keys)) + ;; (runs:set-megatest-env-vars run-id inkeys: keys inkeyvals: keyvals) ;; these may be needed by the launching process + ;; one of these is defunct/redundant ... + (if (not (launch:setup-for-run force: #t)) + (begin + (debug:print 0 "Failed to setup, exiting") + ;; (sqlite3:finalize! db) + ;; (sqlite3:finalize! tdb) + (exit 1))) + (change-directory *toppath*) + (let ((rconfig (full-runconfigs-read))) ;; (read-config (conc *toppath* "/runconfigs.config") #f #t sections: (list "default" target)))) + ;; (setup-env-defaults (conc *toppath* "/runconfigs.config") run-id (make-hash-table) keyvals target) + ;; (set-run-config-vars run-id keyvals target) ;; (db:get-target db run-id)) + ;; Now have runconfigs data loaded, set environment vars + (for-each (lambda (section) + (for-each (lambda (varval) + (let ((var (car varval)) + (val (cadr varval))) + (if (and (string? var)(string? val)) + (begin + (setenv var (config:eval-string-in-environment val))) ;; val) + (debug:print 0 "ERROR: bad variable spec, " var "=" val)))) + (configf:get-section rconfig section))) + (list "default" target))) + (change-directory work-area) (set! keyvals (keys:target->keyval keys target)) ;; apply pre-overrides before other variables. The pre-override vars must not ;; clobbers things from the official sources such as megatest.config and runconfigs.config (if (string? set-vars) (let ((varpairs (string-split set-vars ","))) @@ -120,40 +152,31 @@ (exit))))) (list (list "MT_TEST_RUN_DIR" work-area) (list "MT_TEST_NAME" test-name) (list "MT_ITEM_INFO" (conc itemdat)) + (list "MT_ITEMPATH" item-path) (list "MT_RUNNAME" runname) (list "MT_MEGATEST" megatest) (list "MT_TARGET" target) (list "MT_LINKTREE" (configf:lookup *configdat* "setup" "linktree")))) (if mt-bindir-path (setenv "PATH" (conc (getenv "PATH") ":" mt-bindir-path))) ;; (change-directory top-path) - (if (not (setup-for-run)) - (begin - (debug:print 0 "Failed to setup, exiting") - ;; (sqlite3:finalize! db) - ;; (sqlite3:finalize! tdb) - (exit 1))) ;; Can setup as client for server mode now ;; (client:setup) - (change-directory *toppath*) - (set-megatest-env-vars run-id inkeys: keys inkeyvals: keyvals) ;; these may be needed by the launching process - (change-directory work-area) - - (set-run-config-vars run-id keyvals target) ;; (db:get-target db run-id)) + ;; environment overrides are done *before* the remaining critical envars. (alist->env-vars env-ovrd) - (set-megatest-env-vars run-id inkeys: keys inkeyvals: keyvals) + (runs:set-megatest-env-vars run-id inkeys: keys inkeyvals: keyvals) (set-item-env-vars itemdat) (save-environment-as-files "megatest") ;; open-run-close not needed for test-set-meta-info - (tests:set-full-meta-info test-id run-id 0 work-area) + ;; (tests:set-full-meta-info #f test-id run-id 0 work-area) + ;; (tests:set-full-meta-info test-id run-id 0 work-area) + (tests:set-full-meta-info #f test-id run-id 0 work-area 10) - ;; (tests:test-set-status! test-id "REMOTEHOSTSTART" "n/a" (args:get-arg "-m") #f) - (tests:test-force-state-status! test-id "REMOTEHOSTSTART" "n/a") (thread-sleep! 0.3) ;; NFS slowness has caused grief here (if (args:get-arg "-xterm") (set! fullrunscript "xterm") (if (and fullrunscript (not (file-execute-access? fullrunscript))) @@ -177,11 +200,12 @@ ;; any of the other stuff that tests:test-set-status! does. Let's just ;; force RUNNING/n/a (thread-sleep! 0.3) - (tests:test-force-state-status! test-id "RUNNING" "n/a") + (tests:test-force-state-status! run-id test-id "RUNNING" "n/a") + (rmt:roll-up-pass-fail-counts run-id test-name item-path "RUNNING") (thread-sleep! 0.3) ;; NFS slowness has caused grief here ;; if there is a runscript do it first (if fullrunscript (let ((pid (process-run fullrunscript))) @@ -235,11 +259,11 @@ ;; call the command using mt_ezstep (set! script (conc "mt_ezstep " stepname " " (if prevstep prevstep "-") " " stepcmd)) (debug:print 4 "script: " script) - (rmt:teststep-set-status! test-id stepname "start" "-" #f #f) + (rmt:teststep-set-status! run-id test-id stepname "start" "-" #f #f) ;; now launch (let ((pid (process-run script))) (let processloop ((i 0)) (let-values (((pid-val exit-status exit-code)(process-wait pid #t))) (mutex-lock! m) @@ -252,13 +276,13 @@ (thread-sleep! 2) (processloop (+ i 1)))) )) (let ((exinfo (vector-ref exit-info 2)) (logfna (if logpro-used (conc stepname ".html") ""))) - (rmt:teststep-set-status! test-id stepname "end" exinfo #f logfna)) + (rmt:teststep-set-status! run-id test-id stepname "end" exinfo #f logfna)) (if logpro-used - (rmt:test-set-log! test-id (conc stepname ".html"))) + (rmt:test-set-log! run-id test-id (conc stepname ".html"))) ;; set the test final status (let* ((this-step-status (cond ((and (eq? (vector-ref exit-info 2) 2) logpro-used) 'warn) ((eq? (vector-ref exit-info 2) 0) 'pass) (else 'fail))) @@ -282,18 +306,18 @@ " next-status: " next-status " rollup-status: " rollup-status) (case next-status ((warn) (set! rollup-status 2) ;; NB// test-set-status! does rdb calls under the hood - (tests:test-set-status! test-id next-state "WARN" + (tests:test-set-status! run-id test-id next-state "WARN" (if (eq? this-step-status 'warn) "Logpro warning found" #f) #f)) ((pass) - (tests:test-set-status! test-id next-state "PASS" #f #f)) + (tests:test-set-status! run-id test-id next-state "PASS" #f #f)) (else ;; 'fail (set! rollup-status 1) ;; force fail, this used to be next-state but that doesn't make sense. should always be "COMPLETED" - (tests:test-set-status! test-id "COMPLETED" "FAIL" (conc "Failed at step " stepname) #f) + (tests:test-set-status! run-id test-id "COMPLETED" "FAIL" (conc "Failed at step " stepname) #f) )))) (if (and (steprun-good? logpro-used (vector-ref exit-info 2)) (not (null? tal))) (loop (car tal) (cdr tal) stepname))) (debug:print 4 "WARNING: a prior step failed, stopping at " ezstep)))))))) @@ -304,61 +328,71 @@ (round (- (current-seconds) start-seconds))))) (kill-tries 0)) - (tests:set-full-meta-info test-id run-id (calc-minutes) work-area) + ;; (tests:set-full-meta-info #f test-id run-id (calc-minutes) work-area) + ;; (tests:set-full-meta-info test-id run-id (calc-minutes) work-area) + (tests:set-full-meta-info #f test-id run-id (calc-minutes) work-area 10) (let loop ((minutes (calc-minutes))) (begin - (set! kill-job? (or (test-get-kill-request test-id) ;; run-id test-name itemdat)) + (set! kill-job? (or (test-get-kill-request run-id test-id) ;; run-id test-name itemdat)) (and runtlim (let* ((run-seconds (- (current-seconds) start-seconds)) (time-exceeded (> run-seconds runtlim))) (if time-exceeded (begin (debug:print-info 0 "KILLING TEST DUE TO TIME LIMIT EXCEEDED! Runtime=" run-seconds " seconds, limit=" runtlim) #t) #f))))) ;; open-run-close not needed for test-set-meta-info - (tests:set-partial-meta-info test-id run-id minutes work-area) + ;; (tests:set-partial-meta-info #f test-id run-id minutes work-area) + (tests:update-central-meta-info run-id test-id (get-cpu-load) (get-df (current-directory))(calc-minutes) #f #f) + ;; (tests:set-partial-meta-info #f test-id run-id minutes work-area 10) + ;; (tests:set-partial-meta-info test-id run-id minutes work-area) (if kill-job? (begin (mutex-lock! m) ;; NOTE: The pid can change as different steps are run. Do we need handshaking between this ;; section and the runit section? Or add a loop that tries three times with a 1/4 second ;; between tries? (let* ((pid (vector-ref exit-info 0))) (if (number? pid) - (process-signal pid signal/kill) - ;; (begin - ;; (debug:print 0 "WARNING: Request received to kill job (attempt # " kill-tries ")") - ;; (let ((processes (cmd-run->list (conc "pgrep -l -P " pid)))) - ;; (for-each - ;; (lambda (p) - ;; (let* ((parts (string-split p)) - ;; (p-id (if (> (length parts) 0) - ;; (string->number (car parts)) - ;; #f))) - ;; (if p-id - ;; (begin - ;; (debug:print 0 "Killing " (cadr parts) "; kill -9 " p-id) - ;; (system (conc "kill -9 " p-id)))))) - ;; (car processes)) - ;; (system (conc "kill -9 -" pid)))) + (handle-exceptions + exn + (debug:print-info 0 "Unable to kill process with pid " pid ", possibly already killed.") + ;;(process-signal pid signal/kill)) + (begin + (debug:print 0 "WARNING: Request received to kill job (attempt # " kill-tries ")") + (let ((processes (cmd-run->list (conc "pgrep -l -P " pid)))) + (for-each + (lambda (p) + (let* ((parts (string-split p)) + (p-id (if (> (length parts) 0) + (string->number (car parts)) + #f))) + (if p-id + (begin + (debug:print 0 "Killing " (cadr parts) "; kill -9 " p-id) + ;; (process-signal pid signal/kill))))) ;; + (system (conc "kill -9 " p-id)))))) + (car processes))) + (system (conc "kill -9 -" pid)) + (tests:test-set-status! test-id "KILLED" "KILLED" (args:get-arg "-m") #f))) (begin (debug:print 0 "WARNING: Request received to kill job but problem with process, attempting to kill manager process") - (tests:test-set-status! test-id "KILLED" "FAIL" - (args:get-arg "-m") #f) + (tests:test-set-status! test-id "KILLED" "KILLED" (args:get-arg "-m") #f) + (tests:test-set-status! run-id test-id "KILLED" "FAIL" (args:get-arg "-m") #f) (exit 1) ;; IS THIS NECESSARY OR WISE??? ))) (set! kill-tries (+ 1 kill-tries)) (mutex-unlock! m))) (if keep-going (begin (thread-sleep! 3) ;; (+ 3 (random 6))) ;; add some jitter to the call home time to spread out the db accesses (if keep-going (loop (calc-minutes))))))) - (tests:update-central-meta-info test-id (get-cpu-load) (get-df (current-directory))(calc-minutes) #f #f)))) ;; NOTE: Checking twice for keep-going is intentional + (tests:update-central-meta-info run-id test-id (get-cpu-load) (get-df (current-directory))(calc-minutes) #f #f)))) ;; NOTE: Checking twice for keep-going is intentional (th1 (make-thread monitorjob "monitor job")) (th2 (make-thread runit "run job"))) (set! job-thread th2) (thread-start! th1) (thread-start! th2) @@ -367,11 +401,11 @@ (thread-join! th1) (thread-sleep! 1) ;; give thread th1 a chance to be done TODO: Verify this is needed. At 0.1 I was getting fail to stop, increased to total of 1.1 sec. (mutex-lock! m) (let* ((item-path (item-list->path itemdat)) ;; only state and status needed - use lazy routine - (testinfo (rmt:get-testinfo-state-status test-id))) ;;;(cdb:get-test-info-by-id *runremote* test-id))) ;; )) ;; run-id test-name item-path))) + (testinfo (rmt:get-testinfo-state-status run-id test-id))) ;; Am I completed? (if (member (db:test-get-state testinfo) '("REMOTEHOSTSTART" "RUNNING")) ;; NOTE: It should *not* be REMOTEHOSTSTART but for reasons I don't yet understand it sometimes gets stuck in that state ;; (not (equal? (db:test-get-state testinfo) "COMPLETED")) (let ((new-state (if kill-job? "KILLED" "COMPLETED") ;; (if (eq? (vector-ref exit-info 2) 0) ;; exited with "good" status ;; "COMPLETED" ;; (db:test-get-state testinfo))) ;; else preseve the state as set within the test @@ -385,20 +419,17 @@ ((eq? rollup-status 2) ;; if the current status is AUTO the defer to the calculated value but qualify (i.e. make this AUTO-WARN) (if (equal? (db:test-get-status testinfo) "AUTO") "AUTO-WARN" "WARN")) (else "FAIL")))) ;; (db:test-get-status testinfo))) (debug:print-info 1 "Test exited in state=" (db:test-get-state testinfo) ", setting state/status based on exit code of " (vector-ref exit-info 1) " and rollup-status of " rollup-status) - (tests:test-set-status! test-id + (tests:test-set-status! run-id + test-id new-state new-status (args:get-arg "-m") #f) ;; need to update the top test record if PASS or FAIL and this is a subtest ;; NO NEED TO CALL roll-up-pass-fail-counts HERE, THIS IS DONE IN roll-up-pass-fail-counts called by tests:test-set-status! - ;; (if (not (equal? item-path "")) - ;; (begin - ;; (thread-sleep! 0.1) ;; give other processes an opportunity to access the db as rollup is lower priority - ;; (cdb:roll-up-pass-fail-counts *runremote* run-id test-name item-path new-status))) )) ;; for automated creation of the rollup html file this is a good place... (if (not (equal? item-path "")) (tests:summarize-items run-id test-id test-name #f))) ;; don't force - just update if no (mutex-unlock! m) @@ -406,32 +437,53 @@ work-area ":\n====\n exit code " (vector-ref exit-info 2) "\n" "====\n") (if (not (vector-ref exit-info 1)) (exit 4))))))) ;; set up the very basics needed for doing anything here. -(define (setup-for-run) +(define (launch:setup-for-run #!key (force #f)) ;; would set values for KEYS in the environment here for better support of env-override but ;; have chicken/egg scenario. need to read megatest.config then read it again. Going to ;; pass on that idea for now ;; special case - (if (not (hash-table? *configdat*)) ;; no need to re-open on every call + (if (or force (not (hash-table? *configdat*))) ;; no need to re-open on every call (begin (set! *configinfo* (find-and-read-config (if (args:get-arg "-config")(args:get-arg "-config") "megatest.config") environ-patt: "env-override" given-toppath: (get-environment-variable "MT_RUN_AREA_HOME") pathenvvar: "MT_RUN_AREA_HOME")) (set! *configdat* (if (car *configinfo*)(car *configinfo*) #f)) (set! *toppath* (if (car *configinfo*)(cadr *configinfo*) #f)) - (if *toppath* - (let ((dbdir (conc *toppath* "/db"))) - (handle-exceptions - exn - (debug:print 0 "ERROR: failed to create the " dbdir " area for your database files") - (if (not (directory-exists? dbdir))(create-directory dbdir))) - (setenv "MT_RUN_AREA_HOME" *toppath*)) - (debug:print 0 "ERROR: failed to find the top path to your Megatest area.")))) + (let ((linktree (configf:lookup *configdat* "setup" "linktree"))) ;; link tree is critical + (if linktree + (if (not (file-exists? linktree)) + (begin + (handle-exceptions + exn + (begin + (debug:print 0 "ERROR: Something went wrong when trying to create linktree dir at " linktree) + (exit 1)) + (create-directory linktree #t)))) + (begin + (debug:print 0 "ERROR: linktree not defined in [setup] section of megatest.config") + (exit 1))) + (if linktree + (let ((dbdir (conc linktree "/.db"))) + (handle-exceptions + exn + (debug:print 0 "ERROR: failed to create the " dbdir " area for your database files") + (if (not (directory-exists? dbdir))(create-directory dbdir))) + (setenv "MT_LINKTREE" linktree)) + (begin + (debug:print 0 "ERROR: linktree is required in your megatest.config [setup] section") + (exit 1))) + (if (and *toppath* + (directory-exists? *toppath*)) + (setenv "MT_RUN_AREA_HOME" *toppath*) + (begin + (debug:print 0 "ERROR: failed to find the top path to your Megatest area.") + (exit 1)))))) *toppath*) (define (get-best-disk confdat) (let* ((disks (hash-table-ref/default confdat "disks" #f)) (best #f) @@ -438,25 +490,35 @@ (bestsize 0)) (if disks (for-each (lambda (disk-num) (let* ((dirpath (cadr (assoc disk-num disks))) - (freespc (if (and (directory? dirpath) - (file-write-access? dirpath)) - (get-df dirpath) - (begin - (debug:print 0 "WARNING: path " dirpath " in [disks] section not valid or writable") - 0)))) + (freespc (cond + ((not (directory? dirpath)) + (if (common:low-noise-print 20 "disks" disk-num) + (debug:print 0 "WARNING: disk " disk-num " at path " dirpath " is not a directory - ignoring it.")) + -1) + ((not (file-write-access? dirpath)) + (if (common:low-noise-print 20 "disks" disk-num) + (debug:print 0 "WARNING: disk " disk-num " at path " dirpath " is not writeable - ignoring it.")) + -1) + ((not (eq? (string-ref dirpath 0) #\/)) + (if (common:low-noise-print 20 "disks" disk-num) + (debug:print 0 "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 dirpath) (set! bestsize freespc))))) (map car disks))) - (if best + (if (and best (> bestsize 0)) best (begin - (debug:print 0 "ERROR: No valid disks found in megatest.config. Please add some to your [disks] section") + (if (common:low-noise-print 20 "no valid disks") + (debug:print 0 "ERROR: No valid disks found in megatest.config. Please add some to your [disks] section and ensure the directory exists!")) (exit 1))))) ;; Desired directory structure: ;; ;; - - -. @@ -470,13 +532,13 @@ ;; ;; All log file links should be stored relative to the top of link path ;; ;; - [ - ] ;; -(define (create-work-area run-id run-info keyvals test-id test-src-path disk-path testname itemdat) +(define (create-work-area run-id run-info keyvals test-id test-src-path disk-path testname itemdat #!key (remtries 2)) (let* ((item-path (item-list->path itemdat)) - (runname (db:get-value-by-header (db:get-row run-info) + (runname (db:get-value-by-header (db:get-rows run-info) (db:get-header run-info) "runname")) ;; convert back to db: from rdb: - this is always run at server end (target (string-intersperse (map cadr keyvals) "/")) @@ -492,16 +554,18 @@ ;; ensure this exists first as links to subtests must be created there (linktree (let ((rd (config-lookup *configdat* "setup" "linktree"))) (if rd rd (conc *toppath* "/runs")))) - (lnkbase (conc linktree "/" target "/" runname)) - (lnkpath (conc lnkbase "/" testname)) - (lnkpathf (conc lnkpath (if not-iterated "" "/") item-path))) + (lnkbase (conc linktree "/" target "/" runname)) + (lnkpath (conc lnkbase "/" testname)) + (lnkpathf (conc lnkpath (if not-iterated "" "/") item-path)) + (lnktarget (conc lnkpath "/" item-path))) - ;; Update the rundir path in the test record for all - (rmt:general-call 'test-set-rundir-by-test-id lnkpathf test-id) + ;; Update the rundir path in the test record for all, rundir=physical, shortdir=logical + ;; rundir shortdir + (rmt:general-call 'test-set-rundir-shortdir run-id lnkpathf test-path testname item-path) (debug:print 2 "INFO:\n lnkbase=" lnkbase "\n lnkpath=" lnkpath "\n toptest-path=" toptest-path "\n test-path=" test-path) (if (not (file-exists? linktree)) (begin (debug:print 0 "WARNING: linktree did not exist! Creating it now at " linktree) @@ -514,25 +578,10 @@ ;; update the toptest record with its location rundir, cache the path ;; This wass highly inefficient, one db write for every subtest, potentially ;; thousands of unnecessary updates, cache the fact it was set and don't set it ;; again. - ;; NB - This is not working right - some top tests are not getting the path set!!! - - (if (not (hash-table-ref/default *toptest-paths* testname #f)) - (let* ((testinfo (rmt:get-test-info-by-id test-id)) ;; run-id testname item-path)) - (curr-test-path (if testinfo (db:test-get-rundir testinfo) #f))) - (hash-table-set! *toptest-paths* testname curr-test-path) - ;; NB// Was this for the test or for the parent in an iterated test? - (rmt:general-call 'test-set-rundir lnkpath run-id testname "") ;; toptest-path) - (if (or (not curr-test-path) - (not (directory-exists? toptest-path))) - (begin - (debug:print-info 2 "Creating " toptest-path " and link " lnkpath) - (create-directory toptest-path #t) - (hash-table-set! *toptest-paths* testname toptest-path))))) - ;; Now create the link from the test path to the link tree, however ;; if the test is iterated it is necessary to create the parent path ;; to the iteration. use pathname-directory to trim the path by one ;; level (if (not not-iterated) ;; i.e. iterated @@ -560,14 +609,42 @@ (begin (debug:print 0 "ERROR: Failed to create symlink " lnkpath ((condition-property-accessor 'exn 'message) exn) ", exiting") (exit 1)) (create-symbolic-link toptest-path lnkpath))) + ;; NB - This was not working right - some top tests are not getting the path set!!! + ;; + ;; Do the setting of this record after the paths are created so that the shortdir can + ;; be set to the real directory location. This is safer for future clean up if the link + ;; tree is damaged or lost. + ;; + (if (not (hash-table-ref/default *toptest-paths* testname #f)) + (let* ((testinfo (rmt:get-test-info-by-id run-id test-id)) ;; run-id testname item-path)) + (curr-test-path (if testinfo ;; (filedb:get-path *fdb* + ;; (db:get-path dbstruct + ;; (rmt:sdb-qry 'getstr + (db:test-get-rundir testinfo) ;; ) ;; ) + #f))) + (hash-table-set! *toptest-paths* testname curr-test-path) + ;; NB// Was this for the test or for the parent in an iterated test? + (rmt:general-call 'test-set-rundir-shortdir run-id lnkpath + (if (file-exists? lnkpath) + (resolve-pathname lnkpath) + lnkpath) + testname "") + ;; (rmt:general-call 'test-set-rundir run-id lnkpath testname "") ;; toptest-path) + (if (or (not curr-test-path) + (not (directory-exists? toptest-path))) + (begin + (debug:print-info 2 "Creating " toptest-path " and link " lnkpath) + (create-directory toptest-path #t) + (hash-table-set! *toptest-paths* testname toptest-path))))) + ;; The toptest path has been created, the link to the test in the linktree has ;; been created. Now, if this is an iterated test the real test dir must be created (if (not not-iterated) ;; this is an iterated test - (let ((lnktarget (conc lnkpath "/" item-path))) + (begin ;; (let ((lnktarget (conc lnkpath "/" item-path))) (debug:print 2 "Setting up sub test run area") (debug:print 2 " - creating run area in " test-path) (handle-exceptions exn (begin @@ -585,10 +662,13 @@ (debug:print 0 "ERROR: Failed to re-create link " linktarget ((condition-property-accessor 'exn 'message) exn) ", exiting") (exit)) (if (symbolic-link? lnktarget) (delete-file lnktarget)) (if (not (file-exists? lnktarget)) (create-symbolic-link test-path lnktarget))))) + (if (not (directory? test-path)) + (create-directory test-path #t)) ;; this is a hack, I don't know why out of the blue this path does not exist sometimes + (if (directory? test-path) (begin (let* ((ovrcmd (let ((cmd (config-lookup *configdat* "setup" "testcopycmd"))) (if cmd ;; substitute the TEST_SRC_PATH and TEST_TARG_PATH @@ -601,11 +681,16 @@ " >> " test-path "/mt_launch.log 2>> " test-path "/mt_launch.log"))) (status (system cmd))) (if (not (eq? status 0)) (debug:print 2 "ERROR: problem with running \"" cmd "\""))) (list lnkpathf lnkpath )) - (list #f #f)))) + (if (> remtries 0) + (begin + (debug:print 0 "ERROR: Failed to create work area at " test-path " with link at " lnktarget ", remaining attempts " remtries) + ;; + (create-work-area run-id run-info keyvals test-id test-src-path disk-path testname itemdat remtries: (- remtries 1))) + (list #f #f))))) ;; 1. look though disks list for disk with most space ;; 2. create run dir on disk, path name is meaningful ;; 3. create link from run dir to megatest runs area ;; 4. remotely run the test on allocated host @@ -644,24 +729,24 @@ (local-megatest (let* ((lm (car (argv))) (dir (pathname-directory lm)) (exe (pathname-strip-directory lm))) (conc (if dir (conc dir "/") "") (case (string->symbol exe) - ((dboard) "megatest") - ((mtest) "megatest") + ((dboard) "../megatest") + ((mtest) "../megatest") ((dashboard) "megatest") (else exe))))) - (test-sig (conc test-name ":" (item-list->path itemdat))) ;; test-path is the full path including the item-path + (item-path (item-list->path itemdat)) + (test-sig (conc test-name ":" item-path)) ;; (item-list->path itemdat))) ;; test-path is the full path including the item-path (work-area #f) (toptest-work-area #f) ;; for iterated tests the top test contains data relevant for all (diskpath #f) (cmdparms #f) (fullcmd #f) ;; (define a (with-output-to-string (lambda ()(write x)))) (mt-bindir-path #f) - (item-path (item-list->path itemdat)) ;; (test-id (cdb:remote-run db:get-test-id #f run-id test-name item-path)) - (testinfo (rmt:get-test-info-by-id test-id)) + (testinfo (rmt:get-test-info-by-id run-id test-id)) (mt_target (string-intersperse (map cadr keyvals) "/")) (debug-param (append (if (args:get-arg "-debug") (list "-debug" (args:get-arg "-debug")) '()) (if (args:get-arg "-logging")(list "-logging") '())))) (setenv "MT_ITEMPATH" item-path) (if hosts (set! hosts (string-split hosts))) @@ -668,10 +753,20 @@ ;; set the megatest to be called on the remote host (if (not remote-megatest)(set! remote-megatest local-megatest)) ;; "megatest")) (set! mt-bindir-path (pathname-directory remote-megatest)) (if launcher (set! launcher (string-split launcher))) ;; set up the run work area for this test + (if (and (args:get-arg "-preclean") ;; user has requested to preclean for this run + (not (member (db:test-get-rundir testinfo)(list "n/a" "/tmp/badname")))) ;; n/a is a placeholder and thus not a read dir + (begin + (debug:print-info 0 "attempting to preclean directory " (db:test-get-rundir testinfo) " for test " test-name "/" item-path) + (runs:remove-test-directory #f testinfo #t))) ;; remove data only, do not perturb the record + + ;; prevent overlapping actions - set to LAUNCHED as early as possible + ;; + (tests:test-set-status! run-id test-id "LAUNCHED" "n/a" #f #f) ;; (if launch-results launch-results "FAILED")) + (rmt:roll-up-pass-fail-counts run-id test-name item-path "LAUNCHED") (set! diskpath (get-best-disk *configdat*)) (if diskpath (let ((dat (create-work-area run-id run-info keyvals test-id test-path diskpath test-name itemdat))) (set! work-area (car dat)) (set! toptest-work-area (cadr dat)) @@ -679,36 +774,36 @@ (begin (set! work-area (conc test-path "/tmp_run")) (create-directory work-area #t) (debug:print 0 "WARNING: No disk work area specified - running in the test directory under tmp_run"))) (set! cmdparms (base64:base64-encode - (with-output-to-string - (lambda () ;; (list 'hosts hosts) - (write (list (list 'testpath test-path) - ;; (list 'runremote *runremote*) - (list 'transport (conc *transport-type*)) - (list 'serverinf *server-info*) - (list 'toppath *toppath*) - (list 'work-area work-area) - (list 'test-name test-name) - (list 'runscript runscript) - (list 'run-id run-id ) - (list 'test-id test-id ) - (list 'itemdat itemdat ) - (list 'megatest remote-megatest) - (list 'ezsteps ezsteps) - (list 'target mt_target) - (list 'runtlim (if run-time-limit (common:hms-string->seconds run-time-limit) #f)) - (list 'env-ovrd (hash-table-ref/default *configdat* "env-override" '())) - (list 'set-vars (if params (hash-table-ref/default params "-setvars" #f))) - (list 'runname runname) - (list 'mt-bindir-path mt-bindir-path))))))) + (z3:encode-buffer + (with-output-to-string + (lambda () ;; (list 'hosts hosts) + (write (list (list 'testpath test-path) + (list 'transport (conc *transport-type*)) + (list 'serverinf *server-info*) + (list 'toppath *toppath*) + (list 'work-area work-area) + (list 'test-name test-name) + (list 'runscript runscript) + (list 'run-id run-id ) + (list 'test-id test-id ) + ;; (list 'item-path item-path ) + (list 'itemdat itemdat ) + (list 'megatest remote-megatest) + (list 'ezsteps ezsteps) + (list 'target mt_target) + (list 'runtlim (if run-time-limit (common:hms-string->seconds run-time-limit) #f)) + (list 'env-ovrd (hash-table-ref/default *configdat* "env-override" '())) + (list 'set-vars (if params (hash-table-ref/default params "-setvars" #f))) + (list 'runname runname) + (list 'mt-bindir-path mt-bindir-path)))))))) + ;; clean out step records from previous run if they exist - ;; (debug:print-info 4 "FIXMEEEEE!!!! This can be removed some day, perhaps move all test records to the test db?") - ;; (open-run-close db:delete-test-step-records db test-id) + ;; (rmt:delete-test-step-records run-id test-id) (change-directory work-area) ;; so that log files from the launch process don't clutter the test dir - (tests:test-set-status! test-id "LAUNCHED" "n/a" #f #f) ;; (if launch-results launch-results "FAILED")) (cond ((and launcher hosts) ;; must be using ssh hostname (set! fullcmd (append launcher (car hosts)(list remote-megatest test-sig "-execute" cmdparms) debug-param))) ;; (set! fullcmd (append launcher (car hosts)(list remote-megatest test-sig "-execute" cmdparms)))) (launcher Index: lock-queue.scm ================================================================== --- lock-queue.scm +++ lock-queue.scm @@ -21,60 +21,91 @@ ;;====================================================================== ;; attempt to prevent overlapping updates of rollup files by queueing ;; update requests in an sqlite db ;;====================================================================== -(define (lock-queue:open-db fname) +(define (lock-queue:open-db fname #!key (count 10)) (let* ((actualfname (conc fname ".lockdb")) (dbexists (file-exists? actualfname)) (db (sqlite3:open-database actualfname)) (handler (make-busy-timeout 136000))) (if dbexists db (begin - (sqlite3:execute - db - "CREATE TABLE IF NOT EXISTS queue ( + (handle-exceptions + exn + (begin + (thread-sleep! 10) + (if (> count 0) + (lock-queue:open-db fname count: (- count 1)) + db)) + (sqlite3:execute + db + "CREATE TABLE IF NOT EXISTS queue ( id INTEGER PRIMARY KEY, test_id INTEGER, start_time INTEGER, state TEXT, CONSTRAINT queue_constraint UNIQUE (test_id));") - (sqlite3:execute - db - "CREATE TABLE IF NOT EXISTS runlocks ( + (sqlite3:execute + db + "CREATE TABLE IF NOT EXISTS runlocks ( id INTEGER PRIMARY KEY, test_id INTEGER, run_lock TEXT, - CONSTRAINT runlock_constraint UNIQUE (run_lock));"))) + CONSTRAINT runlock_constraint UNIQUE (run_lock));")))) (sqlite3:set-busy-handler! db handler) db)) -(define (lock-queue:set-state db test-id newstate) - (sqlite3:execute db "UPDATE queue SET state=? WHERE test_id=?;" - newstate - test-id)) - -(define (lock-queue:any-younger? db mystart test-id) - (let ((res #f)) - (sqlite3:for-each-row - (lambda (tid) - ;; Actually this should not be needed as mystart cannot be simultaneously less than and test-id same as - (if (not (equal? tid test-id)) - (set! res tid))) - db - "SELECT test_id FROM queue WHERE start_time > ?;" mystart) - res)) - -(define (lock-queue:get-lock db test-id) +(define (lock-queue:set-state db test-id newstate #!key (remtries 10)) + (handle-exceptions + exn + (if (> remtries 0) + (begin + (debug:print 0 "WARNING: exception on lock-queue:set-state. Trying again in 30 seconds.") + (thread-sleep! 30) + (lock-queue:set-state db test-id newstate remtries: (- remtries 1))) + (begin + (debug:print 0 "ERROR: Failed to set lock state for test with id " test-id ", error: " ((condition-property-accessor 'exn 'message) exn) ", giving up.") + #f)) + (sqlite3:execute db "UPDATE queue SET state=? WHERE test_id=?;" + newstate + test-id))) + +(define (lock-queue:any-younger? db mystart test-id #!key (remtries 10)) + (handle-exceptions + exn + (if (> remtries 0) + (begin + (debug:print 0 "WARNING: exception on lock-queue:any-younger. Trying again in 30 seconds.") + (thread-sleep! 30) + (lock-queue:any-younger? db mystart test-id remtries: (- remtries 1))) + (begin + (debug:print 0 "ERROR: Failed to find younger locks for test with id " test-id ", error: " ((condition-property-accessor 'exn 'message) exn) ", giving up.") + #f)) + (let ((res #f)) + (sqlite3:for-each-row + (lambda (tid) + ;; Actually this should not be needed as mystart cannot be simultaneously less than and test-id same as + (if (not (equal? tid test-id)) + (set! res tid))) + db + "SELECT test_id FROM queue WHERE start_time > ?;" mystart) + res))) + +(define (lock-queue:get-lock db test-id #!key (count 10)) (let ((res #f) (lckqry (sqlite3:prepare db "SELECT test_id,run_lock FROM runlocks WHERE run_lock='locked';")) (mklckqry (sqlite3:prepare db "INSERT INTO runlocks (test_id,run_lock) VALUES (?,'locked');"))) (let ((result (handle-exceptions exn - #f + (begin + (thread-sleep! 10) + (if (> count 0) + (lock-queue:get-lock db test-id count: (- count 1))) + #f) (sqlite3:with-transaction db (lambda () (sqlite3:for-each-row (lambda (tid lockstate) (set! res (list tid lockstate))) @@ -89,46 +120,67 @@ #t))))))) (sqlite3:finalize! lckqry) (sqlite3:finalize! mklckqry) result))) -(define (lock-queue:release-lock fname test-id) +(define (lock-queue:release-lock fname test-id #!key (count 10)) (let ((db (lock-queue:open-db fname))) - (sqlite3:execute db "DELETE FROM runlocks WHERE test_id=?;" test-id) - (sqlite3:finalize! db))) + (handle-exceptions + exn + (begin + (thread-sleep! 10) + (if (> count 0) + (lock-queue:release-lock fname test-id count: (- count 1)) + #f)) + (sqlite3:execute db "DELETE FROM runlocks WHERE test_id=?;" test-id) + (sqlite3:finalize! db)))) -(define (lock-queue:steal-lock db test-id) - (sqlite3:execute db "DELETE FROM runlocks WHERE run_lock='locked';") +(define (lock-queue:steal-lock db test-id #!key (count 10)) + (handle-exceptions + exn + (begin + (thread-sleep! 10) + (if (> count 0) + (lock-queue:steal-lock db test-id count: (- count 1)) + #f)) + (sqlite3:execute db "DELETE FROM runlocks WHERE run_lock='locked';")) (lock-queue:get-lock db test-it)) ;; returns #f if ok to skip the task ;; returns #t if ok to proceed with task ;; otherwise waits ;; -(define (lock-queue:wait-turn fname test-id) +(define (lock-queue:wait-turn fname test-id #!key (count 10)) (let ((db (lock-queue:open-db fname)) (mystart (current-seconds))) - (sqlite3:execute - db - "INSERT OR REPLACE INTO queue (test_id,start_time,state) VALUES (?,?,'waiting');" - test-id mystart) - (thread-sleep! 1) ;; give other tests a chance to register - (let ((result - (let loop ((younger-waiting (lock-queue:any-younger? db mystart test-id))) - (if younger-waiting - (begin - ;; no need for us to wait. mark in the lock queue db as skipping - (lock-queue:set-state db test-id "skipping") - #f) ;; let the calling process know that nothing needs to be done - (if (lock-queue:get-lock db test-id) - #t - (if (> (- (current-seconds) mystart) 36000) ;; waited too long, steal the lock - (lock-queue:steal-lock db test-id) - (begin - (thread-sleep! 1) - (loop (lock-queue:any-younger? db mystart test-id))))))))) - (sqlite3:finalize! db) - result))) + (handle-exceptions + exn + (begin + (thread-sleep! 10) + (if (> count 0) + (lock-queue:wait-turn fname test-id count: (- count 1)) + #f)) + (sqlite3:execute + db + "INSERT OR REPLACE INTO queue (test_id,start_time,state) VALUES (?,?,'waiting');" + test-id mystart) + (thread-sleep! 1) ;; give other tests a chance to register + (let ((result + (let loop ((younger-waiting (lock-queue:any-younger? db mystart test-id))) + (if younger-waiting + (begin + ;; no need for us to wait. mark in the lock queue db as skipping + (lock-queue:set-state db test-id "skipping") + #f) ;; let the calling process know that nothing needs to be done + (if (lock-queue:get-lock db test-id) + #t + (if (> (- (current-seconds) mystart) 36000) ;; waited too long, steal the lock + (lock-queue:steal-lock db test-id) + (begin + (thread-sleep! 1) + (loop (lock-queue:any-younger? db mystart test-id))))))))) + (sqlite3:finalize! db) + result)))) ;; (use trace) ;; (trace lock-queue:get-lock lock-queue:release-lock lock-queue:wait-turn lock-queue:any-younger? lock-queue:set-state) Index: megatest-version.scm ================================================================== --- megatest-version.scm +++ megatest-version.scm @@ -1,7 +1,7 @@ -;; Always use two digit decimal -;; 1.01, 1.02...1.10,1.11 ... 1.99,2.00.. +;; 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.5514) +(define megatest-version 1.6003) Index: megatest.scm ================================================================== --- megatest.scm +++ megatest.scm @@ -8,11 +8,11 @@ ;; PURPOSE. ;; (include "common.scm") ;; (include "megatest-version.scm") -(use sqlite3 srfi-1 posix regex regex-case srfi-69 base64 format readline apropos json http-client) ;; (srfi 18) extras) +(use sqlite3 srfi-1 posix regex regex-case srfi-69 base64 format readline apropos json http-client directory-utils z3) ;; (srfi 18) extras) (import (prefix sqlite3 sqlite3:)) (import (prefix base64 base64:)) ;; (use zmq) @@ -25,13 +25,16 @@ (declare (uses client)) (declare (uses tests)) (declare (uses genexample)) (declare (uses daemon)) (declare (uses db)) +;; (declare (uses sdb)) +;; (declare (uses filedb)) (declare (uses tdb)) (declare (uses mt)) (declare (uses api)) +(declare (uses tasks)) ;; only used for debugging. (define *db* #f) ;; this is only for the repl, do not use in general!!!! (include "common_records.scm") (include "key_records.scm") @@ -41,10 +44,13 @@ (let ((debugcontrolf (conc (get-environment-variable "HOME") "/.megatestrc"))) (if (file-exists? debugcontrolf) (load debugcontrolf))) +;; Disabled help items +;; -rollup : (currently disabled) fill run (set by :runname) with latest test(s) +;; from prior runs with same keys (define help (conc " Megatest, documentation at http://www.kiatoa.com/fossils/megatest version " megatest-version " license GPL, Copyright Matt Welland 2006-2012 @@ -55,27 +61,28 @@ Launching and managing runs -runall : run all tests that are not state COMPLETED and status PASS, CHECK or KILLED -runtests tst1,tst2 ... : run tests - -remove-runs : remove the data for a run, requires :runname and -testpatt + -remove-runs : remove the data for a run, requires -runname and -testpatt Optionally use :state and :status -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) - -rollup : (currently disabled) fill run (set by :runname) with latest test(s) - from prior runs with same keys -lock : lock run specified by target and runname -unlock : unlock run specified by target and runname + -set-run-status status : sets status for run to status, requires -target and -runname + -get-run-status : gets status for run specified by target and runname -run-wait : wait on run specified by target and runname + -preclean : remove the existing test directory before running the test Selectors (e.g. use for -runtests, -remove-runs, -set-state-status, -list-runs etc.) -target key1/key2/... : run for key1, key2, etc. -reqtarg key1/key2/... : run for key1, key2, etc. but key1/key2 must be in runconfig -testpatt patt1/patt2,patt3/... : % is wildcard - :runname : required, name for this particular test run - :state : Applies to runs, tests or steps depending on context - :status : Applies to runs, tests or steps depending on context + -runname : required, name for this particular test run + -state : Applies to runs, tests or steps depending on context + -status : Applies to runs, tests or steps depending on context Test helpers (for use inside tests) -step stepname -test-status : set the state and status of a test (use :state and :status) -setlog logfname : set the path/filename to the final log relative to the test @@ -108,28 +115,39 @@ -list-db-targets : list the target combinations used in the db -show-config : dump the internal representation of the megatest.config file -show-runconfig : dump the internal representation of the runconfigs.config file -dumpmode json : dump in json format instead of sexpr -show-cmdinfo : dump the command info for a test (run in test environment) + -section sectionName + -var varName : for config and runconfig lookup value for sectionName varName Misc + -start-dir path : switch to this directory before running megatest -rebuild-db : bring the database schema up to date -cleanup-db : remove any orphan records, vacuum the db + -import-megatest.db : migrate a database from v1.55 series to v1.60 series + -sync-to-megatest.db : migrate data back to megatest.db -update-meta : update the tests metadata for all tests - -env2file fname : write the environment to fname.csh and fname.sh -setvars VAR1=val1,VAR2=val2 : Add environment variables to a run NB// these are overwritten by values set in config files. -server -|hostname : start the server (reduces contention on megatest.db), use - to automatically figure out hostname - -transport http|fs : use http or direct access for transport (default is http) -daemonize : fork into background and disconnect from stdin/out + -log logfile : send stdout and stderr to logfile -list-servers : list the servers -stop-server id : stop server specified by id (see output of -list-servers), use 0 to kill all -repl : start a repl (useful for extending megatest) -load file.scm : load and run file.scm -mark-incompletes : find and mark incomplete tests + -ping run-id|host:port : ping server, exit with 0 if found + +Utilities + -env2file fname : write the environment to fname.csh and fname.sh + -refdb2dat refdb : convert refdb to sexp or to format specified by -dumpmode + formats: perl, ruby, sqlite3 + -o : output file for refdb2dat (defaults to stdout) Spreadsheet generation -extract-ods fname.ods : extract an open document spreadsheet from the database -pathmod path : insert path, i.e. path/runame/itempath/logfile.html will clear the field if no rundir/testname/itempath/logfile @@ -140,11 +158,11 @@ -gen-megatest-test tname : create a skeleton megatest test. You will be prompted for info 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% +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 @@ -155,11 +173,10 @@ (argv) (list "-runtests" ;; run a specific test "-config" ;; override the config file name "-execute" ;; run the command encoded in the base64 parameter "-step" - ":runname" "-target" "-reqtarg" ":runname" "-runname" ":state" @@ -184,27 +201,35 @@ ":value" ":expected" ":tol" ":units" ;; misc + "-start-dir" "-server" - "-transport" "-stop-server" "-port" "-extract-ods" "-pathmod" "-env2file" "-setvars" "-set-state-status" + "-set-run-status" "-debug" ;; for *verbosity* > 2 "-gen-megatest-test" "-override-timeout" "-test-files" ;; -test-paths is for listing all "-load" ;; load and exectute a scheme file + "-section" + "-var" "-dumpmode" + "-run-id" + "-ping" + "-refdb2dat" + "-o" + "-log" ) - (list "-h" + (list "-h" "-help" "--help" "-version" "-force" "-xterm" "-showkeys" "-show-keys" @@ -212,10 +237,11 @@ "-set-values" "-load-test-data" "-summarize-items" "-gui" "-daemonize" + "-preclean" ;; misc "-archive" "-repl" "-lock" "-unlock" @@ -227,10 +253,12 @@ "-list-targets" "-list-db-targets" "-show-runconfig" "-show-config" "-show-cmdinfo" + "-get-run-status" + ;; queries "-test-paths" ;; get path(s) to a test, ordered by youngest first "-runall" ;; run all tests "-remove-runs" @@ -239,21 +267,41 @@ "-rollup" "-update-meta" "-gen-megatest-area" "-mark-incompletes" + "-convert-to-norm" + "-convert-to-old" + "-import-megatest.db" + "-sync-to-megatest.db" + "-logging" "-v" ;; verbose 2, more than normal (normal is 1) "-q" ;; quiet 0, errors/warnings only ) args:arg-hash 0)) -(if (args:get-arg "-h") +(if (args:get-arg "-log") + (let ((oup (open-output-file (args:get-arg "-log")))) + (debug:print-info 0 "Sending log output to " (args:get-arg "-log")) + (current-error-port oup) + (current-output-port oup))) + +(if (or (args:get-arg "-h") + (args:get-arg "-help") + (args:get-arg "--help")) (begin (print help) (exit))) + +(if (args:get-arg "-start-dir") + (if (file-exists? (args:get-arg "-start-dir")) + (change-directory (args:get-arg "-start-dir")) + (begin + (debug:print 0 "ERROR: non-existant start dir " (args:get-arg "-start-dir") " specified, exiting.") + (exit 1)))) (if (args:get-arg "-version") (begin (print megatest-version) (exit))) @@ -282,16 +330,10 @@ (printf "Sending signal/term to ~A\n" pid) (process-signal pid signal/term)))))) (process:children #f)) (original-exit exit-code))))) -;; Force default transport to fs -;; (if ;; (and (or (args:get-arg "-list-targets") -;; ;; (args:get-arg "-list-db-targets")) -;; (not (args:get-arg "-transport")) -;; (hash-table-set! args:arg-hash "-transport" "fs")) - ;;====================================================================== ;; Misc setup stuff ;;====================================================================== (debug:setup) @@ -305,10 +347,19 @@ (let ((newval (conc (args:get-arg "-testpatt") "/" (args:get-arg "-itempatt")))) (debug:print 0 "WARNING: -itempatt has been deprecated, please use -testpatt testpatt/itempatt method, new testpatt is "newval) (hash-table-set! args:arg-hash "-testpatt" newval) (hash-table-delete! args:arg-hash "-itempatt"))) +(on-exit (lambda () + (rmt:print-db-stats) + (let ((run-ids (hash-table-keys *db-local-sync*))) + (if (not (null? run-ids)) + (db:multi-db-sync run-ids 'new2old))) + (if *dbstruct-db* (db:close-all *dbstruct-db*)) + (if *megatest-db* (sqlite3:finalize! *megatest-db*)) + (if *task-db* (sqlite3:finalize! (vector-ref *task-db* 0))))) + ;;====================================================================== ;; Misc general calls ;;====================================================================== (if (args:get-arg "-env2file") @@ -315,104 +366,132 @@ (begin (save-environment-as-files (args:get-arg "-env2file")) (set! *didsomething* #t))) (if (args:get-arg "-list-disks") - (begin + (let ((toppath (launch:setup-for-run))) (print (string-intersperse (map (lambda (x) (string-intersperse x " => ")) - (common:get-disks) ) + (common:get-disks *configdat*)) "\n")) (set! *didsomething* #t))) +(if (args:get-arg "-refdb2dat") + (let* ((input-db (args:get-arg "-refdb2dat")) + (out-file (args:get-arg "-o")) + (out-fmt (or (args:get-arg "-dumpmode") "scheme")) + (out-port (if (and out-file + (not (equal? out-fmt "sqlite3"))) + (open-output-file out-file) + (current-output-port))) + (res-data (configf:read-refdb input-db)) + (data (car res-data)) + (msg (cadr res-data))) + (if (not data) + (debug:print 0 data) ;; some error occurred + (with-output-to-port out-port + (lambda () + (case (string->symbol out-fmt) + ((scheme)(pp data)) + ((perl) + ;; (print "%hash = (") + ;; key1 => 'value1', + ;; key2 => 'value2', + ;; key3 => 'value3', + ;; ); + (configf:map-all-hier-alist + data + (lambda (sheetname sectionname varname val) + (print "$data{\"" sheetname "\"}{\"" sectionname "\"}{\"" varname "\"} = \"" val "\";")))) + ((python ruby) + (print "data={}") + (configf:map-all-hier-alist + data + (lambda (sheetname sectionname varname val) + (print "data[\"" sheetname "\"][\"" sectionname "\"][\"" varname "\"] = \"" val "\"")) + initproc1: + (lambda (sheetname) + (print "data[\"" sheetname "\"] = {}")) + initproc2: + (lambda (sheetname sectionname) + (print "data[\"" sheetname "\"][\"" sectionname "\"] = {}")))) + ((sqlite3) + (let* ((db-file (or out-file (pathname-file input-db))) + (db-exists (file-exists? db-file)) + (db (sqlite3:open-database db-file))) + (if (not db-exists)(sqlite3:execute db "CREATE TABLE data (sheet,section,var,val);")) + (configf:map-all-hier-alist + data + (lambda (sheetname sectionname varname val) + (sqlite3:execute db + "INSERT OR REPLACE INTO data (sheet,section,var,val) VALUES (?,?,?,?);" + sheetname sectionname varname val))) + (sqlite3:finalize! db))) + (else + (pp data)))))) + (if out-file (close-output-port out-port)) + (exit) ;; yes, bending the rules here - need to exit since this is a utility + )) + +(if (args:get-arg "-ping") + (let* ((run-id (string->number (args:get-arg "-run-id"))) + (host:port (args:get-arg "-ping"))) + (server:ping run-id host:port))) + ;;====================================================================== ;; Start the server - can be done in conjunction with -runall or -runtests (one day...) ;; we start the server if not running else start the client thread ;;====================================================================== (if (args:get-arg "-server") ;; Server? Start up here. ;; - (let ((tl (setup-for-run)) - (transport (or (configf:lookup *configdat* "setup" "transport") - (args:get-arg "-transport" "http")))) - (debug:print 2 "Launching server using transport " transport) - (server:launch (string->symbol transport))) + (let ((tl (launch:setup-for-run)) + (run-id (and (args:get-arg "-run-id") + (string->number (args:get-arg "-run-id"))))) + (if run-id + (begin + (server:launch run-id) + (set! *didsomething* #t)) + (debug:print 0 "ERROR: server requires run-id be specified with -run-id"))) ;; Not a server? This section will decide how to communicate ;; ;; Setup client for all expect listed here (if (null? (lset-intersection equal? (hash-table-keys args:arg-hash) '("-list-servers" "-stop-server" - "-show-cmdinfo"))) - (if (setup-for-run) - (begin - + "-show-cmdinfo" + "-list-runs"))) + (if (launch:setup-for-run) + (let ((run-id (and (args:get-arg "-run-id") + (string->number (args:get-arg "-run-id"))))) + ;; (set! *fdb* (filedb:open-db (conc *toppath* "/db/paths.db"))) ;; if not list or kill then start a client (if appropriate) (if (or (args-defined? "-h" "-version" "-gen-megatest-area" "-gen-megatest-test") (eq? (length (hash-table-keys args:arg-hash)) 0)) (debug:print-info 1 "Server connection not needed") - ;; ok, so lets connect to the server - (let* ((transport-from-config (configf:lookup *configdat* "setup" "transport")) - (transport-from-cmdln (args:get-arg "-transport")) - (transport-from-cmdinfo (if (getenv "MT_CMDINFO") - (let ((res (assoc 'transport - (read - (open-input-string - (base64:base64-decode - (getenv "MT_CMDINFO"))))))) - (if res (cadr res) #f)) - #f)) - (chosen-transport (string->symbol (or transport-from-cmdln - transport-from-cmdinfo - transport-from-config - "fs")))) - (debug:print 2 "chosen-transport: " chosen-transport " have; config=" transport-from-config ", cmdln=" transport-from-cmdln ", cmdinfo=" transport-from-cmdinfo) - (case chosen-transport - ((http) - (set! *transport-type 'http) - (server:ensure-running) - (client:launch)) - (else ;; (fs) - (set! *transport-type* 'fs) - (set! *megatest-db* (open-db)))))))))) -;; (cond -;; ;; command line overrides other mechanisms -;; (transport-from-cmdln -;; (if (equal? transport-from-cmdln "fs") -;; (set! *transport-type* 'fs) -;; (begin -;; (server:ensure-running) -;; (client:launch)))) -;; ;; cmdinfo is second priority -;; (transport-from-cmdinfo -;; (if (equal? transport-from-cmdinfo "fs") -;; (set! *transport-type* 'fs) -;; (begin -;; (server:ensure-running) -;; (client:launch)))) -;; ;; config file is next highest priority for determinining transport -;; (transport-from-config -;; (if (equal? transport-from-config "fs") -;; (set! *transport-type* 'fs) -;; (begin -;; (server:ensure-running) -;; (client:launch)))) -;; (else -;; (set! *transport-type* 'fs))))))))) + (begin + ;; (if run-id + ;; (client:launch run-id) + ;; (client:launch 0) ;; without run-id we'll start a server for "0" + #t + )))))) + +;; MAY STILL NEED THIS +;; (set! *megatest-db* (make-dbr:dbstruct path: *toppath* local: #t)))))))))) (if (or (args:get-arg "-list-servers") (args:get-arg "-stop-server")) - (let ((tl (setup-for-run))) + (let ((tl (launch:setup-for-run))) (if tl (let* ((servers (open-run-close tasks:get-all-servers tasks:open-db)) (fmtstr "~5a~12a~8a~20a~24a~10a~10a~10a~10a\n") (servers-to-kill '()) (killinfo (args:get-arg "-stop-server")) @@ -430,11 +509,11 @@ (pubport (vector-ref server 5)) (start-time (vector-ref server 6)) (priority (vector-ref server 7)) (state (vector-ref server 8)) (mt-ver (vector-ref server 9)) - (last-update (vector-ref server 10)) ;; (open-run-close tasks:server-alive? tasks:open-db #f hostname: hostname port: port)) + (last-update (vector-ref server 10)) (transport (vector-ref server 11)) (killed #f) (status (< last-update 20))) ;; (zmq-sockets (if status (server:client-connect hostname port) #f))) ;; no need to login as status of #t indicates we are connecting to correct @@ -470,55 +549,64 @@ targets) (set! *didsomething* #t))) (define (full-runconfigs-read) (let* ((keys (rmt:get-keys)) - (target (if (args:get-arg "-reqtarg") - (args:get-arg "-reqtarg") - (if (args:get-arg "-target") - (args:get-arg "-target") - #f))) + (target (common:args-get-target)) (key-vals (if target (keys:target->keyval keys target) #f)) (sections (if target (list "default" target) #f)) (data (begin (setenv "MT_RUN_AREA_HOME" *toppath*) (if key-vals (for-each (lambda (kt) (setenv (car kt) (cadr kt))) key-vals)) - (read-config "runconfigs.config" #f #t sections: sections)))) + (read-config (conc *toppath* "/runconfigs.config") #f #t sections: sections)))) data)) (if (args:get-arg "-show-runconfig") - (let ((data (full-runconfigs-read))) - ;; keep this one local - (cond - ((not (args:get-arg "-dumpmode")) - (pp (hash-table->alist data))) - ((string=? (args:get-arg "-dumpmode") "json") + (let ((tl (launch:setup-for-run))) + (push-directory *toppath*) + (let ((data (full-runconfigs-read))) + ;; keep this one local + (cond + ((and (args:get-arg "-section") + (args:get-arg "-var")) + (let ((val (configf:lookup data (args:get-arg "-section")(args:get-arg "-var")))) + (if val (print val)))) + ((not (args:get-arg "-dumpmode")) + (pp (hash-table->alist data))) + ((string=? (args:get-arg "-dumpmode") "json") (json-write data)) - (else - (debug:print 0 "ERROR: -dumpmode of " (args:get-arg "-dumpmode") " not recognised"))) - (set! *didsomething* #t))) + (else + (debug:print 0 "ERROR: -dumpmode of " (args:get-arg "-dumpmode") " not recognised"))) + (set! *didsomething* #t)) + (pop-directory))) (if (args:get-arg "-show-config") - (let ((tl (setup-for-run)) + (let ((tl (launch:setup-for-run)) (data *configdat*)) ;; (read-config "megatest.config" #f #t))) + (push-directory *toppath*) ;; keep this one local (cond + ((and (args:get-arg "-section") + (args:get-arg "-var")) + (let ((val (configf:lookup data (args:get-arg "-section")(args:get-arg "-var")))) + (if val (print val)))) ((not (args:get-arg "-dumpmode")) (pp (hash-table->alist data))) ((string=? (args:get-arg "-dumpmode") "json") (json-write data)) (else (debug:print 0 "ERROR: -dumpmode of " (args:get-arg "-dumpmode") " not recognised"))) - (set! *didsomething* #t))) + (set! *didsomething* #t) + (pop-directory))) (if (args:get-arg "-show-cmdinfo") (if (getenv "MT_CMDINFO") - (let ((data (read (open-input-string (base64:base64-decode (getenv "MT_CMDINFO")))))) + (let ((data (common:read-encoded-string (getenv "MT_CMDINFO")))) (if (equal? (args:get-arg "-dumpmode") "json") (json-write data) (pp data)) (set! *didsomething* #t)) (debug:print-info 0 "environment variable MT_CMDINFO is not set"))) @@ -529,18 +617,18 @@ ;; since several actions can be specified on the command line the removal ;; is done first (define (operate-on action) (let* ((runrec (runs:runrec-make-record)) - (target (or (args:get-arg "-reqtarg") - (args:get-arg "-target")))) + (target (common:args-get-target))) (cond ((not target) (debug:print 0 "ERROR: Missing required parameter for " action ", you must specify -target or -reqtarg") (exit 1)) - ((not (args:get-arg ":runname")) - (debug:print 0 "ERROR: Missing required parameter for " action ", you must specify the run name pattern with :runname patt") + ((not (or (args:get-arg ":runname") + (args:get-arg "-runname"))) + (debug:print 0 "ERROR: Missing required parameter for " action ", you must specify the run name pattern with -runname patt") (exit 2)) ((not (args:get-arg "-testpatt")) (debug:print 0 "ERROR: Missing required parameter for " action ", you must specify the test pattern with -testpatt") (exit 3)) (else @@ -549,14 +637,14 @@ (debug:print 0 "ERROR: Attempted " action "on test(s) but run area config file not found") (exit 1)) ;; put test parameters into convenient variables (runs:operate-on action target - (args:get-arg ":runname") + (or (args:get-arg "-runname")(args:get-arg ":runname")) (args:get-arg "-testpatt") - state: (args:get-arg ":state") - status: (args:get-arg ":status") + state: (or (args:get-arg "-state")(args:get-arg ":state") ) + status: (or (args:get-arg "-status")(args:get-arg ":status")) new-state-status: (args:get-arg "-set-state-status"))) (set! *didsomething* #t))))) (if (args:get-arg "-remove-runs") (general-run-call @@ -569,29 +657,54 @@ (general-run-call "-set-state-status" "set state and status" (lambda (target runname keys keyvals) (operate-on 'set-state-status)))) + +(if (or (args:get-arg "-set-run-status") + (args:get-arg "-get-run-status")) + (general-run-call + "-set-run-status" + "set run status" + (lambda (target runname keys keyvals) + (let* ((runsdat (rmt:get-runs-by-patt keys runname + (common:args-get-target) + #f #f)) + (header (vector-ref runsdat 0)) + (rows (vector-ref runsdat 1))) + (if (null? rows) + (begin + (debug:print-info 0 "No matching run found.") + (exit 1)) + (let* ((row (car (vector-ref runsdat 1))) + (run-id (db:get-value-by-header row header "id"))) + (if (args:get-arg "-set-run-status") + (rmt:set-run-status run-id (args:get-arg "-set-run-status") msg: (args:get-arg "-m")) + (print (rmt:get-run-status run-id)) + ))))))) ;;====================================================================== ;; Query runs ;;====================================================================== ;; NOTE: list-runs and list-db-targets operate on local db!!! ;; (if (or (args:get-arg "-list-runs") (args:get-arg "-list-db-targets")) - (if (setup-for-run) - (let* ((db (open-db)) + (if (launch:setup-for-run) + (let* ((dbstruct (make-dbr:dbstruct path: *toppath* local: #t)) (runpatt (args:get-arg "-list-runs")) (testpatt (if (args:get-arg "-testpatt") (args:get-arg "-testpatt") "%")) - (runsdat (db:get-runs db runpatt #f #f '())) + (keys (db:get-keys dbstruct)) + ;; (runsdat (db:get-runs dbstruct runpatt #f #f '())) + (runsdat (db:get-runs-by-patt dbstruct keys (or runpatt "%") (common:args-get-target) + #f #f)) + ;; (cdb:remote-run db:get-runs #f runpatt #f #f '())) (runs (db:get-rows runsdat)) (header (db:get-header runsdat)) - (keys (db:get-keys db)) (db-targets (args:get-arg "-list-db-targets")) (seen (make-hash-table))) ;; Each run (for-each (lambda (run) @@ -604,11 +717,11 @@ (hash-table-set! seen targetstr #t) ;; (print "[" targetstr "]")))) (print targetstr)))) (if (not db-targets) (let* ((run-id (db:get-value-by-header run header "id")) - (tests (db:get-tests-for-run db run-id testpatt '() '() #f #f #f 'testname 'asc #f))) + (tests (db:get-tests-for-run dbstruct run-id testpatt '() '() #f #f #f 'testname 'asc #f))) (print "Run: " targetstr "/" (db:get-value-by-header run header "runname") " status: " (db:get-value-by-header run header "state") " run-id: " run-id ", number tests: " (length tests)) (for-each (lambda (test) @@ -627,16 +740,18 @@ (equal? (db:test-get-status test) "WARN") (equal? (db:test-get-state test) "NOT_STARTED"))) (begin (print " cpuload: " (db:test-get-cpuload test) "\n diskfree: " (db:test-get-diskfree test) - "\n uname: " (db:test-get-uname test) - "\n rundir: " (db:test-get-rundir test) + "\n uname: " ;; (sdb:qry 'getstr + (db:test-get-uname test) ;; ) + "\n rundir: " ;; (sdb:qry 'getstr ;; (filedb:get-path *fdb* + (db:test-get-rundir test) ;; ) ) ;; Each test ;; DO NOT remote run - (let ((steps (db:get-steps-for-test db (db:test-get-id test)))) + (let ((steps (db:get-steps-for-test dbstruct run-id (db:test-get-id test)))) (for-each (lambda (step) (format #t " Step: ~20a State: ~10a Status: ~10a Time ~22a\n" (tdb:step-get-stepname step) @@ -644,11 +759,12 @@ (tdb:step-get-status step) (tdb:step-get-event_time step))) steps))))) tests))))) runs) - (set! *didsomething* #t)))) + (db:close-all dbstruct) + (set! *didsomething* #t)))) ;;====================================================================== ;; full run ;;====================================================================== @@ -698,10 +814,21 @@ (if (args:get-arg "-runtests") (general-run-call "-runtests" "run a test" (lambda (target runname keys keyvals) + ;; + ;; May or may not implement it this way ... + ;; + ;; Insert this run into the tasks queue + ;; (open-run-close tasks:add tasks:open-db + ;; "runtests" + ;; user + ;; target + ;; runname + ;; (args:get-arg "-runtests") + ;; #f)))) (runs:run-tests target runname (args:get-arg "-runtests") user args:arg-hash)))) @@ -715,11 +842,11 @@ "-rollup" "rollup tests" (lambda (target runname keys keyvals) (runs:rollup-run keys keyvals - (args:get-arg ":runname") + (or (args:get-arg "-runname")(args:get-arg ":runname") ) user)))) ;;====================================================================== ;; Lock or unlock a run ;;====================================================================== @@ -730,11 +857,11 @@ "lock/unlock tests" (lambda (target runname keys keyvals) (runs:handle-locking target keys - (args:get-arg ":runname") + (or (args:get-arg "-runname")(args:get-arg ":runname") ) (args:get-arg "-lock") (args:get-arg "-unlock") user)))) ;;====================================================================== @@ -743,38 +870,33 @@ ;; Get test paths matching target, runname, and testpatt (if (or (args:get-arg "-test-files")(args:get-arg "-test-paths")) ;; if we are in a test use the MT_CMDINFO data (if (getenv "MT_CMDINFO") (let* ((startingdir (current-directory)) - (cmdinfo (read (open-input-string (base64:base64-decode (getenv "MT_CMDINFO"))))) - ;; (runremote (assoc/default 'runremote cmdinfo)) - (transport (assoc/default 'transport cmdinfo)) + (cmdinfo (common:read-encoded-string (getenv "MT_CMDINFO"))) (testpath (assoc/default 'testpath cmdinfo)) (test-name (assoc/default 'test-name cmdinfo)) (runscript (assoc/default 'runscript cmdinfo)) (db-host (assoc/default 'db-host cmdinfo)) (run-id (assoc/default 'run-id cmdinfo)) (itemdat (assoc/default 'itemdat cmdinfo)) - (db #f) (state (args:get-arg ":state")) (status (args:get-arg ":status")) (target (args:get-arg "-target")) (toppath (assoc/default 'toppath cmdinfo))) (change-directory toppath) - ;; (set! *runremote* runremote) - ;; (set! *transport-type* (string->symbol transport)) (if (not target) (begin (debug:print 0 "ERROR: -target is required.") (exit 1))) - (if (not (setup-for-run)) + (if (not (launch:setup-for-run)) (begin (debug:print 0 "Failed to setup, giving up on -test-paths or -test-files, exiting") (exit 1))) (let* ((keys (rmt:get-keys)) ;; db:test-get-paths must not be run remote - (paths (db:test-get-paths-matching db keys target (args:get-arg "-test-files")))) + (paths (tests:test-get-paths-matching keys target (args:get-arg "-test-files")))) (set! *didsomething* #t) (for-each (lambda (path) (print path)) paths))) ;; else do a general-run-call @@ -782,11 +904,11 @@ "-test-files" "Get paths to test" (lambda (target runname keys keyvals) (let* ((db #f) ;; DO NOT run remote - (paths (db:test-get-paths-matching db keys target (args:get-arg "-test-files")))) + (paths (tests:test-get-paths-matching keys target (args:get-arg "-test-files")))) (for-each (lambda (path) (print path)) paths)))))) ;;====================================================================== @@ -795,54 +917,46 @@ ;; Archive tests matching target, runname, and testpatt (if (args:get-arg "-archive") ;; if we are in a test use the MT_CMDINFO data (if (getenv "MT_CMDINFO") (let* ((startingdir (current-directory)) - (cmdinfo (read (open-input-string (base64:base64-decode (getenv "MT_CMDINFO"))))) - ;; (runremote (assoc/default 'runremote cmdinfo)) - (transport (assoc/default 'transport cmdinfo)) + (cmdinfo (common:read-encoded-string (getenv "MT_CMDINFO"))) (testpath (assoc/default 'testpath cmdinfo)) (test-name (assoc/default 'test-name cmdinfo)) (runscript (assoc/default 'runscript cmdinfo)) (db-host (assoc/default 'db-host cmdinfo)) (run-id (assoc/default 'run-id cmdinfo)) (itemdat (assoc/default 'itemdat cmdinfo)) - (db (open-db)) (state (args:get-arg ":state")) (status (args:get-arg ":status")) (target (args:get-arg "-target"))) (change-directory testpath) - ;; (set! *runremote* runremote) - ;; (set! *transport-type* (string->symbol transport)) (if (not target) (begin (debug:print 0 "ERROR: -target is required.") (exit 1))) - (if (not (setup-for-run)) + (if (not (launch:setup-for-run)) (begin (debug:print 0 "Failed to setup, giving up on -archive, exiting") (exit 1))) - (let* ((keys (db:get-keys db)) - ;; DO NOT run remote - (paths (db:test-get-paths-matching db keys target))) + (let* ((keys (rmt:get-keys)) + (paths (tests:test-get-paths-matching keys target))) (set! *didsomething* #t) (for-each (lambda (path) (print path)) paths)) - (if (sqlite3:database? db)(sqlite3:finalize! db))) + ;; (if (sqlite3:database? db)(sqlite3:finalize! db)) + ) ;; else do a general-run-call (general-run-call "-test-paths" "Get paths to tests" (lambda (target runname keys keyvals) - (let* ((db (open-db)) - ;; DO NOT run remote - (paths (db:test-get-paths-matching db keys target))) + (let* ((paths (tests:test-get-paths-matching keys target))) (for-each (lambda (path) (print path)) - paths) - (sqlite3:finalize! db)))))) + paths)))))) ;;====================================================================== ;; Extract a spreadsheet from the runs database ;;====================================================================== @@ -849,18 +963,18 @@ (if (args:get-arg "-extract-ods") (general-run-call "-extract-ods" "Make ods spreadsheet" (lambda (target runname keys keyvals) - (let ((db (open-db)) + (let ((dbstruct (make-dbr:dbstruct path: *toppath* local: #t)) (outputfile (args:get-arg "-extract-ods")) - (runspatt (args:get-arg ":runname")) + (runspatt (or (args:get-arg "-runname")(args:get-arg ":runname"))) (pathmod (args:get-arg "-pathmod"))) ;; (keyvalalist (keys->alist keys "%"))) (debug:print 2 "Extract ods, outputfile: " outputfile " runspatt: " runspatt " keyvals: " keyvals) - (db:extract-ods-file db outputfile keyvals (if runspatt runspatt "%") pathmod) - (sqlite3:finalize! db) + (db:extract-ods-file dbstruct outputfile keyvals (if runspatt runspatt "%") pathmod) + (db:close-all dbstruct) (set! *didsomething* #t))))) ;;====================================================================== ;; execute the test ;; - gets called on remote host @@ -881,13 +995,11 @@ (define (megatest:step step state status logfile msg) (if (not (getenv "MT_CMDINFO")) (begin (debug:print 0 "ERROR: MT_CMDINFO env var not set, -step must be called *inside* a megatest invoked environment!") (exit 5)) - (let* ((cmdinfo (read (open-input-string (base64:base64-decode (getenv "MT_CMDINFO"))))) - ;; (runremote (assoc/default 'runremote cmdinfo)) - (transport (assoc/default 'transport cmdinfo)) + (let* ((cmdinfo (common:read-encoded-string (getenv "MT_CMDINFO"))) (testpath (assoc/default 'testpath cmdinfo)) (test-name (assoc/default 'test-name cmdinfo)) (runscript (assoc/default 'runscript cmdinfo)) (db-host (assoc/default 'db-host cmdinfo)) (run-id (assoc/default 'run-id cmdinfo)) @@ -894,19 +1006,16 @@ (test-id (assoc/default 'test-id cmdinfo)) (itemdat (assoc/default 'itemdat cmdinfo)) (work-area (assoc/default 'work-area cmdinfo)) (db #f)) (change-directory testpath) - ;; (set! *runremote* runremote) - ;; The transport is handled earlier in the loading process of megatest. - ;; (set! *transport-type* (string->symbol transport)) - (if (not (setup-for-run)) + (if (not (launch:setup-for-run)) (begin (debug:print 0 "Failed to setup, exiting") (exit 1))) (if (and state status) - (rmt:teststep-set-status! test-id step state status msg logfile) + (rmt:teststep-set-status! run-id test-id step state status msg logfile) (begin (debug:print 0 "ERROR: You must specify :state and :status with every call to -step") (exit 6)))))) (if (args:get-arg "-step") @@ -932,13 +1041,11 @@ (if (not (getenv "MT_CMDINFO")) (begin (debug:print 0 "ERROR: MT_CMDINFO env var not set, commands -test-status, -runstep and -setlog must be called *inside* a megatest environment!") (exit 5)) (let* ((startingdir (current-directory)) - (cmdinfo (read (open-input-string (base64:base64-decode (getenv "MT_CMDINFO"))))) - ;; (runremote (assoc/default 'runremote cmdinfo)) - (transport (assoc/default 'transport cmdinfo)) + (cmdinfo (common:read-encoded-string (getenv "MT_CMDINFO"))) (testpath (assoc/default 'testpath cmdinfo)) (test-name (assoc/default 'test-name cmdinfo)) (runscript (assoc/default 'runscript cmdinfo)) (db-host (assoc/default 'db-host cmdinfo)) (run-id (assoc/default 'run-id cmdinfo)) @@ -946,13 +1053,11 @@ (itemdat (assoc/default 'itemdat cmdinfo)) (work-area (assoc/default 'work-area cmdinfo)) (db #f) ;; (open-db)) (state (args:get-arg ":state")) (status (args:get-arg ":status"))) - ;; (set! *runremote* runremote) - ;; (set! *transport-type* (string->symbol transport)) - (if (not (setup-for-run)) + (if (not (launch:setup-for-run)) (begin (debug:print 0 "Failed to setup, exiting") (exit 1))) (if (args:get-arg "-runstep")(debug:print-info 1 "Running -runstep, first change to directory " work-area)) @@ -961,20 +1066,20 @@ ;; (client:setup) (if (args:get-arg "-load-test-data") ;; has sub commands that are rdb: ;; DO NOT put this one into either cdb:remote-run or open-run-close - (tdb:load-test-data test-id)) + (tdb:load-test-data run-id test-id)) (if (args:get-arg "-setlog") (let ((logfname (args:get-arg "-setlog"))) - (rmt:test-set-log! test-id logfname))) + (rmt:test-set-log! run-id test-id logfname))) (if (args:get-arg "-set-toplog") ;; DO NOT run remote (tests:test-set-toplog! run-id test-name (args:get-arg "-set-toplog"))) (if (args:get-arg "-summarize-items") ;; DO NOT run remote - (tests:summarize-items db run-id test-id test-name #t)) ;; do force here + (tests:summarize-items run-id test-id test-name #t)) ;; do force here (if (args:get-arg "-runstep") (if (null? remargs) (begin (debug:print 0 "ERROR: nothing specified to run!") (if db (sqlite3:finalize! db)) @@ -983,20 +1088,23 @@ (logprofile (args:get-arg "-logpro")) (logfile (conc stepname ".log")) (cmd (if (null? remargs) #f (car remargs))) (params (if cmd (cdr remargs) '())) (exitstat #f) - (shell (last (string-split (get-environment-variable "SHELL") "/"))) + (shell (let ((sh (get-environment-variable "SHELL") )) + (if sh + (last (string-split sh "/")) + "bash"))) (redir (case (string->symbol shell) ((tcsh csh ksh) ">&") ((zsh bash sh ash) "2>&1 >") (else ">&"))) (fullcmd (conc "(" (string-intersperse (cons cmd params) " ") ") " redir " " logfile))) ;; mark the start of the test - (rmt:teststep-set-status! test-id stepname "start" "n/a" (args:get-arg "-m") logfile) + (rmt:teststep-set-status! run-id test-id stepname "start" "n/a" (args:get-arg "-m") logfile) ;; run the test step (debug:print-info 2 "Running \"" fullcmd "\" in directory \"" startingdir) (change-directory startingdir) (set! exitstat (system fullcmd)) (set! *globalexitstatus* exitstat) @@ -1009,13 +1117,13 @@ (debug:print-info 2 "running \"" cmd "\"") (change-directory startingdir) (set! exitstat (system cmd)) (set! *globalexitstatus* exitstat) ;; no necessary (change-directory testpath) - (rmt:test-set-log! test-id htmllogfile))) + (rmt:test-set-log! run-id test-id htmllogfile))) (let ((msg (args:get-arg "-m"))) - (rmt:teststep-set-status! test-id stepname "end" exitstat msg logfile)) + (rmt:teststep-set-status! run-id test-id stepname "end" exitstat msg logfile)) ))) (if (or (args:get-arg "-test-status") (args:get-arg "-set-values")) (let ((newstatus (cond ((number? status) (if (equal? status 0) "PASS" "FAIL")) @@ -1038,11 +1146,11 @@ (if (sqlite3:database? db)(sqlite3:finalize! db)) (exit 6))) (let* ((msg (args:get-arg "-m")) (numoth (length (hash-table-keys otherdata)))) ;; Convert to rpc inside the tests:test-set-status! call, not here - (tests:test-set-status! test-id state newstatus msg otherdata work-area: work-area)))) + (tests:test-set-status! run-id test-id state newstatus msg otherdata work-area: work-area)))) (if (sqlite3:database? db)(sqlite3:finalize! db)) (set! *didsomething* #t)))) ;;====================================================================== ;; Various helper commands can go below here @@ -1050,11 +1158,11 @@ (if (or (args:get-arg "-showkeys") (args:get-arg "-show-keys")) (let ((db #f) (keys #f)) - (if (not (setup-for-run)) + (if (not (launch:setup-for-run)) (begin (debug:print 0 "Failed to setup, exiting") (exit 1))) (set! keys (cdb:remote-run db:get-keys db)) (debug:print 1 "Keys: " (string-intersperse keys ", ")) @@ -1081,57 +1189,44 @@ ;; Update the database schema, clean up the db ;;====================================================================== (if (args:get-arg "-rebuild-db") (begin - (if (not (setup-for-run)) + (if (not (launch:setup-for-run)) (begin (debug:print 0 "Failed to setup, exiting") (exit 1))) ;; keep this one local (open-run-close patch-db #f) (set! *didsomething* #t))) (if (args:get-arg "-cleanup-db") (begin - (if (not (setup-for-run)) + (if (not (launch:setup-for-run)) (begin (debug:print 0 "Failed to setup, exiting") (exit 1))) ;; keep this one local (open-run-close db:clean-up #f) (set! *didsomething* #t))) (if (args:get-arg "-mark-incompletes") (begin - (if (not (setup-for-run)) + (if (not (launch:setup-for-run)) (begin (debug:print 0 "Failed to setup, exiting") (exit 1))) (open-run-close db:find-and-mark-incomplete #f) - (set! *didsomething* #t))) - -;;====================================================================== -;; Wait on a run to complete -;;====================================================================== - -(if (args:get-arg "-run-wait") - (begin - (if (not (setup-for-run)) - (begin - (debug:print 0 "Failed to setup, exiting") - (exit 1))) - (operate-on 'run-wait) (set! *didsomething* #t))) ;;====================================================================== ;; Update the tests meta data from the testconfig files ;;====================================================================== (if (args:get-arg "-update-meta") (begin - (if (not (setup-for-run)) + (if (not (launch:setup-for-run)) (begin (debug:print 0 "Failed to setup, exiting") (exit 1))) ;; now can find our db ;; keep this one local @@ -1142,44 +1237,102 @@ ;; Start a repl ;;====================================================================== (if (or (args:get-arg "-repl") (args:get-arg "-load")) - (let* ((toppath (setup-for-run)) - (db (if toppath (open-db) #f))) - (if db + (let* ((toppath (launch:setup-for-run)) + (dbstruct (if toppath (make-dbr:dbstruct path: toppath local: #t) #f))) + (if dbstruct (begin - (set! *db* db) + (set! *db* dbstruct) (set! *client-non-blocking-mode* #t) (import readline) (import apropos) + ;; (import (prefix sqlite3 sqlite3:)) ;; doesn't work ... (gnu-history-install-file-manager (string-append (or (get-environment-variable "HOME") ".") "/.megatest_history")) (current-input-port (make-gnu-readline-port "megatest> ")) (if (args:get-arg "-repl") (repl) - (load (args:get-arg "-load")))) + (load (args:get-arg "-load"))) + (db:close-all dbstruct)) (exit)) (set! *didsomething* #t))) + +;;====================================================================== +;; Wait on a run to complete +;;====================================================================== + +(if (and (args:get-arg "-run-wait") + (not (args:get-arg "-runtests"))) ;; run-wait is built into runtests now + (begin + (if (not (launch:setup-for-run)) + (begin + (debug:print 0 "Failed to setup, exiting") + (exit 1))) + (operate-on 'run-wait) + (set! *didsomething* #t))) + +;; ;; ;; redo me ;; Not converted to use dbstruct yet +;; ;; ;; redo me ;; +;; ;; ;; redo me (if (args:get-arg "-convert-to-norm") +;; ;; ;; redo me (let* ((toppath (setup-for-run)) +;; ;; ;; redo me (dbstruct (if toppath (make-dbr:dbstruct path: toppath local: #t)))) +;; ;; ;; redo me (for-each +;; ;; ;; redo me (lambda (field) +;; ;; ;; redo me (let ((dat '())) +;; ;; ;; redo me (debug:print-info 0 "Getting data for field " field) +;; ;; ;; redo me (sqlite3:for-each-row +;; ;; ;; redo me (lambda (id val) +;; ;; ;; redo me (set! dat (cons (list id val) dat))) +;; ;; ;; redo me (db:get-db db run-id) +;; ;; ;; redo me (conc "SELECT id," field " FROM tests;")) +;; ;; ;; redo me (debug:print-info 0 "found " (length dat) " items for field " field) +;; ;; ;; redo me (let ((qry (sqlite3:prepare db (conc "UPDATE tests SET " field "=? WHERE id=?;")))) +;; ;; ;; redo me (for-each +;; ;; ;; redo me (lambda (item) +;; ;; ;; redo me (let ((newval ;; (sdb:qry 'getid +;; ;; ;; redo me (cadr item))) ;; ) +;; ;; ;; redo me (if (not (equal? newval (cadr item))) +;; ;; ;; redo me (debug:print-info 0 "Converting " (cadr item) " to " newval " for test #" (car item))) +;; ;; ;; redo me (sqlite3:execute qry newval (car item)))) +;; ;; ;; redo me dat) +;; ;; ;; redo me (sqlite3:finalize! qry)))) +;; ;; ;; redo me (db:close-all dbstruct) +;; ;; ;; redo me (list "uname" "rundir" "final_logf" "comment")) +;; ;; ;; redo me (set! *didsomething* #t))) + +(if (args:get-arg "-import-megatest.db") + (begin + (db:multi-db-sync + #f ;; do all run-ids + 'killservers + 'dejunk + 'adj-testids + 'old2new + 'new2old + ) + (set! *didsomething* #t))) + +(if (args:get-arg "-sync-to-megatest.db") + (begin + (db:multi-db-sync + #f ;; do all run-ids + 'new2old + ) + (set! *didsomething* #t))) ;;====================================================================== ;; Exit and clean up ;;====================================================================== (if *runremote* (close-all-connections!)) -;; this is the socket if we are a client -;; (if (and *runremote* -;; (socket? *runremote*)) -;; (close-socket *runremote*)) - (if (not *didsomething*) (debug:print 0 help)) -;; (if *runremote* (rpc:close-all-connections!)) - (if (not (eq? *globalexitstatus* 0)) (if (or (args:get-arg "-runtests")(args:get-arg "-runall")) (begin (debug:print 0 "NOTE: Subprocesses with non-zero exit code detected: " *globalexitstatus*) (exit 0)) ADDED minimal/megatest.config Index: minimal/megatest.config ================================================================== --- /dev/null +++ minimal/megatest.config @@ -0,0 +1,12 @@ +[fields] +RUNTYPE text + +[setup] +linktree #{getenv PWD}/linktree +max_concurrent_jobs 20 + +[jobtools] +launcher nbfake + +[disks] +disk0 #{getenv PWD}/runs ADDED minimal/runconfigs.config Index: minimal/runconfigs.config ================================================================== --- /dev/null +++ minimal/runconfigs.config @@ -0,0 +1,3 @@ +[default] +EXAMPLEVAR 1 + ADDED minimal/tests/tmpspace/testconfig Index: minimal/tests/tmpspace/testconfig ================================================================== --- /dev/null +++ minimal/tests/tmpspace/testconfig @@ -0,0 +1,27 @@ +[ezsteps] + +df [ `df -m /tmp | grep /tmp | awk '{print $3}'` -gt 200000 ] + +[items] +TARGETHOST chlr10722 \ + chlr15003 \ + chlr13406 \ + chlr12539 \ + chlr12713 \ + chlr11407 \ + chlr14713 \ + chlr11440 \ + chlr11417 \ + chlr14709 \ + chlr11722 \ + chlr11445 \ + chlr11421 \ + chlr11404 + +[test_meta] +author mrwellan +owner mrwellan +description Check for available space in /tmp +tags Utility +reviewed ww50.3 + Index: mt.scm ================================================================== --- mt.scm +++ mt.scm @@ -18,10 +18,11 @@ (declare (uses runconfig)) (declare (uses tests)) (declare (uses server)) (declare (uses runs)) (declare (uses rmt)) +;; (declare (uses filedb)) (include "common_records.scm") (include "key_records.scm") (include "db_records.scm") (include "run_records.scm") @@ -36,11 +37,11 @@ ;; runs: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-row runinfo)) +;; Use: (db-get-value-by-header (db:get-header runinfo)(db:get-rows runinfo)) ;; to extract info from the structure returned ;; (define (mt:get-runs-by-patt keys runnamepatt targpatt) (let loop ((runsdat (rmt:get-runs-by-patt keys runnamepatt targpatt 0 500)) (res '()) @@ -81,11 +82,11 @@ full-list new-offset limit)) full-list)))) -(define (mt:lazy-get-prereqs-not-met run-id waitons ref-item-path #!key (mode 'normal)) +(define (mt:lazy-get-prereqs-not-met run-id waitons ref-item-path #!key (mode '(normal))(itemmap #f) ) (let* ((key (list run-id waitons ref-item-path mode)) (res (hash-table-ref/default *pre-reqs-met-cache* key #f)) (useres (let ((last-time (if (vector? res) (vector-ref res 0) #f))) (if last-time (< (current-seconds)(+ last-time 5)) @@ -92,50 +93,56 @@ #f)))) (if useres (let ((result (vector-ref res 1))) (debug:print 4 "Using lazy value res: " result) result) - (let ((newres (rmt:get-prereqs-not-met run-id waitons ref-item-path mode: mode))) + (let ((newres (rmt:get-prereqs-not-met run-id waitons ref-item-path mode: mode itemmap: itemmap))) +;; (let ((newres (db:get-prereqs-not-met run-id waitons ref-item-path mode: mode itemmap: itemmap))) (hash-table-set! *pre-reqs-met-cache* key (vector (current-seconds) newres)) newres)))) +(define (mt:get-run-stats dbstruct run-id) ;; Get run stats from local access, move this ... but where? -(define (mt:get-run-stats) - (db:get-run-stats #f)) + (db:get-run-stats dbstruct run-id)) (define (mt:discard-blocked-tests run-id failed-test tests test-records) (if (null? tests) tests (begin (debug:print-info 1 "Discarding tests from " tests " that are waiting on " failed-test) (let loop ((testn (car tests)) (remt (cdr tests)) (res '())) - (let ((waitons (vector-ref (hash-table-ref/default test-records testn (vector #f #f '())) 2))) + (let* ((test-dat (hash-table-ref/default test-records testn (vector #f #f '()))) + (waitons (vector-ref test-dat 2))) ;; (print "mt:discard-blocked-tests run-id: " run-id " failed-test: " failed-test " testn: " testn " with waitons: " waitons) (if (null? remt) (let ((new-res (reverse res))) ;; (print " new-res: " new-res) new-res) (loop (car remt) (cdr remt) (if (member failed-test waitons) - res + (begin + (debug:print 0 "Discarding test " testn "(" test-dat ") due to " failed-test) + res) (cons testn res))))))))) ;;====================================================================== ;; T R I G G E R S ;;====================================================================== -(define (mt:process-triggers test-id newstate newstatus) - (let* ((test-dat (rmt:get-test-info-by-id test-id)) - (test-rundir (db:test-get-rundir test-dat)) +(define (mt:process-triggers run-id test-id newstate newstatus) + (let* ((test-dat (rmt:get-test-info-by-id run-id test-id)) + (test-rundir ;; (rmt:sdb-qry 'getstr ;; (filedb:get-path *fdb* + (db:test-get-rundir test-dat)) ;; ) ;; ) (test-name (db:test-get-testname test-dat)) (tconfig #f) (state (if newstate newstate (db:test-get-state test-dat))) (status (if newstatus newstatus (db:test-get-status test-dat)))) - (if (and (file-exists? test-rundir) + (if (and test-rundir ;; #f means no dir set yet + (file-exists? test-rundir) (directory? test-rundir)) (begin (push-directory test-rundir) (set! tconfig (mt:lazy-read-test-config test-name)) (pop-directory) @@ -157,45 +164,48 @@ ;;====================================================================== ;; S T A T E A N D S T A T U S F O R T E S T S ;;====================================================================== ;; speed up for common cases with a little logic -(define (mt:test-set-state-status-by-id test-id newstate newstatus newcomment) +(define (mt:test-set-state-status-by-id run-id test-id newstate newstatus newcomment) (cond ((and newstate newstatus newcomment) - (rmt:general-call 'state-status-msg newstate newstatus newcomment test-id)) + (rmt:general-call 'state-status-msg run-id newstate newstatus newcomment test-id)) ((and newstate newstatus) - (rmt:general-call 'state-status newstate newstatus test-id)) + (rmt:general-call 'state-status run-id newstate newstatus test-id)) (else - (if newstate (rmt:general-call 'set-test-state newstate test-id)) - (if newstatus (rmt:general-call 'set-test-status newstatus test-id)) - (if newcomment (rmt:general-call 'set-test-comment newcomment test-id)))) - (mt:process-triggers test-id newstate newstatus) + (if newstate (rmt:general-call 'set-test-state run-id newstate test-id)) + (if newstatus (rmt:general-call 'set-test-status run-id newstatus test-id)) + (if newcomment (rmt:general-call 'set-test-comment run-id newcomment test-id)))) + (mt:process-triggers run-id test-id newstate newstatus) #t) -(define (mt:lazy-get-test-info-by-id test-id) - (let* ((tdat (hash-table-ref/default *test-info* test-id #f))) - (if (and tdat - (< (current-seconds)(+ (vector-ref tdat 0) 10))) - (vector-ref tdat 1) - ;; no need to update *test-info* as that is done in cdb:get-test-info-by-id - (cdb:get-test-info-by-id *runremote* test-id)))) +(define (mt:test-set-state-status-by-testname run-id test-name item-path new-state new-status new-comment) + (let ((test-id (cdb:remote-run db:get-test-id-cached #f run-id test-name item-path))) + (mt:test-set-state-status-by-id test-id new-state new-status new-comment))) (define (mt:lazy-read-test-config test-name) (let ((tconf (hash-table-ref/default *testconfigs* test-name #f))) (if tconf tconf (let ((test-dirs (tests:get-tests-search-path *configdat*))) (let loop ((hed (car test-dirs)) (tal (cdr test-dirs))) + ;; Setting MT_LINKTREE here is almost certainly unnecessary. (let ((tconfig-file (conc hed "/" test-name "/testconfig"))) (if (and (file-exists? tconfig-file) (file-read-access? tconfig-file)) - (let ((newtcfg (read-config tconfig-file #f #f))) ;; NOTE: Does NOT run [system ...] - (hash-table-set! *testconfigs* test-name newtcfg) - newtcfg) + (let ((link-tree-path (configf:lookup *configdat* "setup" "linktree")) + (old-link-tree (get-environment-variable "MT_LINKTREE"))) + (if link-tree-path (setenv "MT_LINKTREE" link-tree-path)) + (let ((newtcfg (read-config tconfig-file #f #f))) ;; NOTE: Does NOT run [system ...] + (hash-table-set! *testconfigs* test-name newtcfg) + (if old-link-tree + (setenv "MT_LINKTREE" old-link-tree) + (unsetenv "MT_LINKTREE")) + newtcfg)) (if (null? tal) (begin (debug:print 0 "ERROR: No readable testconfig found for " test-name) #f) (loop (car tal)(cdr tal)))))))))) Index: newdashboard.scm ================================================================== --- newdashboard.scm +++ newdashboard.scm @@ -67,21 +67,29 @@ (if (args:get-arg "-h") (begin (print help) (exit))) -(if (not (setup-for-run)) +(if (not (launch:setup-for-run)) (begin (print "Failed to find megatest.config, exiting") (exit 1))) -(if (args:get-arg "-host") - (begin - (set! *runremote* (string-split (args:get-arg "-host" ":"))) - (client:launch)) - (client:launch)) +;; (if (args:get-arg "-host") +;; (begin +;; (set! *runremote* (string-split (args:get-arg "-host" ":"))) +;; (client:launch)) +;; (client:launch)) + + +(define *dbdir* (conc (configf:lookup *configdat* "setup" "linktree") "/.db")) +(define *dbstruct-local* (make-dbr:dbstruct path: *dbdir* + local: #t)) +(define *db-file-path* (db:dbfile-path 0)) +;; HACK ALERT: this is a hack, please fix. +(define *read-only* (not (file-read-access? *db-file-path*))) (debug:setup) (define *tim* (iup:timer)) (define *ord* #f) @@ -568,13 +576,13 @@ (iup:attribute-set! tabtop "TABTITLE4" "runconfigs.config") tabtop))) (define *current-window-id* 0) -(define (newdashboard) +(define (newdashboard dbstruct) (let* ((data (make-hash-table)) - (keys (cdb:remote-run db:get-keys #f)) + (keys (db:get-keys dbstruct)) (runname "%") (testpatt "%") (keypatts (map (lambda (k)(list k "%")) keys)) (states '()) (statuses '()) @@ -590,13 +598,14 @@ (lambda (x) ;; Want to dedicate no more than 50% of the time to this so skip if ;; 2x delta time has not passed since last query (if (< nextmintime (current-milliseconds)) (let* ((starttime (current-milliseconds)) - (changes (run-update keys data runname keypatts testpatt states statuses 'full my-window-id)) + (changes (dcommon:run-update keys data runname keypatts testpatt states statuses 'full my-window-id)) (endtime (current-milliseconds))) (set! nextmintime (+ endtime (* 2 (- endtime starttime)))) (debug:print 11 "CHANGE(S): " (car changes) "...")) (debug:print-info 11 "Server overloaded")))))) -(newdashboard) +(dboard:data-set-updaters! *data* (make-hash-table)) +(newdashboard *dbstruct-local*) (iup:main-loop) ADDED oldsrc/fs-transport.scm Index: oldsrc/fs-transport.scm ================================================================== --- /dev/null +++ oldsrc/fs-transport.scm @@ -0,0 +1,44 @@ + +;; Copyright 2006-2012, Matthew Welland. +;; +;; This program is made available under the GNU GPL version 2.0 or +;; greater. See the accompanying file COPYING for details. +;; +;; This program is distributed WITHOUT ANY WARRANTY; without even the +;; implied warranty of MERCHANTABILITY or FITNESS FOR A PARTICULAR +;; PURPOSE. + +(require-extension (srfi 18) extras tcp s11n) + +(use sqlite3 srfi-1 posix regex regex-case srfi-69 hostinfo md5 message-digest) +(import (prefix sqlite3 sqlite3:)) + +(use spiffy uri-common intarweb http-client spiffy-request-vars) + +(tcp-buffer-size 2048) + +(declare (unit fs-transport)) + +(declare (uses common)) +(declare (uses db)) +(declare (uses tests)) +(declare (uses tasks)) ;; tasks are where stuff is maintained about what is running. + +(include "common_records.scm") +(include "db_records.scm") + + +;;====================================================================== +;; F S T R A N S P O R T S E R V E R +;;====================================================================== + +;; There is no "server" per se but a convience routine to make it non +;; necessary to be reopening the db over and over again. +;; + +(define (fs:process-queue-item packet) + (if (not *megatest-db*) ;; we will require that (setup-for-run) has already been called + (set! *megatest-db* (open-db))) + (debug:print-info 11 "fs:process-queue-item called with packet=" packet) + (db:process-queue-item *megatest-db* packet)) + ADDED oldsrc/zmq-transport.scm Index: oldsrc/zmq-transport.scm ================================================================== --- /dev/null +++ oldsrc/zmq-transport.scm @@ -0,0 +1,494 @@ +;;====================================================================== +;; Copyright 2006-2012, Matthew Welland. +;; +;; This program is made available under the GNU GPL version 2.0 or +;; greater. See the accompanying file COPYING for details. +;; +;; This program is distributed WITHOUT ANY WARRANTY; without even the +;; implied warranty of MERCHANTABILITY or FITNESS FOR A PARTICULAR +;; PURPOSE. +;;====================================================================== + +(require-extension (srfi 18) extras tcp s11n) + +(use sqlite3 srfi-1 posix regex regex-case srfi-69 hostinfo md5 message-digest) +(import (prefix sqlite3 sqlite3:)) + +(use zmq) + +(declare (unit zmq-transport)) + +(declare (uses common)) +(declare (uses db)) +(declare (uses tests)) +(declare (uses tasks)) ;; tasks are where stuff is maintained about what is running. +(declare (uses server)) + +(include "common_records.scm") +(include "db_records.scm") + +;; Transition to pub --> sub with pull <-- push +;; +;; 1. client sends request to server via push to the pull port +;; 2. server puts request in queue or processes immediately as appropriate +;; 3. server puts responses from completed requests into pub port +;; +;; TODO +;; +;; Done Tested +;; [x] [ ] 1. Add columns pullport pubport to servers table +;; [x] [ ] 2. Add rm of monitor.db if older than 11/12/2012 +;; [x] [ ] 3. Add create of pullport and pubport with finding of available ports +;; [x] [ ] 4. Add client compose of request +;; [x] [ ] - name of client: testname/itempath-test_id-hostname +;; [x] [ ] - name of request: callname, params +;; [x] [ ] - request key: f(clientname, callname, params) +;; [x] [ ] 5. Add processing of subscription hits +;; [x] [ ] - done when get key +;; [x] [ ] - return results +;; [x] [ ] 6. Add timeout processing +;; [x] [ ] - after 60 seconds +;; [ ] [ ] i. check server alive, connect to new if necessary +;; [ ] [ ] ii. resend request +;; [ ] [ ] 7. Turn self ping back on + +(define (zmq-transport:make-server-url hostport) + (if (not hostport) + #f + (conc "tcp://" (car hostport) ":" (cadr hostport)))) + +(define *server-loop-heart-beat* (current-seconds)) +(define *heartbeat-mutex* (make-mutex)) + +;;====================================================================== +;; S E R V E R +;;====================================================================== + +(define-inline (zmqsock:get-pub dat)(vector-ref dat 0)) +(define-inline (zmqsock:get-pull dat)(vector-ref dat 1)) +(define-inline (zmqsock:set-pub! dat s)(vector-set! dat s 0)) +(define-inline (zmqsock:set-pull! dat s)(vector-set! dat s 0)) + +(define (zmq-transport:run hostn) + (debug:print 2 "Attempting to start the server ...") + (if (not *toppath*) + (if (not (setup-for-run)) + (begin + (debug:print 0 "ERROR: cannot find megatest.config, cannot start server, exiting") + (exit)))) + (let* ((db (open-db)) ;; here we *do not* want to be opening and closing the db + (zmq-sdat1 #f) + (zmq-sdat2 #f) + (pull-socket #f) + (pub-socket #f) + (p1 #f) + (p2 #f) + (zmq-sockets-dat #f) + (iface (if (string=? "-" hostn) + "*" ;; (get-host-name) + hostn)) + (hostname (get-host-name)) + (ipaddrstr (let ((ipstr (if (string=? "-" hostn) + (string-intersperse (map number->string (u8vector->list (hostname->ip hostname))) ".") + #f))) + (if ipstr ipstr hostname))) + (last-run 0)) + (set! zmq-sockets-dat (zmq-transport:setup-ports ipaddrstr (if (args:get-arg "-port") + (string->number (args:get-arg "-port")) + (+ 5000 (random 1001))))) + + (set! zmq-sdat1 (car zmq-sockets-dat)) + (set! pull-socket (cadr zmq-sdat1)) ;; (iface s port) + (set! p1 (caddr zmq-sdat1)) + + (set! zmq-sdat2 (cadr zmq-sockets-dat)) + (set! pub-socket (cadr zmq-sdat2)) + (set! p2 (caddr zmq-sdat2)) + + (set! *cache-on* #t) + + (set! *runremote* (vector pull-socket pub-socket)) ;; overloading the use of *runremote* BUG!? + + ;; what to do when we quit + ;; +;; (on-exit (lambda () +;; (if (and *toppath* *server-info*) +;; (open-run-close tasks:server-deregister-self tasks:open-db (car *server-info*)) +;; (let loop () +;; (let ((queue-len 0)) +;; (thread-sleep! (random 5)) +;; (mutex-lock! *incoming-mutex*) +;; (set! queue-len (length *incoming-data*)) +;; (mutex-unlock! *incoming-mutex*) +;; (if (> queue-len 0) +;; (begin +;; (debug:print-info 0 "Queue not flushed, waiting ...") +;; (loop)))))))) + + ;; The heavy lifting + ;; + ;; make-vector-record cdb packet client-sig qtype immediate query-sig params qtime + ;; + (debug:print-info 11 "Server setup complete, start listening for messages") + (let loop ((queue-lst '())) + (let* ((rawmsg (receive-message* pull-socket)) + (packet (db:string->obj rawmsg)) + (qtype (cdb:packet-get-qtype packet))) + (debug:print-info 12 "server=> received packet=" packet) + (if (not (member qtype '(sync ping))) + (begin + (mutex-lock! *heartbeat-mutex*) + (set! *last-db-access* (current-seconds)) + (mutex-unlock! *heartbeat-mutex*))) + (if #t ;; (cdb:packet-get-immediate packet) ;; process immediately or put in queue + (begin + (db:process-queue-item db packet) + ;; (open-run-close db:process-queue #f pub-socket (cons packet queue-lst)) + + (loop '())) + (loop (cons packet queue-lst))))))) + +;; run zmq-transport:keep-running in a parallel thread to monitor that the db is being +;; used and to shutdown after sometime if it is not. +;; +(define (zmq-transport:keep-running) + ;; if none running or if > 20 seconds since + ;; server last used then start shutdown + ;; This thread waits for the server to come alive + (let* ((server-info (let loop () + (let ((sdat #f)) + (mutex-lock! *heartbeat-mutex*) + (set! sdat *server-info*) + (mutex-unlock! *heartbeat-mutex*) + (if sdat sdat + (begin + (debug:print 12 "WARNING: server not started yet, waiting few seconds before trying again") + (sleep 4) + (loop)))))) + (iface (cadr server-info)) + (pullport (caddr server-info)) + (pubport (cadddr server-info)) ;; id interface pullport pubport) + ;; (zmq-sockets (zmq-transport:client-connect iface pullport pubport)) + (last-access 0)) + (debug:print-info 11 "heartbeat started for zmq server on " iface " " pullport " " pubport) + (let loop ((count 0)) + (thread-sleep! 4) ;; no need to do this very often + ;; NB// sync currently does NOT return queue-length + ;; GET REAL QUEUE LENGTH FROM THE VARIABLE + (let ((queue-len 0)) ;; FOR NOW DO NOT DO THIS (cdb:client-call zmq-sockets 'sync #t 1))) + ;; (print "Server running, count is " count) + (if (< count 1) ;; 3x3 = 9 secs aprox + (loop (+ count 1))) + + ;; NOTE: Get rid of this mechanism! It really is not needed... + (open-run-close tasks:server-update-heartbeat tasks:open-db (car server-info)) + + ;; (if ;; (or (> numrunning 0) ;; stay alive for two days after last access + (mutex-lock! *heartbeat-mutex*) + (set! last-access *last-db-access*) + (mutex-unlock! *heartbeat-mutex*) + (if (> (+ last-access + ;; (* 50 60 60) ;; 48 hrs + ;; 60 ;; one minute + ;; (* 60 60) ;; one hour + (* 45 60) ;; 45 minutes, until the db deletion bug is fixed. + ) + (current-seconds)) + (begin + (debug:print-info 2 "Server continuing, seconds since last db access: " (- (current-seconds) last-access)) + (loop 0)) + (begin + (debug:print-info 0 "Starting to shutdown the server.") + ;; need to delete only *my* server entry (future use) + (set! *time-to-exit* #t) + (open-run-close tasks:server-deregister-self tasks:open-db (get-host-name)) + (thread-sleep! 1) + (debug:print-info 0 "Max cached queries was " *max-cache-size*) + (debug:print-info 0 "Server shutdown complete. Exiting") + (exit))))))) + +(define (zmq-transport:find-free-port-and-open iface s port stype #!key (trynum 50)) + (let ((s (if s s (make-socket stype))) + (p (if (number? port) port 5555)) + (old-handler (current-exception-handler))) + (handle-exceptions + exn + (begin + (debug:print 0 "Failed to bind to port " p ", trying next port") + (debug:print 0 " EXCEPTION: " ((condition-property-accessor 'exn 'message) exn)) + ;; (old-handler) + ;; (print-call-chain) + (if (> trynum 0) + (zmq-transport:find-free-port-and-open iface s (+ p 1) trynum: (- trynum 1)) + (debug:print-info 0 "Tried ports up to " p + " but all were in use. Please try a different port range by starting the server with parameter \" -port N\" where N is the starting port number to use")) + (exit)) ;; To exit or not? That is the question. + (let ((zmq-url (conc "tcp://" iface ":" p))) + (debug:print 2 "Trying to start server on " zmq-url) + (bind-socket s zmq-url) + (list iface s port))))) + +(define (zmq-transport:setup-ports ipaddrstr startport) + (let* ((s1 (zmq-transport:find-free-port-and-open ipaddrstr #f startport 'pull)) + (p1 (caddr s1)) + (s2 (zmq-transport:find-free-port-and-open ipaddrstr #f (+ 1 (if p1 p1 (+ startport 1))) 'pub)) + (p2 (caddr s2))) + (set! *runremote* #f) + (debug:print 0 "Server started on " ipaddrstr " ports " p1 " and " p2) + (mutex-lock! *heartbeat-mutex*) + (set! *server-info* (open-run-close tasks:server-register + tasks:open-db + (current-process-id) + ipaddrstr p1 + 0 + 'live + 'zmq + pubport: p2)) + (debug:print-info 11 "*server-info* set to " *server-info*) + (mutex-unlock! *heartbeat-mutex*) + (list s1 s2))) + +(define (zmq-transport:mk-signature) + (message-digest-string (md5-primitive) + (with-output-to-string + (lambda () + (write (list (current-directory) + (argv))))))) + +;;====================================================================== +;; S E R V E R U T I L I T I E S +;;====================================================================== + +;;====================================================================== +;; C L I E N T S +;;====================================================================== + +;; +(define (zmq-transport:client-socket-connect iface port #!key (context #f)(type 'req)(subscriptions '())) + (debug:print-info 3 "client-connect " iface ":" port ", type=" type ", subscriptions=" subscriptions) + (let ((connect-ok #f) + (zmq-socket (if context + (make-socket type context) + (make-socket type))) + (conurl (zmq-transport:make-server-url (list iface port)))) + (if (socket? zmq-socket) + (begin + ;; first apply subscriptions + (for-each (lambda (subscription) + (debug:print 2 "Subscribing to " subscription) + (socket-option-set! zmq-socket 'subscribe subscription)) + subscriptions) + (connect-socket zmq-socket conurl) + zmq-socket) + (begin + (debug:print 0 "ERROR: Failed to open socket to " conurl) + #f)))) + +(define (zmq-transport:client-connect iface pullport pubport) + (let* ((push-socket (zmq-transport:client-socket-connect iface pullport type: 'push)) + (sub-socket (zmq-transport:client-socket-connect iface pubport + type: 'sub + subscriptions: (list (client:get-signature) "all"))) + (zmq-sockets (vector push-socket sub-socket)) + (login-res #f)) + (debug:print-info 11 "zmq-transport:client-connect started. Next is login") + (set! login-res (client:login serverdat zmq-sockets)) + (if (and (not (null? login-res)) + (car login-res)) + (begin + (debug:print-info 2 "Logged in and connected to " iface ":" pullport "/" pubport ".") + (set! *runremote* zmq-sockets) + zmq-sockets) + (begin + (debug:print-info 2 "Failed to login or connect to " conurl) + (set! *runremote* #f) + #f)))) + +;; run zmq-transport:keep-running in a parallel thread to monitor that the db is being +;; used and to shutdown after sometime if it is not. +;; +(define (zmq-transport:keep-running) + ;; if none running or if > 20 seconds since + ;; server last used then start shutdown + ;; This thread waits for the server to come alive + (let* ((server-info (let loop () + (let ((sdat #f)) + (mutex-lock! *heartbeat-mutex*) + (set! sdat *runremote*) + (mutex-unlock! *heartbeat-mutex*) + (if sdat sdat + (begin + (sleep 4) + (loop)))))) + (iface (car server-info)) + (port (cadr server-info)) + (last-access 0) + (tdb (tasks:open-db)) + (spid (tasks:server-get-server-id tdb #f iface port #f))) + (print "Keep-running got server pid " spid ", using iface " iface " and port " port) + (let loop ((count 0)) + (thread-sleep! 4) ;; no need to do this very often + ;; NB// sync currently does NOT return queue-length + (let () ;; (queue-len (cdb:client-call server-info 'sync #t 1))) + ;; (print "Server running, count is " count) + (if (< count 1) ;; 3x3 = 9 secs aprox + (loop (+ count 1))) + + ;; NOTE: Get rid of this mechanism! It really is not needed... + (tasks:server-update-heartbeat tdb spid) + + ;; (if ;; (or (> numrunning 0) ;; stay alive for two days after last access + (mutex-lock! *heartbeat-mutex*) + (set! last-access *last-db-access*) + (mutex-unlock! *heartbeat-mutex*) + (if (> (+ last-access + ;; (* 50 60 60) ;; 48 hrs + ;; 60 ;; one minute + ;; (* 60 60) ;; one hour + (* 45 60) ;; 45 minutes, until the db deletion bug is fixed. + ) + (current-seconds)) + (begin + (debug:print-info 2 "Server continuing, seconds since last db access: " (- (current-seconds) last-access)) + (loop 0)) + (begin + (debug:print-info 0 "Starting to shutdown the server.") + ;; need to delete only *my* server entry (future use) + (set! *time-to-exit* #t) + (tasks:server-deregister-self tdb (get-host-name)) + (thread-sleep! 1) + (debug:print-info 0 "Max cached queries was " *max-cache-size*) + (debug:print-info 0 "Server shutdown complete. Exiting") + (exit))))))) + +;; all routes though here end in exit ... +(define (zmq-transport:launch) + (if (not *toppath*) + (if (not (setup-for-run)) + (begin + (debug:print 0 "ERROR: cannot find megatest.config, exiting") + (exit)))) + (debug:print-info 2 "Starting zmq server") + (if *toppath* + (let* (;; (th1 (make-thread (lambda () + ;; (let ((server-info #f)) + ;; ;; wait for the server to be online and available + ;; (let loop () + ;; (debug:print-info 2 "Waiting for the server to come online before starting heartbeat") + ;; (thread-sleep! 2) + ;; (mutex-lock! *heartbeat-mutex*) + ;; (set! server-info *server-info* ) + ;; (mutex-unlock! *heartbeat-mutex*) + ;; (if (not server-info)(loop))) + ;; (debug:print 2 "Server alive, starting self-ping") + ;; (zmq-transport:self-ping server-info) + ;; )) + ;; "Self ping")) + (th2 (make-thread (lambda () + (zmq-transport:run + (if (args:get-arg "-server") + (args:get-arg "-server") + "-"))) "Server run")) + ;; (th3 (make-thread (lambda ()(zmq-transport:keep-running)) "Keep running")) + ) + (set! *client-non-blocking-mode* #t) + ;; (thread-start! th1) + (thread-start! th2) + ;; (thread-start! th3) + (set! *didsomething* #t) + ;; (thread-join! th3) + (thread-join! th2) + ) + (debug:print 0 "ERROR: Failed to setup for megatest"))) + +(define (zmq-transport:client-signal-handler signum) + (handle-exceptions + exn + (debug:print " ... exiting ...") + (let ((th1 (make-thread (lambda () + (if (not *received-response*) + (receive-message* *runremote*))) ;; flush out last call if applicable + "eat response")) + (th2 (make-thread (lambda () + (debug:print 0 "ERROR: Received ^C, attempting clean exit. Please be patient and wait a few seconds before hitting ^C again.") + (thread-sleep! 3) ;; give the flush three seconds to do it's stuff + (debug:print 0 " Done.") + (exit 4)) + "exit on ^C timer"))) + (thread-start! th2) + (thread-start! th1) + (thread-join! th2)))) + +(define (zmq-transport:client-launch) + (set-signal-handler! signal/int zmq-transport:client-signal-handler) + (if (zmq-transport:client-setup) + (debug:print-info 2 "connected as client") + (begin + (debug:print 0 "ERROR: Failed to connect as client") + (exit)))) + +;;====================================================================== +;; Defunct functions +;;====================================================================== + +;; ping a server and return number of clients or #f (if no response) +;; NOT IN USE! +(define (zmq-transport:ping host port #!key (secs 10)(return-socket #f)) + (cdb:use-non-blocking-mode + (lambda () + (let* ((res #f) + (th1 (make-thread + (lambda () + (let* ((zmq-context (make-context 1)) + (zmq-socket (zmq-transport:client-connect host port context: zmq-context))) + (if zmq-socket + (if (zmq-transport:client-login zmq-socket) + (let ((numclients (cdb:num-clients zmq-socket))) + (if (not return-socket) + (begin + (zmq-transport:client-logout zmq-socket) + (close-socket zmq-socket))) + (set! res (list #t numclients (if return-socket zmq-socket #f)))) + (begin + ;; (close-socket zmq-socket) + (set! res (list #f "CAN'T LOGIN" #f)))) + (set! res (list #f "CAN'T CONNECT" #f))))) + "Ping: th1")) + (th2 (make-thread + (lambda () + (let loop ((count 1)) + (debug:print-info 1 "Ping " count " server on " host " at port " port) + (thread-sleep! 2) + (if (< count (/ secs 2)) + (loop (+ count 1)))) + ;; (thread-terminate! th1) + (set! res (list #f "TIMED OUT" #f))) + "Ping: th2"))) + (thread-start! th2) + (thread-start! th1) + (handle-exceptions + exn + (set! res (list #f "TIMED OUT" #f)) + (thread-join! th1 secs)) + res)))) + +;; (define (zmq-transport:self-ping server-info) +;; ;; server-info: server-id interface pullport pubport +;; (let ((iface (list-ref server-info 1)) +;; (pullport (list-ref server-info 2)) +;; (pubport (list-ref server-info 3))) +;; (zmq-transport:client-connect iface pullport pubport) +;; (let loop () +;; (thread-sleep! 2) +;; (cdb:client-call *runremote* 'ping #t) +;; (debug:print 4 "zmq-transport:self-ping - I'm alive on " iface ":" pullport "/" pubport "!") +;; (mutex-lock! *heartbeat-mutex*) +;; (set! *server-loop-heart-beat* (current-seconds)) +;; (mutex-unlock! *heartbeat-mutex*) +;; (loop)))) + +(define (zmq-transport:reply pubsock target query-sig success/fail result) + (debug:print-info 11 "zmq-transport:reply target=" target ", result=" result) + (send-message pubsock target send-more: #t) + (send-message pubsock (db:obj->string (vector success/fail query-sig result)))) + ADDED portlogger.scm Index: portlogger.scm ================================================================== --- /dev/null +++ portlogger.scm @@ -0,0 +1,141 @@ + +;; Copyright 2006-2014, Matthew Welland. +;; +;; This program is made available under the GNU GPL version 2.0 or +;; greater. See the accompanying file COPYING for details. +;; +;; This program is distributed WITHOUT ANY WARRANTY; without even the +;; implied warranty of MERCHANTABILITY or FITNESS FOR A PARTICULAR +;; PURPOSE. + +(require-extension (srfi 18) extras tcp s11n) + +(use sqlite3 srfi-1 posix srfi-69 hostinfo dot-locking) +(import (prefix sqlite3 sqlite3:)) + +(declare (unit portlogger)) + +;; lsof -i + + +(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 (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)) + (canwrite (file-write-access? fname))) + (sqlite3:set-busy-handler! db handler) + (sqlite3:execute db "PRAGMA synchronous = 0;") + (if (not exists) + (sqlite3:execute + db + "CREATE TABLE ports ( + port INTEGER PRIMARY KEY, + state TEXT DEFAULT 'not-used', + fail_count INTEGER DEFAULT 0, + 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 + (handle-exceptions + exn + (begin + ;; (release-dot-lock fname) + (debug:print 0 "ERROR: portlogger:open-run-close failed. " proc " " params) + (debug:print 0 " message: " ((condition-property-accessor 'exn 'message) exn)) + (debug:print 0 "exn=" (condition->list exn)) + (print-call-chain)) + (let* (;; (lock (obtain-dot-lock fname 2 9 10)) + (db (portlogger:open-db fname)) + (res (apply proc db params))) + (sqlite3:finalize! db) + ;; (release-dot-lock fname) + res)))) + +;; (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 () + ;; (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) + (or curr var curr)) + "not-tried" + qry3 + portnum)) + ;; (print "curr=" curr) + (set! res (case (string->symbol curr) + ((released) (sqlite3:execute qry2 "taken" portnum) 'taken) + ((not-tried) (sqlite3:execute qry1 portnum "taken") 'taken) + ((taken) 'already-taken) + ((failed) 'failed) + (else 'error))) + ;; (print "res=" res) + res))))) + (sqlite3:finalize! qry1) + (sqlite3:finalize! qry2) + (sqlite3:finalize! qry3) + res)) + +(define (portlogger:get-prev-used-port db) + (sqlite3:fold-row + (lambda (var curr) + (or curr var curr)) + #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)))))) + (portlogger:take-port db portnum) + portnum)) + +;; 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)) + +;; 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)) + +;;====================================================================== +;; MAIN +;;====================================================================== + +(define (portlogger:main . args) + (let* ((db (portlogger:open-db (conc "/tmp/." (current-user-name) "-portlogger.db"))) + (numargs (length args)) + (result (cond + ((> numargs 1) ;; most commands + (case (string->symbol (car args)) ;; commands with two or more params + ((take)(portlogger:take-port db (string->number (cadr args)))) + ((set) (portlogger:set-port db + (string->number (cadr args)) + (caddr args)) + (caddr args)) + ((failed)(portlogger:set-failed db (string->number (cadr args))) 'failed)))))) + (sqlite3:finalize! db) + result)) + +;; (print (apply portlogger:main (cdr (argv)))) Index: rmt.scm ================================================================== --- rmt.scm +++ rmt.scm @@ -7,11 +7,11 @@ ;; This program is distributed WITHOUT ANY WARRANTY; without even the ;; implied warranty of MERCHANTABILITY or FITNESS FOR A PARTICULAR ;; PURPOSE. ;;====================================================================== -(use json) +(use json format) (declare (unit rmt)) (declare (uses api)) (declare (uses tdb)) (declare (uses http-transport)) @@ -31,31 +31,146 @@ ;;====================================================================== ;; S U P P O R T F U N C T I O N S ;;====================================================================== + +;; #t means - please start a server! +;; +(define (rmt:write-frequency-over-limit? cmd run-id) + (and (not (member cmd api:read-only-queries)) + (let* ((tmprec (hash-table-ref/default *write-frequency* run-id #f)) + (record (if tmprec tmprec + (let ((v (vector (current-seconds) 0))) + (hash-table-set! *write-frequency* run-id v) + v))) + (count (+ 1 (vector-ref record 1))) + (start (vector-ref record 0)) + (queries-per-second (/ (* count 1.0) + (max (- (current-seconds) start) 1)))) + (vector-set! record 1 count) + (if (and (> count 10) + (> queries-per-second 10)) + (begin + (debug:print-info 1 "db write rate too high, starting a server, count=" count " start=" start " run-id=" run-id " queries-per-second=" queries-per-second) + #t) + #f)))) ;; cmd is a symbol ;; vars is a json string encoding the parameters for the call ;; -(define (rmt:send-receive cmd params) - (case *transport-type* - ((fs-aint-here) - (debug:print 0 "ERROR: Not yet (re)supported") - (exit 1)) - ((fs http) - (let* ((jparams (db:obj->string params)) ;; (rmt:dat->json-str params)) - (res (http-transport:client-api-send-receive *runremote* cmd jparams))) - (if res - (db:string->obj res) ;; (rmt:json-str->dat res) - (begin - (debug:print 0 "ERROR: Bad value from http-transport:client-api-send-receive " res) - #f)) - )) - (else - (debug:print 0 "ERROR: Transport " *transport-type* " not yet (re)supported") - (exit 1)))) +(define (rmt:send-receive cmd rid params) + (let* ((run-id (if rid rid 0)) + (connection-info (let ((cinfo (hash-table-ref/default *runremote* run-id #f))) + (if cinfo + cinfo + ;; NB// can cache the answer for server running for 10 seconds ... + ;; ;; (and (not (rmt:write-frequency-over-limit? cmd run-id)) + (if (tasks:server-running-or-starting? (tasks:get-db) run-id) + (let ((res (client:setup run-id))) + (if res + (hash-table-ref/default *runremote* run-id #f) ;; client:setup filled this in (hopefully) + #f)) + #f)))) + (jparams (db:obj->string params))) + (if connection-info + (let ((res (http-transport:client-api-send-receive run-id connection-info cmd jparams))) + (if res + (db:string->obj res) + (let ((new-connection-info (client:setup run-id))) + (debug:print 0 "WARNING: Communication failed, trying call to http-transport:client-api-send-receive again.") + (rmt:send-receive cmd run-id params)))) + (let ((max-avg-qry (string->number (or (configf:lookup *configdat* "server" "server-query-threshold") "800")))) + (debug:print-info 4 "no server and read-only query, bypassing normal channel") + ;; (if (rmt:write-frequency-over-limit? cmd run-id)(server:kind-run run-id)) + (let ((curr-max (rmt:get-max-query-average))) + (if (> (cdr curr-max) max-avg-qry) + (begin + (debug:print-info 3 "Max average query, " (inexact->exact (round (cdr curr-max))) "ms (" (car curr-max) ") exceeds " max-avg-qry ", try starting server ...") + (server:kind-run run-id)))) + (rmt:open-qry-close-locally cmd run-id params))))) + +(define (rmt:update-db-stats rawcmd params duration) + (mutex-lock! *db-stats-mutex*) + (let* ((cmd (if (eq? rawcmd 'general-call) (car params) rawcmd)) + (stat-vec (hash-table-ref/default *db-stats* cmd #f))) + (if (not 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 "DB Stats\n========") + (debug:print 18 (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 (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) + (mutex-lock! *db-stats-mutex*) + (let* ((cmds (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) + (let* ((dbdir (conc (configf:lookup *configdat* "setup" "linktree") "/.db")) + (dbstruct-local (if *dbstruct-db* + *dbstruct-db* + (let ((db (make-dbr:dbstruct path: dbdir local: #t))) + (set! *dbstruct-db* db) + db))) + (db-file-path (db:dbfile-path 0))) + ;; (read-only (not (file-read-access? db-file-path))) + (let* ((start (current-milliseconds)) + (res (api:execute-requests dbstruct-local (symbol->string cmd) params)) + (duration (- (current-milliseconds) start))) + (rmt:update-db-stats cmd params duration) + ;; mark this run as dirty if this was a write + (if (not (member cmd api:read-only-queries)) + (let ((start-time (current-seconds))) + (mutex-lock! *db-multi-sync-mutex*) + (let ((last-sync (hash-table-ref/default *db-local-sync* run-id 0))) + (if (> (- start-time last-sync) 5) ;; every five seconds + (begin + (db:multi-db-sync (list run-id) 'new2old) + (debug:print-info 0 "Sync of newdb to olddb for run-id " run-id " completed in " (- (current-seconds) start-time) " seconds") + (hash-table-set! *db-local-sync* run-id start-time)))) + (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)) + (jparams (db:obj->string params)) ;; (rmt:dat->json-str params)) + (res (http-transport:client-api-send-receive run-id connection-info cmd jparams))) + (if res + (db:string->obj res) + res))) ;; Wrap json library for strings (why the ports crap in the first place?) (define (rmt:dat->json-str dat) (with-output-to-string (lambda () @@ -69,148 +184,265 @@ ;;====================================================================== ;; ;; 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) - (rmt:send-receive 'login (list *toppath* megatest-version *my-client-signature*))) +(define (rmt:login run-id) + (rmt:send-receive 'login run-id (list *toppath* megatest-version run-id *my-client-signature*))) -(define (rmt:kill-server) - (rmt:send-receive 'kill-server '())) - +;; This login does no retries under the hood - it acts a bit like a ping. +;; +(define (rmt:login-no-auto-client-setup connection-info run-id) + (rmt:send-receive-no-auto-client-setup connection-info 'login run-id (list *toppath* megatest-version run-id *my-client-signature*))) + ;; hand off a call to one of the db:queries statements -(define (rmt:general-call stmtname . params) - (rmt:send-receive 'general-call (append (list stmtname) params))) +;; 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))) + +(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))) -(define (rmt:sync-inmem->db) - (rmt:send-receive 'sync-inmem->db '())) +;; NOT COMPLETED +(define (rmt:runtests user run-id testpatt params) + (rmt:send-receive 'runtests run-id testpatt)) ;;====================================================================== ;; 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 (list run-id))) + (rmt:send-receive 'get-key-val-pairs run-id (list run-id))) (define (rmt:get-keys) - (rmt:send-receive 'get-keys '())) + (rmt:send-receive 'get-keys #f '())) ;;====================================================================== ;; T E S T S ;;====================================================================== (define (rmt:get-test-id run-id testname item-path) - (rmt:send-receive 'get-test-id (list run-id testname item-path))) - -(define (rmt:get-test-info-by-id test-id) - (rmt:send-receive 'get-test-info-by-id (list test-id))) - -(define (rmt:test-get-rundir-from-test-id test-id) - (rmt:send-receive 'test-get-rundir-from-test-id (list test-id))) - -(define (rmt:open-test-db-by-test-id test-id #!key (work-area #f)) + (rmt:send-receive 'get-test-id run-id (list run-id testname item-path))) + +(define (rmt:get-test-info-by-id run-id test-id) + (if (and (number? run-id)(number? test-id)) + (rmt:send-receive 'get-test-info-by-id run-id (list run-id test-id)) + (begin + (debug:print 0 "ERROR: Bad data handed to rmt:get-test-info-by-id run-id=" run-id ", test-id=" test-id) + (print-call-chain) + #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 test-id)))) + (rmt:test-get-rundir-from-test-id run-id test-id)))) (debug:print 3 "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 test-id newstate newstatus newcomment) - (rmt:send-receive 'test-set-state-status-by-id (list test-id newstate newstatus newcomment))) +(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 (list 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) - (rmt:send-receive 'get-tests-for-run (list run-id testpatt states statuses offset limit not-in sort-by sort-order qryvals))) + (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)) + (begin + (debug:print "ERROR: rmt:get-tests-for-run called with bad run-id=" run-id) + (print-call-chain) + '()))) (define (rmt:get-tests-for-runs-mindata run-ids testpatt states status not-in) - (rmt:send-receive 'get-tests-for-runs-mindata (list run-ids testpatt states status not-in))) - -(define (rmt:delete-test-records test-id) - (rmt:send-receive 'delete-test-records (list test-id))) - -(define (rmt:test-set-status-state test-id status state msg) - (rmt:send-receive 'test-set-status-state (list test-id status state msg))) - -(define (rmt:get-previous-test-run-record run-id test-name item-path) - (rmt:send-receive 'get-previous-test-run-record (list run-id test-name item-path))) + (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-status-state run-id test-id status state msg) + (rmt:send-receive 'test-set-status-state run-id (list run-id test-id status state 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 (list 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 (list 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 (list run-id test-name))) - -(define (rmt:get-testinfo-state-status test-id) - (rmt:send-receive 'get-testinfo-state-status (list test-id))) - -(define (rmt:test-set-log! test-id logf) - (if (string? logf)(rmt:general-call 'test-set-log logf test-id))) - + (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: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) - (rmt:send-receive 'test-get-paths-matching-keynames-target-new (list 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-item-path #!key (mode 'normal)) - (rmt:send-receive 'get-prereqs-not-met (list run-id waitons ref-item-path mode))) +(define (rmt:get-prereqs-not-met run-id waitons ref-item-path #!key (mode '(normal))) + (rmt:send-receive 'get-prereqs-not-met run-id (list run-id waitons ref-item-path mode))) (define (rmt:get-count-tests-running-for-run-id run-id) - (rmt:send-receive 'get-count-tests-running-for-run-id (list 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) - (rmt:send-receive 'get-count-tests-running '())) +(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-in-jobgroup jobgroup) - (rmt:send-receive 'get-count-tests-running-in-jobgroup (list jobgroup))) +(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))) (define (rmt:roll-up-pass-fail-counts run-id test-name item-path status) - (rmt:send-receive 'roll-up-pass-fail-counts (list run-id test-name item-path status))) + (rmt:send-receive 'roll-up-pass-fail-counts run-id (list run-id test-name item-path status))) (define (rmt:update-pass-fail-counts run-id test-name) - (rmt:general-call 'update-fail-pass-counts run-id test-name run-id test-name run-id test-name)) + (rmt:general-call 'update-fail-pass-counts run-id (list run-id test-name run-id test-name run-id test-name))) ;;====================================================================== ;; R U N S ;;====================================================================== (define (rmt:get-run-info run-id) - (rmt:send-receive 'get-run-info (list run-id))) + (rmt:send-receive 'get-run-info run-id (list run-id))) +;; Use the special run-id == #f scenario here since there is no run yet (define (rmt:register-run keyvals runname state status user) - (rmt:send-receive 'register-run (list keyvals runname state status user))) + (rmt:send-receive 'register-run #f (list keyvals runname state status user))) (define (rmt:get-run-name-from-id run-id) - (rmt:send-receive 'get-run-name-from-id (list 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 (list run-id))) + (rmt:send-receive 'delete-run run-id (list run-id))) (define (rmt:delete-old-deleted-test-records) - (rmt:send-receive '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:get-runs runpatt count offset keypatts) - (rmt:send-receive 'get-runs (list runpatt count offset keypatts))) + (rmt:send-receive 'get-runs #f (list runpatt count offset keypatts))) + +(define (rmt:get-all-run-ids) + (rmt:send-receive 'get-all-run-ids #f '())) -(define (rmt:get-runs-by-patt keys runnamepatt targpatt offset limit) - (rmt:send-receive 'get-runs-by-patt (list keys runnamepatt targpatt offset limit))) +(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 (list 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 (list run-id))) + (rmt:send-receive 'update-run-event_time #f (list run-id))) + +(define (rmt:get-runs-by-patt keys runnamepatt targpatt offset limit) + (rmt:send-receive 'get-runs-by-patt #f (list keys runnamepatt targpatt offset limit))) + +(define (rmt:find-and-mark-incomplete run-id ovr-deadtime) + (rmt:send-receive 'find-and-mark-incomplete run-id (list run-id ovr-deadtime))) + +;;====================================================================== +;; 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 "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) '() '() #f #f #f #f #f #f))) + (debug:print 4 "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)))))))))) ;;====================================================================== ;; S T E P S ;;====================================================================== @@ -221,43 +453,43 @@ ;; 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 test-id) - (rmt:send-receive 'get-steps-data (list test-id))) +(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! test-id teststep-name state-in status-in comment logfile) +(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 "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! (list test-id teststep-name state-in status-in comment logfile)))) + (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 test-id) - (rmt:send-receive 'get-steps-for-test (list test-id))) +(define (rmt:get-steps-for-test run-id test-id) + (rmt:send-receive 'get-steps-for-test run-id (list test-id))) ;;====================================================================== ;; T E S T D A T A ;;====================================================================== -(define (rmt:read-test-data test-id categorypatt #!key (work-area #f)) - (let ((tdb (rmt:open-test-db-by-test-id test-id work-area: work-area))) +(define (rmt:read-test-data run-id test-id categorypatt #!key (work-area #f)) + (let ((tdb (rmt:open-test-db-by-test-id run-id test-id work-area: work-area))) (if tdb (tdb:read-test-data tdb test-id categorypatt) '()))) (define (rmt:testmeta-add-record testname) - (rmt:send-receive 'testmeta-add-record (list testname))) + (rmt:send-receive 'testmeta-add-record #f (list testname))) (define (rmt:testmeta-get-record testname) - (rmt:send-receive 'testmeta-get-record (list 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 (list test-name fld val))) + (rmt:send-receive 'testmeta-update-field #f (list test-name fld val))) -(define (rmt:test-data-rollup test-id status) - (rmt:send-receive 'test-data-rollup (list test-id status))) +(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 test-id csvdata) - (rmt:send-receive 'csv->test-data (list test-id csvdata))) +(define (rmt:csv->test-data run-id test-id csvdata) + (rmt:send-receive 'csv->test-data run-id (list run-id test-id csvdata))) Index: runconfig.scm ================================================================== --- runconfig.scm +++ runconfig.scm @@ -11,12 +11,11 @@ (include "common_records.scm") (define (setup-env-defaults fname run-id already-seen keyvals #!key (environ-patt #f)(change-env #t)) (let* ((keys (map car keyvals)) (thekey (if keyvals (string-intersperse (map (lambda (x)(if x x "-na-")) (map cadr keyvals)) "/") - (or (args:get-arg "-reqtarg") - (args:get-arg "-target") + (or (common:args-get-target) (get-environment-variable "MT_TARGET") (begin (debug:print 0 "ERROR: setup-env-defaults called with no run-id or -target or -reqtarg") "nothing matches this I hope")))) ;; Why was system disallowed in the reading of the runconfigs file? @@ -29,11 +28,11 @@ (debug:print 4 "Using key=\"" thekey "\"") (if change-env (for-each ;; NB// This can be simplified with new content of keyvals having all that is needed. (lambda (keyval) - (setenv (car keyval)(cadr keyval))) + (safe-setenv (car keyval)(cadr keyval))) keyvals)) (for-each (lambda (section) (let ((section-dat (hash-table-ref/default confdat section #f))) @@ -43,11 +42,11 @@ (let ((val (cadr (assoc envvar section-dat)))) (hash-table-set! whatfound section (+ (hash-table-ref/default whatfound section 0) 1)) (if (and (string? envvar) (string? val) change-env) - (setenv envvar val)) + (safe-setenv envvar val)) (hash-table-set! finaldat envvar val))) (map car section-dat))))) sections) (if already-seen (begin @@ -60,12 +59,11 @@ finaldat)) (define (set-run-config-vars run-id keyvals targ-from-db) (push-directory *toppath*) ;; the push/pop doesn't appear to do anything ... (let ((runconfigf (conc *toppath* "/runconfigs.config")) - (targ (or (args:get-arg "-target") - (args:get-arg "-reqtarg") + (targ (or (common:args-get-target) targ-from-db (get-environment-variable "MT_TARGET")))) (pop-directory) (if (file-exists? runconfigf) (setup-env-defaults runconfigf run-id #t keyvals Index: runs.scm ================================================================== --- runs.scm +++ runs.scm @@ -19,10 +19,11 @@ (declare (uses items)) (declare (uses runconfig)) (declare (uses tests)) (declare (uses server)) (declare (uses mt)) +;; (declare (uses filedb)) (include "common_records.scm") (include "key_records.scm") (include "db_records.scm") (include "run_records.scm") @@ -36,20 +37,19 @@ ;; This is the *new* methodology. One record to inform them and in the chaos, organise them. ;; (define (runs:create-run-record) (let* ((mconfig (if *configdat* *configdat* - (if (setup-for-run) + (if (launch:setup-for-run) *configdat* (begin (debug:print 0 "ERROR: Called setup in a non-megatest area, exiting") (exit 1))))) (runrec (runs:runrec-make-record)) - (target (or (args:get-arg "-reqtarg") - (args:get-arg "-target"))) - (runname (or (args:get-arg ":runname") - (args:get-arg "-runname"))) + (target (common:args-get-target)) + (runname (or (args:get-arg "-runname") + (args:get-arg ":runname"))) (testpatt (or (args:get-arg "-testpatt") (args:get-arg "-runtests"))) (keys (keys:config-get-fields mconfig)) (keyvals (keys:target->keyval keys target)) (toppath *toppath*) @@ -57,15 +57,10 @@ (runconfig #f) (serverdat (if (args:get-arg "-server") *runremote* #f)) ;; to be used later (transport (or (args:get-arg "-transport") 'http)) - (db (if (and mconfig - (or (args:get-arg "-server") - (eq? transport 'fs))) - (open-db) - #f)) (run-id #f)) ;; Set all the environment vars we know so far, start with keys (for-each (lambda (keyval) (setenv (car keyval)(cadr keyval))) keyvals) @@ -88,23 +83,26 @@ (exit 1))) ;; Now have runconfigs data loaded, set environment vars (for-each (lambda (section) (for-each (lambda (varval) (set! envdat (append envdat (list varval))) - (setenv (car varval)(cadr varval))) + (safe-setenv (car varval)(cadr varval))) (configf:get-section runconfig section))) (list "default" target)) (vector target runname testpatt keys keyvals envdat mconfig runconfig serverdat transport db toppath run-id))) -(define (set-megatest-env-vars run-id #!key (inkeys #f)(inrunname #f)(inkeyvals #f)) - (let* ((target (or (args:get-arg "-reqtarg") - (args:get-arg "-target") - (get-environment-variable "MT_TARGET"))) +(define (runs:set-megatest-env-vars run-id #!key (inkeys #f)(inrunname #f)(inkeyvals #f)) + (let* ((target (or (common:args-get-target) + (get-environment-variable "MT_TARGET"))) (keys (if inkeys inkeys (rmt:get-keys))) - (keyvals (if inkeyvals inkeyvals (keys:target->keyval keys target))) - (vals (hash-table-ref/default *env-vars-by-run-id* run-id #f))) + (keyvals (if inkeyvals inkeyvals (keys:target->keyval keys target))) + (vals (hash-table-ref/default *env-vars-by-run-id* run-id #f)) + (link-tree (configf:lookup *configdat* "setup" "linktree"))) ;; get the info from the db and put it in the cache + (if link-tree + (setenv "MT_LINKTREE" link-tree) + (debug:print 0 "ERROR: linktree not set, should be set in megatest.config in [setup] section.")) (if (not vals) (let ((ht (make-hash-table))) (hash-table-set! *env-vars-by-run-id* run-id ht) (set! vals ht) (for-each @@ -114,14 +112,11 @@ ;; from the cached data set the vars (hash-table-for-each vals (lambda (key val) (debug:print 2 "setenv " key " " val) - (if (and (string? key) - (string? val)) - (setenv key val) - (debug:print 0 "ERROR: Malformed environment variable definition: var=" var ", val=" val)))) + (safe-setenv key val))) (if (not (get-environment-variable "MT_TARGET"))(setenv "MT_TARGET" target)) (alist->env-vars (hash-table-ref/default *configdat* "env-override" '())) ;; Lets use this as an opportunity to put MT_RUNNAME in the environment (let ((runname (if inrunname inrunname (rmt:get-run-name-from-id run-id)))) (if runname @@ -163,17 +158,20 @@ (begin (hash-table-set! *runs:denoise* key currtime) #t) #f))) -(define (runs:can-run-more-tests jobgroup max-concurrent-jobs) +(define (runs:can-run-more-tests run-id jobgroup max-concurrent-jobs) (thread-sleep! (cond ((> *runs:can-run-more-tests-count* 20) 2);; obviously haven't had any work to do for a while (else 0))) - (let* ((num-running (rmt:get-count-tests-running)) - (num-running-in-jobgroup (rmt:get-count-tests-running-in-jobgroup jobgroup)) - (job-group-limit (config-lookup *configdat* "jobgroups" jobgroup))) + (let* ((num-running (rmt:get-count-tests-running run-id)) + (num-running-in-jobgroup (rmt:get-count-tests-running-in-jobgroup run-id jobgroup)) + (job-group-limit (let ((jobg-count (config-lookup *configdat* "jobgroups" jobgroup))) + (if (string? jobg-count) + (string->number jobg-count) + jobg-count)))) (if (> (+ num-running num-running-in-jobgroup) 0) (set! *runs:can-run-more-tests-count* (+ *runs:can-run-more-tests-count* 1))) (if (not (eq? *last-num-running-tests* num-running)) (begin (debug:print 2 "max-concurrent-jobs: " max-concurrent-jobs ", num-running: " num-running) @@ -190,56 +188,78 @@ #t) ;; if job-group-limit is set and number of jobs in the group is greater ;; than the limit then cannot run more jobs of this kind ((and job-group-limit (>= num-running-in-jobgroup job-group-limit)) - (debug:print 1 "WARNING: number of jobs " num-running-in-jobgroup - " in " jobgroup " exceeded, will not run " (tests:testqueue-get-testname test-record)) + (if (runs:lownoise (conc "maxjobgroup " jobgroup) 60) + (debug:print 1 "WARNING: number of jobs " num-running-in-jobgroup + " in jobgroup \"" jobgroup "\" exceeds limit of " job-group-limit)) #t) (else #f)))) (list (not can-not-run-more) num-running num-running-in-jobgroup max-concurrent-jobs job-group-limit))))) + ;; test-names: Comma separated patterns same as test-patts but used in selection ;; of tests to run. The item portions are not respected. ;; FIXME: error out if /patt specified ;; -(define (runs:run-tests target runname test-patts user flags) ;; test-names - (common:clear-caches) ;; clear all caches +(define (runs:run-tests target runname test-patts user flags #!key (run-count 3)) ;; test-names (let* ((keys (keys:config-get-fields *configdat*)) (keyvals (keys:target->keyval keys target)) (run-id (rmt:register-run keyvals runname "new" "n/a" user)) ;; test-name))) (deferred '()) ;; delay running these since they have a waiton clause (runconfigf (conc *toppath* "/runconfigs.config")) - (required-tests '()) (test-records (make-hash-table)) - (all-tests-registry (tests:get-all)) ;; (tests:get-valid-tests (make-hash-table) test-search-path)) ;; all valid tests to check waiton names - (all-test-names (hash-table-keys all-tests-registry)) - (test-names (tests:filter-test-names all-test-names test-patts))) - - ;; Update the synchronous setting in the db based on the default or what is set by the user - ;; This is done once here on a call to run tests rather than on every call to open-db - - (set-megatest-env-vars run-id inkeys: keys inrunname: runname) ;; these may be needed by the launching process + ;; need to process runconfigs before generating these lists + (all-tests-registry #f) ;; (tests:get-all)) ;; (tests:get-valid-tests (make-hash-table) test-search-path)) ;; all valid tests to check waiton names + (all-test-names #f) ;; (hash-table-keys all-tests-registry)) + (test-names #f) ;; (tests:filter-test-names all-test-names test-patts)) + (required-tests #f) ;;(lset-intersection equal? (string-split test-patts ",") test-names))) ;; test-names)) ;; Added test-names as initial for required-tests but that failed to work + (task-key (conc (hash-table->alist flags) " " (get-host-name) " " (current-process-id))) + (tasks-db (tasks:open-db))) + + (set-signal-handler! signal/int + (lambda (signum) + (let ((tdb (tasks:open-db))) + (tasks:set-state-given-param-key tdb task-key "killed") + (sqlite3:finalize! tdb)) + (print "Killed by sigint. Exiting") + (exit))) + + ;; register this run in monitor.db + (tasks:add tasks-db "run-tests" user target runname test-patts task-key) ;; params) + (tasks:set-state-given-param-key tasks-db task-key "running") + (runs:set-megatest-env-vars run-id inkeys: keys inrunname: runname) ;; these may be needed by the launching process (if (file-exists? runconfigf) - (setup-env-defaults runconfigf run-id *already-seen-runconfig-info* keyvals "pre-launch-env-vars") + (setup-env-defaults runconfigf run-id *already-seen-runconfig-info* keyvals target) (debug:print 0 "WARNING: You do not have a run config file: " runconfigf)) + + ;; Now generate all the tests lists + (set! all-tests-registry (tests:get-all)) + (set! all-test-names (hash-table-keys all-tests-registry)) + (set! test-names (tests:filter-test-names all-test-names test-patts)) + (set! required-tests (lset-intersection equal? (string-split test-patts ",") test-names)) ;; look up all tests matching the comma separated list of globs in ;; test-patts (using % as wildcard) ;; (set! test-names (delete-duplicates (tests:get-valid-tests *toppath* test-patts))) - (debug:print-info 0 "test names " test-names) + (debug:print-info 0 "tests search path: " (tests:get-tests-search-path *configdat*)) + (debug:print-info 0 "all tests: " (string-intersperse (sort all-test-names string<) " ")) + (debug:print-info 0 "test names: " (string-intersperse (sort test-names string<) " ")) ;; on the first pass or call to run-tests set FAILS to NOT_STARTED if ;; -keepgoing is specified (if (eq? *passnum* 0) (begin ;; have to delete test records where NOT_STARTED since they can cause -keepgoing to ;; get stuck due to becoming inaccessible from a failed test. I.e. if test B depends ;; on test A but test B reached the point on being registered as NOT_STARTED and test ;; A failed for some reason then on re-run using -keepgoing the run can never complete. - (rmt:general-call 'delete-tests-in-state run-id "NOT_STARTED") + (for-each (lambda (state) + (rmt:general-call 'delete-tests-in-state run-id state)) + (cons "NOT_STARTED" (string-split (or (configf:lookup *configdat* "setup" "allow-auto-rerun") "")))) (rmt:set-tests-state-status run-id test-names #f "FAIL" "NOT_STARTED" "FAIL"))) ;; Ensure all tests are registered in the test_meta table (runs:update-all-test_meta #f) @@ -336,13 +356,24 @@ (debug:print-info 1 "Adding " required-tests " to the run queue")) ;; NOTE: these are all parent tests, items are not expanded yet. (debug:print-info 4 "test-records=" (hash-table->alist test-records)) (let ((reglen (configf:lookup *configdat* "setup" "runqueue"))) (if (> (length (hash-table-keys test-records)) 0) - (runs:run-tests-queue run-id runname test-records keyvals flags test-patts required-tests (any->number reglen) all-tests-registry) + (begin + (runs:run-tests-queue run-id runname test-records keyvals flags test-patts required-tests (any->number reglen) all-tests-registry) + ;; if run-count > 0 call, set -preclean and -rerun STUCK/DEAD + (if (> run-count 0) + (begin + (if (not (hash-table-ref/default flags "-preclean" #f)) + (hash-table-set! flags "-preclean" #t)) + (if (not (hash-table-ref/default flags "-rerun" #f)) + (hash-table-set! flags "-rerun" "STUCK/DEAD,n/a,ZERO_ITEMS")) + (runs:run-tests target runname test-patts user flags run-count: (- run-count 1))))) (debug:print-info 0 "No tests to run"))) - (debug:print-info 4 "All done by here"))) + (debug:print-info 4 "All done by here") + (tasks:set-state-given-param-key tasks-db task-key "done") + (sqlite3:finalize! tasks-db))) ;; loop logic. These are used in runs:run-tests-queue to make it a bit more readable. ;; ;; If reg not full and have items in tal then loop with (car tal)(cdr tal) reg reruns @@ -382,34 +413,39 @@ '() reg))) (define runs:nothing-left-in-queue-count 0) -(define (runs:expand-items hed tal reg reruns regfull newtal jobgroup max-concurrent-jobs run-id waitons item-path testmode test-record can-run-more items runname tconfig reglen test-registry test-records) +(define (runs:expand-items hed tal reg reruns regfull newtal jobgroup max-concurrent-jobs run-id waitons item-path testmode test-record can-run-more items runname tconfig reglen test-registry test-records itemmap) (let* ((loop-list (list hed tal reg reruns)) - (prereqs-not-met (rmt:get-prereqs-not-met run-id waitons item-path mode: testmode)) ;; (mt:lazy-get-prereqs-not-met run-id waitons item-path mode: testmode)) + (prereqs-not-met (rmt:get-prereqs-not-met run-id waitons item-path testmode itemmap: itemmap)) + ;; (prereqs-not-met (mt:lazy-get-prereqs-not-met run-id waitons item-path mode: testmode itemmap: itemmap)) (fails (runs:calc-fails prereqs-not-met)) - (non-completed (runs:calc-not-completed prereqs-not-met))) + (prereq-fails (runs:calc-prereq-fail prereqs-not-met)) + (non-completed (runs:calc-not-completed prereqs-not-met)) + (runnables (runs:calc-runnable prereqs-not-met))) (debug:print-info 4 "START OF INNER COND #2 " "\n can-run-more: " can-run-more "\n testname: " hed "\n prereqs-not-met: " (runs:pretty-string prereqs-not-met) "\n non-completed: " (runs:pretty-string non-completed) + "\n prereq-fails: " (runs:pretty-string prereq-fails) "\n fails: " (runs:pretty-string fails) "\n testmode: " testmode - "\n (eq? testmode 'toplevel): " (eq? testmode 'toplevel) + "\n (member 'toplevel testmode): " (member 'toplevel testmode) "\n (null? non-completed): " (null? non-completed) "\n reruns: " reruns "\n items: " items "\n can-run-more: " can-run-more) (cond ;; all prereqs met, fire off the test ;; or, if it is a 'toplevel test and all prereqs not met are COMPLETED then launch - ((member (hash-table-ref/default test-registry (runs:make-full-test-name hed item-path) 'n/a) - '(DONOTRUN removed)) ;; *common:cant-run-states-sym*) ;; '(COMPLETED KILLED WAIVED UNKNOWN INCOMPLETE)) ;; try to catch repeat processing of COMPLETED tests here + ((and (not (member 'toplevel testmode)) + (member (hash-table-ref/default test-registry (runs:make-full-test-name hed item-path) 'n/a) + '(DONOTRUN removed CANNOTRUN))) ;; *common:cant-run-states-sym*) ;; '(COMPLETED KILLED WAIVED UNKNOWN INCOMPLETE)) ;; try to catch repeat processing of COMPLETED tests here (debug:print-info 1 "Test " hed " set to \"" (hash-table-ref test-registry (runs:make-full-test-name hed item-path)) "\". Removing it from the queue") (if (or (not (null? tal)) (not (null? reg))) (list (runs:queue-next-hed tal reg reglen regfull) (runs:queue-next-tal tal reg reglen regfull) @@ -427,27 +463,31 @@ (set! runs:nothing-left-in-queue-count (+ runs:nothing-left-in-queue-count 1))) #f))) ;; ((or (null? prereqs-not-met) - (and (eq? testmode 'toplevel) + (and (member 'toplevel testmode) (null? non-completed))) - (debug:print-info 4 "runs:expand-items: (or (null? prereqs-not-met) (and (eq? testmode 'toplevel)(null? non-completed)))") + (debug:print-info 4 "runs:expand-items: (or (null? prereqs-not-met) (and (member 'toplevel testmode)(null? non-completed)))") (let ((test-name (tests:testqueue-get-testname test-record))) (setenv "MT_TEST_NAME" test-name) ;; (setenv "MT_RUNNAME" runname) - (set-megatest-env-vars run-id inrunname: runname) ;; these may be needed by the launching process + (runs:set-megatest-env-vars run-id inrunname: runname) ;; these may be needed by the launching process (let ((items-list (items:get-items-from-config tconfig))) (if (list? items-list) (begin + (if (null? items-list) + (let ((test-id (rmt:get-test-id run-id test-name ""))) + (mt:test-set-state-status-by-id run-id test-id "NOT_STARTED" "ZERO_ITEMS" "Failed to run due to failed prerequisites"))) (tests:testqueue-set-items! test-record items-list) (list hed tal reg reruns)) (begin (debug:print 0 "ERROR: The proc from reading the items table did not yield a list - please report this") (exit 1)))))) ((and (null? fails) + (null? prereq-fails) (not (null? non-completed))) (let* ((allinqueue (map (lambda (x)(if (string? x) x (db:test-get-testname x))) (append newtal reruns))) ;; prereqstrs is a list of test names as strings that are prereqs for hed (prereqstrs (delete-duplicates (map (lambda (x)(if (string? x) x (db:test-get-testname x))) @@ -459,83 +499,37 @@ ;; prereqstrs)) (give-up #f)) ;; We can get here when a prereq has not been run due to *it* having a prereq that failed. ;; We need to use this to dequeue this item as CANNOTRUN - (for-each (lambda (prereq) - (if (eq? (hash-table-ref/default test-registry prereq 'justfine) 'CANNOTRUN) - (set! give-up #t))) - prereqstrs) + ;; + (if (member testmode '(toplevel)) + (for-each (lambda (prereq) + (if (eq? (hash-table-ref/default test-registry prereq 'justfine) 'CANNOTRUN) + (set! give-up #t))) + prereqstrs)) + (if (and give-up (not (and (null? tal)(null? reg)))) (let ((trimmed-tal (mt:discard-blocked-tests run-id hed tal test-records)) (trimmed-reg (mt:discard-blocked-tests run-id hed reg test-records))) (debug:print 1 "WARNING: test " hed " has discarded prerequisites, removing it from the queue") + + (let ((test-id (rmt:get-test-id run-id hed ""))) + (mt:test-set-state-status-by-id run-id test-id "NOT_STARTED" "PREQ_DISCARDED" "Failed to run due to discarded prerequisites")) + (if (and (null? trimmed-tal) (null? trimmed-reg)) #f (list (runs:queue-next-hed trimmed-tal trimmed-reg reglen regfull) (runs:queue-next-tal trimmed-tal trimmed-reg reglen regfull) (runs:queue-next-reg trimmed-tal trimmed-reg reglen regfull) reruns))) (list (car newtal)(append (cdr newtal) reg) '() reruns)))) - ;; (debug:print-info 1 "allinqueue: " allinqueue) - ;; (debug:print-info 1 "prereqstrs: " prereqstrs) - ;; (debug:print-info 1 "notinqueue: " notinqueue) - ;; (debug:print-info 1 "tal: " tal) - ;; (debug:print-info 1 "newtal: " newtal) - ;; (debug:print-info 1 "reg: " reg) - -;; == == ;; num-retries code was here -;; == == ;; we use this opportunity to move contents of reg to tal -;; == == ;; but also lets check that the prerequisites are all in the newtal or reruns lists -;; == == -;; == == (let* ((allinqueue (map (lambda (x)(if (string? x) x (db:test-get-testname x))) -;; == == (append newtal reruns))) -;; == == ;; prereqstrs is a list of test names as strings that are prereqs for hed -;; == == (prereqstrs (map (lambda (x)(if (string? x) x (db:test-get-testname x))) -;; == == prereqs-not-met)) -;; == == ;; a prereq that is not found in allinqueue will be put in the notinqueue list -;; == == ;; -;; == == (notinqueue (filter (lambda (x) -;; == == (not (member x allinqueue))) -;; == == prereqstrs))) -;; == == (if (not (null? notinqueue)) -;; == == (if (runs:can-keep-running? hed 5) ;; try five times -;; == == (begin -;; == == (debug:print-info 4 "increment cant-run-tests for " hed) -;; == == (runs:inc-cant-run-tests hed) -;; == == (list (car newtal)(append (cdr newtal) reg) '() reruns)) -;; == == (begin -;; == == -;; == == (if (runs:lownoise (conc "no fails prereq, null notinqueue " hed) 30) -;; == == (begin -;; == == (debug:print 1 "WARNING: test " hed " has no failed prerequisites but does have prerequistes that are NOT in the queue: " (string-intersperse notinqueue ", ")) -;; == == (debug:print-info 4 "allinqueue: " allinqueue) -;; == == (debug:print-info 4 "prereqstrs: " prereqstrs) -;; == == (debug:print-info 4 "notinqueue: " notinqueue))) -;; == == (if (and (null? tal)(null? reg)) -;; == == (list (car newtal)(append (cdr newtal) reg) '() reruns) -;; == == (list (runs:queue-next-hed tal reg reglen regfull) -;; == == (runs:queue-next-tal tal reg reglen regfull) -;; == == (runs:queue-next-reg tal reg reglen regfull) -;; == == reruns)))) -;; == == ;; have prereqs in queue, keep going. -;; == == (begin -;; == == (if (runs:lownoise (conc "no fails prereq " hed) 30) -;; == == (debug:print-info 1 "no fails in prerequisites for " hed ", waiting on tests; " -;; == == (string-intersperse (map (lambda (x) -;; == == (if (string? x) -;; == == x -;; == == (runs:make-full-test-name (db:test-get-testname x) -;; == == (db:test-get-item-path x)))) -;; == == non-completed) ", ") -;; == == ". Delaying launch of " hed ".")) -;; == == (list (car newtal)(append (cdr newtal) reg) '() reruns))))) ;; an issue with prereqs not yet met? - ((and (null? fails) + (null? prereq-fails) (null? non-completed)) (if (runs:can-keep-running? hed 5) (begin (runs:inc-cant-run-tests hed) (debug:print-info 1 "no fails in prerequisites for " hed " but also none running, keeping " hed " for now. Try count: " (hash-table-ref/default *seen-cant-run-tests* hed 0)) @@ -542,71 +536,94 @@ ;; num-retries code was here ;; we use this opportunity to move contents of reg to tal (list (car newtal)(append (cdr newtal) reg) '() reruns)) ;; an issue with prereqs not yet met? (begin (debug:print-info 1 "no fails in prerequisites for " hed " but nothing seen running in a while, dropping test " hed " from the run queue") + (let ((test-id (rmt:get-test-id run-id hed ""))) + (mt:test-set-state-status-by-id run-id test-id "NOT_STARTED" "TIMED_OUT" "Nothing seen running in a while.")) (list (runs:queue-next-hed tal reg reglen regfull) (runs:queue-next-tal tal reg reglen regfull) (runs:queue-next-reg tal reg reglen regfull) reruns)))) - ((and (not (null? fails))(eq? testmode 'normal)) + ((and + (or (not (null? fails)) + (not (null? prereq-fails))) + (member 'normal testmode)) (debug:print-info 1 "test " hed " (mode=" testmode ") has failed prerequisite(s); " (string-intersperse (map (lambda (t)(conc (db:test-get-testname t) ":" (db:test-get-state t)"/"(db:test-get-status t))) fails) ", ") ", removing it from to-do list") + (let ((test-id (rmt:get-test-id run-id hed ""))) + (if (not (null? prereq-fails)) + (mt:test-set-state-status-by-id run-id test-id "NOT_STARTED" "PREQ_DISCARDED" "Failed to run due to prior failed prerequisites") + (mt:test-set-state-status-by-id run-id test-id "NOT_STARTED" "PREQ_FAIL" "Failed to run due to failed prerequisites"))) (if (or (not (null? reg))(not (null? tal))) (begin (hash-table-set! test-registry hed 'CANNOTRUN) (list (runs:queue-next-hed tal reg reglen regfull) (runs:queue-next-tal tal reg reglen regfull) (runs:queue-next-reg tal reg reglen regfull) (cons hed reruns))) #f)) ;; #f flags do not loop - ((and (not (null? fails))(eq? testmode 'toplevel)) + ((and (not (null? fails))(member 'toplevel testmode)) (if (or (not (null? reg))(not (null? tal))) (list (car newtal)(append (cdr newtal) reg) '() reruns) #f)) + ((null? runnables) #f) ;; if we get here and non-completed is null the it's all over. (else - (debug:print 1 "WARNING: FAILS or incomplete tests are preventing completion of this run. Dropping test " hed " from the run queue") - (list (runs:queue-next-hed tal reg reglen regfull) - (runs:queue-next-tal tal reg reglen regfull) - (runs:queue-next-reg tal reg reglen regfull) - reruns))))) ;; (list (car newtal)(cdr newtal) reg reruns))))) + (debug:print 0 "WARNING: FAILS or incomplete tests maybe preventing completion of this run. Watch for issues with test " hed ", continuing for now") + ;; (list (runs:queue-next-hed tal reg reglen regfull) + ;; (runs:queue-next-tal tal reg reglen regfull) + ;; (runs:queue-next-reg tal reg reglen regfull) + ;; reruns) + (list (car newtal)(cdr newtal) reg reruns))))) (define (runs:mixed-list-testname-and-testrec->list-of-strings inlst) - (map (lambda (t) - (cond - ((vector? t) - (conc (db:test-get-state t) "/" (db:test-get-status t))) - ((string? t) - t) - (else - (conc t)))) - inlst)) - -(define (runs:process-expanded-tests hed tal reg reruns reglen regfull test-record runname test-name item-path jobgroup max-concurrent-jobs run-id waitons item-path testmode test-patts required-tests test-registry registry-mutex flags keyvals run-info newtal all-tests-registry) - (let* ((run-limits-info (runs:can-run-more-tests jobgroup max-concurrent-jobs)) ;; look at the test jobgroup and tot jobs running + (if (null? inlst) + '() + (map (lambda (t) + (cond + ((vector? t) + (let ((test-name (db:test-get-testname t)) + (item-path (db:test-get-item-path t)) + (test-state (db:test-get-state t)) + (test-status (db:test-get-status t))) + (conc test-name (if (equal? item-path "") "" "/") item-path ":" test-state "/" test-status))) + ((string? t) + t) + (else + (conc t)))) + inlst))) + +(define (runs:process-expanded-tests hed tal reg reruns reglen regfull test-record runname test-name item-path jobgroup max-concurrent-jobs run-id waitons item-path testmode test-patts required-tests test-registry registry-mutex flags keyvals run-info newtal all-tests-registry itemmap) + (let* ((run-limits-info (runs:can-run-more-tests run-id jobgroup max-concurrent-jobs)) ;; look at the test jobgroup and tot jobs running (have-resources (car run-limits-info)) (num-running (list-ref run-limits-info 1)) (num-running-in-jobgroup (list-ref run-limits-info 2)) (max-concurrent-jobs (list-ref run-limits-info 3)) (job-group-limit (list-ref run-limits-info 4)) - (prereqs-not-met (rmt:get-prereqs-not-met run-id waitons item-path mode: testmode)) ;; (mt:lazy-get-prereqs-not-met run-id waitons item-path mode: testmode)) + (prereqs-not-met (rmt:get-prereqs-not-met run-id waitons item-path testmode itemmap: itemmap)) + ;; (prereqs-not-met (mt:lazy-get-prereqs-not-met run-id waitons item-path mode: testmode itemmap: itemmap)) (fails (runs:calc-fails prereqs-not-met)) (non-completed (runs:calc-not-completed prereqs-not-met)) - (loop-list (list hed tal reg reruns))) + (loop-list (list hed tal reg reruns)) + ;; configure the load runner + (numcpus (common:get-num-cpus)) + (maxload (string->number (or (configf:lookup *configdat* "jobtools" "maxload") "3"))) + (waitdelay (string->number (or (configf:lookup *configdat* "jobtools" "waitdelay") "60")))) (debug:print-info 4 "have-resources: " have-resources " prereqs-not-met: (" (string-intersperse (map (lambda (t) (if (vector? t) (conc (db:test-get-state t) "/" (db:test-get-status t)) (conc " WARNING: t is not a vector=" t ))) prereqs-not-met) ", ") ") fails: " fails) - (if (not (null? prereqs-not-met)) - (debug:print-info 1 "waiting on tests; " (string-intersperse (runs:mixed-list-testname-and-testrec->list-of-strings prereqs-not-met) ", "))) + (if (and (not (null? prereqs-not-met)) + (runs:lownoise (conc "waiting on tests " prereqs-not-met hed) 60)) + (debug:print-info 2 "waiting on tests; " (string-intersperse (runs:mixed-list-testname-and-testrec->list-of-strings prereqs-not-met) ", "))) ;; Don't know at this time if the test have been launched at some time in the past ;; i.e. is this a re-launch? (debug:print-info 4 "run-limits-info = " run-limits-info) @@ -629,20 +646,20 @@ ;; ((not (hash-table-ref/default test-registry (runs:make-full-test-name test-name item-path) #f)) (debug:print-info 4 "Pre-registering test " test-name "/" item-path " to create placeholder" ) (if (eq? *transport-type* 'fs) ;; no point in parallel registration if use fs (begin - (rmt:general-call 'register-test run-id test-name item-path) + (rmt:general-call 'register-test run-id run-id test-name item-path) (hash-table-set! test-registry (runs:make-full-test-name test-name item-path) 'done)) (let ((th (make-thread (lambda () (mutex-lock! registry-mutex) (hash-table-set! test-registry (runs:make-full-test-name test-name item-path) 'start) (mutex-unlock! registry-mutex) ;; If haven't done it before register a top level test if this is an itemized test (if (not (eq? (hash-table-ref/default test-registry (runs:make-full-test-name test-name "") #f) 'done)) - (rmt:general-call 'register-test run-id test-name "")) - (rmt:general-call 'register-test run-id test-name item-path) + (rmt:general-call 'register-test run-id run-id test-name "")) + (rmt:general-call 'register-test run-id run-id test-name item-path) (mutex-lock! registry-mutex) (hash-table-set! test-registry (runs:make-full-test-name test-name item-path) 'done) (mutex-unlock! registry-mutex)) (conc test-name "/" item-path)))) (thread-start! th))) @@ -690,10 +707,14 @@ (null? non-completed)))) ;; (hash-table-delete! *max-tries-hash* (runs:make-full-test-name test-name item-path)) ;; we are going to reset all the counters for test retries by setting a new hash table ;; this means they will increment only when nothing can be run (set! *max-tries-hash* (make-hash-table)) + ;; well, first lets see if cpu load throttling is enabled. If so wait around until the + ;; average cpu load is under the threshold before continuing + (if (configf:lookup *configdat* "jobtools" "maxload") ;; only gate if maxload is specified + (common:wait-for-cpuload maxload numcpus waitdelay)) (run:test run-id run-info keyvals runname test-record flags #f test-registry all-tests-registry) (hash-table-set! test-registry (runs:make-full-test-name test-name item-path) 'running) (runs:shrink-can-run-more-tests-count) ;; DELAY TWEAKER (still needed?) ;; (thread-sleep! *global-delta*) (if (or (not (null? tal))(not (null? reg))) @@ -708,40 +729,117 @@ (else (debug:print 4 "FAILS: " fails) ;; If one or more of the prereqs-not-met are FAIL then we can issue ;; a message and drop hed from the items to be processed. ;; (runs:mixed-list-testname-and-testrec->list-of-strings prereqs-not-met) - (if (not (null? prereqs-not-met)) + (if (and (not (null? prereqs-not-met)) + (runs:lownoise (conc "waiting on tests " prereqs-not-met hed) 60)) (debug:print-info 1 "waiting on tests; " (string-intersperse (runs:mixed-list-testname-and-testrec->list-of-strings prereqs-not-met) ", "))) - (if (null? fails) (begin ;; couldn't run, take a breather - (debug:print-info 0 "Waiting for more work to do...") + (if (runs:lownoise "Waiting for more work to do..." 60) + (debug:print-info 0 "Waiting for more work to do...")) (thread-sleep! 1) (list (car newtal)(cdr newtal) reg reruns)) ;; the waiton is FAIL so no point in trying to run hed ever again (if (or (not (null? reg))(not (null? tal))) (if (vector? hed) - (begin - (debug:print 1 "WARN: Dropping test " (db:test-get-testname hed) "/" (db:test-get-item-path hed) + (begin + (debug:print 1 "WARNING: Dropping test " test-name "/" item-path " from the launch list as it has prerequistes that are FAIL") + (let ((test-id (rmt:get-test-id run-id hed ""))) + (mt:test-set-state-status-by-id run-id test-id "NOT_STARTED" "PREQ_FAIL" "Failed to run due to failed prerequisites")) (runs:shrink-can-run-more-tests-count) ;; DELAY TWEAKER (still needed?) ;; (thread-sleep! *global-delta*) + ;; This next is for the items + (mt:test-set-state-status-by-testname run-id test-name item-path "NOT_STARTED" "BLOCKED" #f) (hash-table-set! test-registry (runs:make-full-test-name test-name item-path) 'removed) (list (runs:queue-next-hed tal reg reglen regfull) (runs:queue-next-tal tal reg reglen regfull) (runs:queue-next-reg tal reg reglen regfull) - (cons hed reruns))) - (begin - (debug:print 0 "WARNING: Test not processed correctly. Could be a race condition in your test implementation? Dropping test " hed) ;; " as it has prerequistes that are FAIL. (NOTE: hed is not a vector)") - (runs:shrink-can-run-more-tests-count) ;; DELAY TWEAKER (still needed?) - ;; (list hed tal reg reruns) - (list (car newtal)(cdr newtal) reg reruns) - )))))))) + reruns ;; WAS: (cons hed reruns) ;; but that makes no sense? + )) + (let ((nth-try (hash-table-ref/default test-registry hed 0))) + (cond + ((member "RUNNING" (map db:test-get-state prereqs-not-met)) + (if (runs:lownoise (conc "possible RUNNING prerequistes " hed) 60) + (debug:print 0 "WARNING: test " hed " has possible RUNNING prerequisites, don't give up on it yet.")) + (thread-sleep! 4) + (list (runs:queue-next-hed newtal reg reglen regfull) + (runs:queue-next-tal newtal reg reglen regfull) + (runs:queue-next-reg newtal reg reglen regfull) + reruns)) + ((or (not nth-try) + (and (number? nth-try) + (< nth-try 10))) + (hash-table-set! test-registry hed (if (number? nth-try) + (+ nth-try 1) + 0)) + (if (runs:lownoise (conc "not removing test " hed) 60) + (debug:print 1 "WARNING: not removing test " hed " from queue although it may not be runnable due to FAILED prerequisites")) + ;; may not have processed correctly. Could be a race condition in your test implementation? Dropping test " hed) ;; " as it has prerequistes that are FAIL. (NOTE: hed is not a vector)") + (runs:shrink-can-run-more-tests-count) ;; DELAY TWEAKER (still needed?) + ;; (list hed tal reg reruns) + ;; (list (car newtal)(cdr newtal) reg reruns) + ;; (hash-table-set! test-registry hed 'removed) + (list (runs:queue-next-hed newtal reg reglen regfull) + (runs:queue-next-tal newtal reg reglen regfull) + (runs:queue-next-reg newtal reg reglen regfull) + reruns)) + ((symbol? nth-try) + (if (eq? nth-try 'removed) ;; removed is removed - drop it NOW + (if (null? tal) + #f ;; yes, really + (list (car tal)(cdr tal) reg reruns)) + (begin + (if (runs:lownoise (conc "FAILED prerequisites or other issue" hed) 60) + (debug:print 0 "WARNING: test " hed " has FAILED prerequisites or other issue. Internal state " nth-try " will be overridden and we'll retry.")) + (mt:test-set-state-status-by-testname run-id test-name item-path "NOT_STARTED" "KEEP_TRYING" #f) + (hash-table-set! test-registry hed 0) + (list (runs:queue-next-hed newtal reg reglen regfull) + (runs:queue-next-tal newtal reg reglen regfull) + (runs:queue-next-reg newtal reg reglen regfull) + reruns)))) + (else + (if (runs:lownoise (conc "FAILED prerequitests and we tried" hed) 60) + (debug:print 0 "WARNING: test " hed " has FAILED prerequitests and we've tried at least 10 times to run it. Giving up now.")) + ;; (debug:print 0 " prereqs: " prereqs-not-met) + (hash-table-set! test-registry hed 'removed) + (mt:test-set-state-status-by-testname run-id test-name item-path "NOT_STARTED" "TEN_STRIKES" #f) + (mt:roll-up-pass-fail-counts run-id test-name item-path "FAIL") ;; treat as FAIL + (list (if (null? tal)(car newtal)(car tal)) + tal + reg + reruns))))) + ;; can't drop this - maybe running? Just keep trying + (let ((runable-tests (runs:runable-tests prereqs-not-met))) + (if (null? runable-tests) + #f ;; I think we are truly done here + (list (runs:queue-next-hed newtal reg reglen regfull) + (runs:queue-next-tal newtal reg reglen regfull) + (runs:queue-next-reg newtal reg reglen regfull) + reruns))))))))) + +;; scan a list of tests looking to see if any are potentially runnable +(define (runs:runable-tests tests) + (filter (lambda (t) + (if (not (vector? t)) + t + (let ((state (db:test-get-state t)) + (status (db:test-get-status t))) + (case (string->symbol state) + ((COMPLETED) #f) + ((NOT_STARTED) + (if (member status '("TEN_STRIKES" "BLOCKED" "PREQ_FAIL" "ZERO_ITEMS" "PREQ_DISCARDED" "TIMED_OUT" )) + #f + t)) + ((DELETED) #f) + (else t))))) + tests)) ;; every time though the loop increment the test/itempatt val. ;; when the min is > max-allowed and none running then force exit ;; (define *max-tries-hash* (make-hash-table)) @@ -766,11 +864,11 @@ (max-concurrent-jobs (let ((mcj (config-lookup *configdat* "setup" "max_concurrent_jobs"))) (if (and mcj (string->number mcj)) (string->number mcj) 1))) ;; length of the register queue ahead (reglen (if (number? reglen-in) reglen-in 1)) - (last-time-incomplete (current-seconds)) + (last-time-incomplete (- (current-seconds) 900)) ;; force at least one clean up cycle (last-time-some-running (current-seconds))) ;; Initialize the test-registery hash with tests that already have a record ;; convert state to symbol and use that as the hash value (for-each (lambda (trec) @@ -785,25 +883,27 @@ (let loop ((hed (car sorted-test-names)) (tal (cdr sorted-test-names)) (reg '()) ;; registered, put these at the head of tal (reruns '())) + (if (not (null? reruns))(debug:print-info 4 "reruns=" reruns)) ;; Here we mark any old defunct tests as incomplete. Do this every fifteen minutes - ;; (if (> (current-seconds)(+ last-time-incomplete 900)) - ;; (begin - ;; (set! last-time-incomplete (current-seconds)) - ;; (cdb:remote-run db:find-and-mark-incomplete #f))) + (if (> (current-seconds)(+ last-time-incomplete 900)) + (begin + (set! last-time-incomplete (current-seconds)) + (rmt:find-and-mark-incomplete-all-runs))) ;; (print "Top of loop, hed=" hed ", tal=" tal " ,reruns=" reruns) (let* ((test-record (hash-table-ref test-records hed)) (test-name (tests:testqueue-get-testname test-record)) (tconfig (tests:testqueue-get-testconfig test-record)) - (jobgroup (config-lookup tconfig "requirements" "jobgroup")) + (jobgroup (config-lookup tconfig "test_meta" "jobgroup")) (testmode (let ((m (config-lookup tconfig "requirements" "mode"))) - (if m (string->symbol m) 'normal))) + (if m (map string->symbol (string-split m)) '(normal)))) + (itemmap (configf:lookup tconfig "requirements" "itemmap")) (waitons (tests:testqueue-get-waitons test-record)) (priority (tests:testqueue-get-priority test-record)) (itemdat (tests:testqueue-get-itemdat test-record)) ;; itemdat can be a string, list or #f (items (tests:testqueue-get-items test-record)) (item-path (item-list->path itemdat)) @@ -813,27 +913,28 @@ (num-running (rmt:get-count-tests-running-for-run-id run-id))) (if (> num-running 0) (set! last-time-some-running (current-seconds))) - (if (> (current-seconds)(+ last-time-some-running 60)) + (if (> (current-seconds)(+ last-time-some-running 240)) (hash-table-set! *max-tries-hash* tfullname (+ (hash-table-ref/default *max-tries-hash* tfullname 0) 1))) ;; (debug:print 0 "max-tries-hash: " (hash-table->alist *max-tries-hash*)) ;; Ensure all top level tests get registered. This way they show up as "NOT_STARTED" on the dashboard ;; and it is clear they *should* have run but did not. (if (not (hash-table-ref/default test-registry (runs:make-full-test-name test-name "") #f)) (begin - (rmt:general-call 'register-test run-id test-name "") + (rmt:general-call 'register-test run-id run-id test-name "") (hash-table-set! test-registry (runs:make-full-test-name test-name "") 'done))) ;; Fast skip of tests that are already "COMPLETED" - NO! Cannot do that as the items may not have been expanded yet :( ;; (if (member (hash-table-ref/default test-registry tfullname #f) '(DONOTRUN removed)) ;; *common:cant-run-states-sym*) ;; '(COMPLETED KILLED WAIVED UNKNOWN INCOMPLETE)) (begin - (debug:print-info 0 "Skipping test " tfullname " as it has been marked do not run due to being completed or not runnable") + (if (runs:lownoise (conc "been marked do not run " tfullname) 60) + (debug:print-info 0 "Skipping test " tfullname " as it has been marked do not run due to being completed or not runnable")) (if (or (not (null? tal))(not (null? reg))) (loop (runs:queue-next-hed tal reg reglen regfull) (runs:queue-next-tal tal reg reglen regfull) (runs:queue-next-reg tal reg reglen regfull) reruns)))) @@ -885,11 +986,11 @@ ((not items) (debug:print-info 4 "OUTER COND: (not items)") (if (and (not (tests:match test-patts (tests:testqueue-get-testname test-record) item-path required: required-tests)) (not (null? tal))) (loop (car tal)(cdr tal) reg reruns)) - (let ((loop-list (runs:process-expanded-tests hed tal reg reruns reglen regfull test-record runname test-name item-path jobgroup max-concurrent-jobs run-id waitons item-path testmode test-patts required-tests test-registry registry-mutex flags keyvals run-info newtal all-tests-registry))) + (let ((loop-list (runs:process-expanded-tests hed tal reg reruns reglen regfull test-record runname test-name item-path jobgroup max-concurrent-jobs run-id waitons item-path testmode test-patts required-tests test-registry registry-mutex flags keyvals run-info newtal all-tests-registry itemmap))) (if loop-list (apply loop loop-list)))) ;; items processed into a list but not came in as a list been processed ;; ((and (list? items) ;; thus we know our items are already calculated @@ -937,14 +1038,14 @@ ;; if items is a proc then need to run items:get-items-from-config, get the list and loop ;; - but only do that if resources exist to kick off the job ;; EXPAND ITEMS ((or (procedure? items)(eq? items 'have-procedure)) - (let ((can-run-more (runs:can-run-more-tests jobgroup max-concurrent-jobs))) + (let ((can-run-more (runs:can-run-more-tests run-id jobgroup max-concurrent-jobs))) (if (and (list? can-run-more) (car can-run-more)) - (let ((loop-list (runs:expand-items hed tal reg reruns regfull newtal jobgroup max-concurrent-jobs run-id waitons item-path testmode test-record can-run-more items runname tconfig reglen test-registry test-records))) + (let ((loop-list (runs:expand-items hed tal reg reruns regfull newtal jobgroup max-concurrent-jobs run-id waitons item-path testmode test-record can-run-more items runname tconfig reglen test-registry test-records itemmap))) (if loop-list (apply loop loop-list))) ;; if can't run more just loop with next possible test (loop (car newtal)(cdr newtal) reg reruns)))) @@ -968,12 +1069,33 @@ ((not (null? reg)) ;; could we get here with leftovers? (debug:print-info 0 "Have leftovers!") (loop (car reg)(cdr reg) '() reruns)) (else (debug:print-info 4 "Exiting loop with...\n hed=" hed "\n tal=" tal "\n reruns=" reruns)) - ))) ;; LET* ((test-record - + ))) + ;; now *if* -run-wait we wait for all tests to be done + ;; Now wait for any RUNNING tests to complete (if in run-wait mode) + (let wait-loop ((num-running (rmt:get-count-tests-running-for-run-id run-id)) + (prev-num-running 0)) + ;; (debug:print 0 "num-running=" num-running ", prev-num-running=" prev-num-running) + (if (and (or (args:get-arg "-run-wait") + (equal? (configf:lookup *configdat* "setup" "run-wait") "yes")) + (> num-running 0)) + (begin + ;; Here we mark any old defunct tests as incomplete. Do this every fifteen minutes + ;; (debug:print 0 "Got here eh! num-running=" num-running " (> num-running 0) " (> num-running 0)) + (if (> (current-seconds)(+ last-time-incomplete 900)) + (begin + (debug:print-info 0 "Marking stuck tests as INCOMPLETE while waiting for run " run-id ". Running as pid " (current-process-id) " on " (get-host-name)) + (set! last-time-incomplete (current-seconds)) + (rmt:find-and-mark-incomplete run-id #f))) + (if (not (eq? num-running prev-num-running)) + (debug:print-info 0 "run-wait specified, waiting on " num-running " tests in RUNNING, REMOTEHOSTSTART or LAUNCHED state at " (time->string (seconds->local-time (current-seconds))))) + (thread-sleep! 15) + ;; (wait-loop (rmt:get-count-tests-running-for-run-id run-id) num-running)))) + (wait-loop (rmt:get-count-tests-running-for-run-id run-id) num-running)))) + ;; LET* ((test-record ;; we get here on "drop through". All done! (debug:print-info 1 "All tests launched"))) (define (runs:calc-fails prereqs-not-met) (filter (lambda (test) @@ -980,17 +1102,41 @@ (and (vector? test) ;; not (string? test)) (equal? (db:test-get-state test) "COMPLETED") (not (member (db:test-get-status test) '("PASS" "WARN" "CHECK" "WAIVED" "SKIP"))))) prereqs-not-met)) + +(define (runs:calc-prereq-fail prereqs-not-met) + (filter (lambda (test) + (and (vector? test) ;; not (string? test)) + (equal? (db:test-get-state test) "NOT_STARTED") + (not (member (db:test-get-status test) + '("n/a" "KEEP_TRYING"))))) + prereqs-not-met)) + +(define (runs:calc-not-completed prereqs-not-met) + (filter + (lambda (t) + (or (not (vector? t)) + (not (equal? "COMPLETED" (db:test-get-state t))))) + prereqs-not-met)) (define (runs:calc-not-completed prereqs-not-met) (filter (lambda (t) (or (not (vector? t)) (not (equal? "COMPLETED" (db:test-get-state t))))) prereqs-not-met)) + +(define (runs:calc-runnable prereqs-not-met) + (filter + (lambda (t) + (or (not (vector? t)) + (and (equal? "NOT_STARTED" (db:test-get-state t)) + (member (db:test-get-status t) + '("n/a" "KEEP_TRYING"))))) + prereqs-not-met)) (define (runs:pretty-string lst) (map (lambda (t) (if (not (vector? t)) (conc t) @@ -1009,10 +1155,11 @@ (itemdat (tests:testqueue-get-itemdat test-record)) (test-path (hash-table-ref all-tests-registry test-name)) ;; (conc *toppath* "/tests/" test-name)) ;; could use tests:get-testconfig here ... (force (hash-table-ref/default flags "-force" #f)) (rerun (hash-table-ref/default flags "-rerun" #f)) (keepgoing (hash-table-ref/default flags "-keepgoing" #f)) + (incomplete-timeout (string->number (or (configf:lookup *configdat* "setup" "incomplete-timeout") "x"))) (item-path "") (db #f) (full-test-name #f)) ;; setting itemdat to a list if it is #f @@ -1026,11 +1173,11 @@ ) (debug:print 2 "Attempting to launch test " full-test-name) (setenv "MT_TEST_NAME" test-name) ;; (setenv "MT_ITEMPATH" item-path) (setenv "MT_RUNNAME" runname) - (set-megatest-env-vars run-id inrunname: runname) ;; these may be needed by the launching process + (runs:set-megatest-env-vars run-id inrunname: runname) ;; these may be needed by the launching process (change-directory *toppath*) ;; Here is where the test_meta table is best updated ;; Yes, another use of a global for caching. Need a better way? ;; @@ -1044,11 +1191,11 @@ (runs:update-test_meta test-name test-conf))) ;; itemdat => ((ripeness "overripe") (temperature "cool") (season "summer")) (let* ((new-test-path (string-intersperse (cons test-path (map cadr itemdat)) "/")) (test-id (rmt:get-test-id run-id test-name item-path)) - (testdat (if test-id (rmt:get-test-info-by-id test-id) #f))) + (testdat (if test-id (rmt:get-test-info-by-id run-id test-id) #f))) (if (not testdat) (let loop () ;; ensure that the path exists before registering the test ;; NOPE: Cannot! Don't know yet which disk area will be assigned.... ;; (system (conc "mkdir -p " new-test-path)) @@ -1055,18 +1202,18 @@ ;; ;; (open-run-close tests:register-test db run-id test-name item-path) ;; ;; NB// for the above line. I want the test to be registered long before this routine gets called! ;; - (if (not test-id)(set! test-id (rmt:get-test-id-cached run-id test-name item-path))) + (if (not test-id)(set! test-id (rmt:get-test-id run-id test-name item-path))) (if (not test-id) (begin (debug:print 2 "WARN: Test not pre-created? test-name=" test-name ", item-path=" item-path ", run-id=" run-id) - (rmt:general-call 'register-test run-id test-name item-path) + (rmt:general-call 'register-test run-id run-id test-name item-path) (set! test-id (rmt:get-test-id run-id test-name item-path)))) (debug:print-info 4 "test-id=" test-id ", run-id=" run-id ", test-name=" test-name ", item-path=\"" item-path "\"") - (set! testdat (rmt:get-test-info-by-id test-id)) + (set! testdat (rmt:get-test-info-by-id run-id test-id)) (if (not testdat) (begin (debug:print-info 0 "WARNING: server is overloaded, trying again in one second") (thread-sleep! 1) (loop))))) @@ -1118,13 +1265,14 @@ (set! runflag #t)) (else (set! runflag #f))) (debug:print 4 "RUNNING => runflag: " runflag " STATE: " (test:get-state testdat) " STATUS: " (test:get-status testdat)) (if (not runflag) (if (not parent-test) - (debug:print 1 "NOTE: Not starting test " full-test-name " as it is state \"" (test:get-state testdat) - "\" and status \"" (test:get-status testdat) "\", use -rerun \"" (test:get-status testdat) - "\" or -force to override")) + (if (runs:lownoise (conc "not starting test" full-test-name) 60) + (debug:print 1 "NOTE: Not starting test " full-test-name " as it is state \"" (test:get-state testdat) + "\" and status \"" (test:get-status testdat) "\", use -rerun \"" (test:get-status testdat) + "\" or -force to override"))) ;; NOTE: No longer be checking prerequisites here! Will never get here unless prereqs are ;; already met. ;; This would be a great place to do the process-fork ;; (let ((skip-test #f) @@ -1132,20 +1280,21 @@ (cond ;; Have to check for skip conditions. This one skips if there are same-named tests ;; currently running ((and skip-check (configf:lookup test-conf "skip" "prevrunning")) + ;; run-ids = #f means *all* runs (let ((running-tests (rmt:get-tests-for-runs-mindata #f full-test-name '("RUNNING" "REMOTEHOSTSTART" "LAUNCHED") '() #f))) (if (not (null? running-tests)) ;; have to skip (set! skip-test "Skipping due to previous tests running")))) ((and skip-check (configf:lookup test-conf "skip" "fileexists")) (if (file-exists? (configf:lookup test-conf "skip" "fileexists")) (set! skip-test (conc "Skipping due to existance of file " (configf:lookup test-conf "skip" "fileexists")))))) (if skip-test (begin - (mt:test-set-state-status-by-id test-id "COMPLETED" "SKIP" skip-test) + (mt:test-set-state-status-by-id run-id test-id "COMPLETED" "SKIP" skip-test) (debug:print-info 1 "SKIPPING Test " full-test-name " due to " skip-test)) (if (not (launch-test test-id run-id run-info keyvals runname test-conf test-name test-path itemdat flags)) (begin (print "ERROR: Failed to launch the test. Exiting as soon as possible") (set! *globalexitstatus* 1) ;; @@ -1152,17 +1301,20 @@ (process-signal (current-process-id) signal/kill)))))))) ((KILLED) (debug:print 1 "NOTE: " full-test-name " is already running or was explictly killed, use -force to launch it.") (hash-table-set! test-registry (runs:make-full-test-name test-name test-path) 'DONOTRUN)) ;; KILLED)) ((LAUNCHED REMOTEHOSTSTART RUNNING) - (if (> (- (current-seconds)(+ (db:test-get-event_time testdat) - (db:test-get-run_duration testdat))) - 600) ;; i.e. no update for more than 600 seconds - (begin - (debug:print 0 "WARNING: Test " test-name " appears to be dead. Forcing it to state INCOMPLETE and status STUCK/DEAD") - (tests:test-set-status! test-id "INCOMPLETE" "STUCK/DEAD" "Test is stuck or dead" #f)) - (debug:print 2 "NOTE: " test-name " is already running"))) + (debug:print 2 "NOTE: " test-name " is already running")) + ;; (if (> (- (current-seconds)(+ (db:test-get-event_time testdat) + ;; (db:test-get-run_duration testdat))) + ;; (or incomplete-timeout + ;; 6000)) ;; i.e. no update for more than 6000 seconds + ;; (begin + ;; (debug:print 0 "WARNING: Test " test-name " appears to be dead. Forcing it to state INCOMPLETE and status STUCK/DEAD") + ;; (tests:test-set-status! run-id test-id "INCOMPLETE" "STUCK/DEAD" "" #f)) + ;; ;; (tests:test-set-status! test-id "INCOMPLETE" "STUCK/DEAD" "" #f)) + ;; (debug:print 2 "NOTE: " test-name " is already running"))) (else (debug:print 0 "ERROR: Failed to launch test " full-test-name ". Unrecognised state " (test:get-state testdat)) (case (string->symbol (test:get-state testdat)) ((COMPLETED INCOMPLETE) (hash-table-set! test-registry (runs:make-full-test-name test-name test-path) 'DONOTRUN)) @@ -1180,11 +1332,15 @@ (take dparts (- (length dparts) count)) "/")))) (define (runs:recursive-delete-with-error-msg real-dir) (if (> (system (conc "rm -rf " real-dir)) 0) - (debug:print 0 "ERROR: There was a problem removing " real-dir " with rm -f"))) + (begin + ;; FAILED, possibly due to permissions, do chmod a+rwx then try one more time + (system (conc "chmod -R a+rwx " real-dir)) + (if (> (system (conc "rm -rf " real-dir)) 0) + (debug:print 0 "ERROR: There was a problem removing " real-dir " with rm -f"))))) (define (runs:safe-delete-test-dir real-dir) ;; first delete all sub-directories (directory-fold (lambda (f x) @@ -1209,13 +1365,14 @@ ;; 'remove-runs ;; 'set-state-status ;; ;; NB// should pass in keys? ;; -(define (runs:operate-on action target runnamepatt testpatt #!key (state #f)(status #f)(new-state-status #f)) +(define (runs:operate-on action target runnamepatt testpatt #!key (state #f)(status #f)(new-state-status #f)(remove-data-only #f)) (common:clear-caches) ;; clear all caches (let* ((db #f) + (tasks-db (tasks:open-db)) (keys (rmt:get-keys)) (rundat (mt:get-runs-by-patt keys runnamepatt target)) (header (vector-ref rundat 0)) (runs (vector-ref rundat 1)) (states (if state (string-split state ",") '())) @@ -1238,19 +1395,24 @@ sort-by: (case action ((remove-runs) 'rundir) (else 'event_time)))))) (let* ((run-id (db:get-value-by-header run header "id")) (run-state (db:get-value-by-header run header "state")) + (run-name (db:get-value-by-header run header "runname")) (tests (if (not (equal? run-state "locked")) (proc-get-tests run-id) '())) (lasttpath "/does/not/exist/I/hope")) (debug:print-info 4 "runs:operate-on run=" run ", header=" header) (if (not (null? tests)) (begin (case action ((remove-runs) + ;; seek and kill in flight -runtests with % as testpatt here + (if (equal? testpatt "%") + (tasks:kill-runner tasks-db target run-name) + (debug:print 0 "not attempting to kill any run launcher processes as testpatt is " testpatt)) (debug:print 1 "Removing tests for run: " runkey " " (db:get-value-by-header run header "runname"))) ((set-state-status) (debug:print 1 "Modifying state and staus for tests for run: " runkey " " (db:get-value-by-header run header "runname"))) ((print-run) (debug:print 1 "Printing info for run " runkey ", run=" run ", tests=" tests ", header=" header) @@ -1257,97 +1419,81 @@ action) ((run-wait) (debug:print 1 "Waiting for run " runkey ", run=" runnamepatt " to complete")) (else (debug:print-info 0 "action not recognised " action))) - (let ((sorted-tests (sort tests (lambda (a b)(let ((dira (db:test-get-rundir a)) - (dirb (db:test-get-rundir b))) + (let ((sorted-tests (sort tests (lambda (a b)(let ((dira ;; (rmt:sdb-qry 'getstr + (db:test-get-rundir a)) ;; ) ;; (filedb:get-path *fdb* (db:test-get-rundir a))) + (dirb ;; (rmt:sdb-qry 'getstr + (db:test-get-rundir b))) ;; ) ;; ((filedb:get-path *fdb* (db:test-get-rundir b)))) (if (and (string? dira)(string? dirb)) (> (string-length dira)(string-length dirb)) #f))))) + (toplevel-retries (make-hash-table)) ;; try three times to loop through and remove top level tests (test-retry-time (make-hash-table)) (allow-run-time 10)) ;; seconds to allow for killing tests before just brutally killing 'em (let loop ((test (car sorted-tests)) (tal (cdr sorted-tests))) (let* ((test-id (db:test-get-id test)) - (new-test-dat (rmt:get-test-info-by-id test-id))) + (new-test-dat (rmt:get-test-info-by-id run-id test-id))) (if (not new-test-dat) (begin (debug:print 0 "ERROR: We have a test-id of " test-id " but no record was found. NOTE: No locking of records is done between processes, do not simultaneously remove the same run from two processes!") (if (not (null? tal)) (loop (car tal)(cdr tal)))) (let* ((item-path (db:test-get-item-path new-test-dat)) (test-name (db:test-get-testname new-test-dat)) - (run-dir (db:test-get-rundir new-test-dat)) ;; run dir is from the link tree - (real-dir (if (file-exists? run-dir) - (resolve-pathname run-dir) - #f)) + (run-dir ;;(filedb:get-path *fdb* + ;; (rmt:sdb-qry 'getid + (db:test-get-rundir new-test-dat)) ;; ) ;; run dir is from the link tree (test-state (db:test-get-state new-test-dat)) - (test-fulln (db:test-get-fullname new-test-dat))) + (test-fulln (db:test-get-fullname new-test-dat)) + (uname (db:test-get-uname new-test-dat)) + (toplevel-with-children (and (db:test-get-is-toplevel test) + (> (rmt:test-toplevel-num-items run-id test-name) 0)))) (case action ((remove-runs) - (debug:print-info 0 "test: " test-name " itest-state: " test-state) - (if (member test-state (list "RUNNING" "LAUNCHED" "REMOTEHOSTSTART" "KILLREQ")) - (begin - (if (not (hash-table-ref/default test-retry-time test-fulln #f)) - (begin - ;; want to set to REMOVING BUT CANNOT do it here? - (hash-table-set! test-retry-time test-fulln (current-seconds)))) - (if (> (- (current-seconds)(hash-table-ref test-retry-time test-fulln)) allow-run-time) - ;; This test is not in a correct state for cleaning up. Let's try some graceful shutdown steps first - ;; Set the test to "KILLREQ" and wait five seconds then try again. Repeat up to five times then give - ;; up and blow it away. - (begin - (debug:print 0 "WARNING: could not gracefully remove test " test-fulln ", tried to kill it to no avail. Forcing state to FAILEDKILL and continuing") - (mt:test-set-state-status-by-id (db:test-get-id test) "FAILEDKILL" "n/a" #f) - (thread-sleep! 1)) - (begin - (mt:test-set-state-status-by-id (db:test-get-id test) "KILLREQ" "n/a" #f) - (thread-sleep! 1))) - ;; NOTE: This is suboptimal as the testdata will be used later and the state/status may have changed ... - (if (null? tal) - (loop new-test-dat tal) - (loop (car tal)(append tal (list new-test-dat))))) - (begin - (mt:test-set-state-status-by-id (db:test-get-id test) "REMOVING" "LOCKED" #f) - (debug:print-info 1 "Attempting to remove " (if real-dir (conc " dir " real-dir " and ") "") " link " run-dir) - (if (and real-dir - (> (string-length real-dir) 5) - (file-exists? real-dir)) ;; bad heuristic but should prevent /tmp /home etc. - (begin ;; let* ((realpath (resolve-pathname run-dir))) - (debug:print-info 1 "Recursively removing " real-dir) - (if (file-exists? real-dir) - (runs:safe-delete-test-dir real-dir) - (debug:print 0 "WARNING: test dir " real-dir " appears to not exist or is not readable"))) - (if real-dir - (debug:print 0 "WARNING: directory " real-dir " does not exist") - (debug:print 0 "WARNING: no real directory corrosponding to link " run-dir ", nothing done"))) - (if (symbolic-link? run-dir) - (begin - (debug:print-info 1 "Removing symlink " run-dir) - (handle-exceptions - exn - (debug:print 0 "ERROR: Failed to remove symlink " run-dir ((condition-property-accessor 'exn 'message) exn) ", attempting to continue") - (delete-file run-dir))) - (if (directory? run-dir) - (if (> (directory-fold (lambda (f x)(+ 1 x)) 0 run-dir) 0) - (debug:print 0 "WARNING: refusing to remove " run-dir " as it is not empty") - (handle-exceptions - exn - (debug:print 0 "ERROR: Failed to remove directory " run-dir ((condition-property-accessor 'exn 'message) exn) ", attempting to continue") - (delete-directory run-dir))) - (if run-dir - (debug:print 0 "WARNING: not removing " run-dir " as it either doesn't exist or is not a symlink") - (debug:print 0 "NOTE: the run dir for this test is undefined. Test may have already been deleted.")) - )) - ;; Only delete the records *after* removing the directory. If things fail we have a record - (rmt:delete-test-records (db:test-get-id test)) - (if (not (null? tal)) - (loop (car tal)(cdr tal)))))) + ;; if the test is a toplevel-with-children issue an error and do not remove + (if toplevel-with-children + (begin + (debug:print 0 "WARNING: skipping removal of " test-fulln " with run-id " run-id " as it has sub tests") + (hash-table-set! toplevel-retries test-fulln (+ (hash-table-ref/default toplevel-retries test-fulln 0) 1)) + (if (> (hash-table-ref toplevel-retries test-fulln) 3) + (if (not (null? tal)) + (loop (car tal)(cdr tal))) ;; no else clause - drop it if no more in queue and > 3 tries + (let ((newtal (append tal (list test)))) + (loop (car newtal)(cdr newtal))))) ;; loop with test still in queue + (begin + (debug:print-info 0 "test: " test-name " itest-state: " test-state) + (if (member test-state (list "RUNNING" "LAUNCHED" "REMOTEHOSTSTART" "KILLREQ")) + (begin + (if (not (hash-table-ref/default test-retry-time test-fulln #f)) + (begin + ;; want to set to REMOVING BUT CANNOT do it here? + (hash-table-set! test-retry-time test-fulln (current-seconds)))) + (if (> (- (current-seconds)(hash-table-ref test-retry-time test-fulln)) allow-run-time) + ;; This test is not in a correct state for cleaning up. Let's try some graceful shutdown steps first + ;; Set the test to "KILLREQ" and wait five seconds then try again. Repeat up to five times then give + ;; up and blow it away. + (begin + (debug:print 0 "WARNING: could not gracefully remove test " test-fulln ", tried to kill it to no avail. Forcing state to FAILEDKILL and continuing") + (mt:test-set-state-status-by-id run-id (db:test-get-id test) "FAILEDKILL" "n/a" #f) + (thread-sleep! 1)) + (begin + (mt:test-set-state-status-by-id run-id (db:test-get-id test) "KILLREQ" "n/a" #f) + (thread-sleep! 1))) + ;; NOTE: This is suboptimal as the testdata will be used later and the state/status may have changed ... + (if (null? tal) + (loop new-test-dat tal) + (loop (car tal)(append tal (list new-test-dat))))) + (begin + (runs:remove-test-directory db new-test-dat remove-data-only) + (if (not (null? tal)) + (loop (car tal)(cdr tal)))))))) ((set-state-status) (debug:print-info 2 "new state " (car state-status) ", new status " (cadr state-status)) - (mt:test-set-state-status-by-id (db:test-get-id test) (car state-status)(cadr state-status) #f) + (mt:test-set-state-status-by-id run-id (db:test-get-id test) (car state-status)(cadr state-status) #f) (if (not (null? tal)) (loop (car tal)(cdr tal)))) ((run-wait) (debug:print-info 2 "still waiting, " (length tests) " tests still running") (thread-sleep! 10) @@ -1373,38 +1519,78 @@ ;; (begin ;; (debug:print 1 "Removing run dir " runpath) ;; (system (conc "rmdir -p " runpath)))) ))))) )) - runs)) + runs) + (sqlite3:finalize! tasks-db)) #t) +(define (runs:remove-test-directory db test remove-data-only) + (let* ((run-dir (db:test-get-rundir test)) ;; run dir is from the link tree + (real-dir (if (file-exists? run-dir) + (resolve-pathname run-dir) + #f))) + (if remove-data-only + (mt:test-set-state-status-by-id (db:test-get-run_id test)(db:test-get-id test) "CLEANING" "LOCKED" #f) + (mt:test-set-state-status-by-id (db:test-get-run_id test)(db:test-get-id test) "REMOVING" "LOCKED" #f)) + (debug:print-info 1 "Attempting to remove " (if real-dir (conc " dir " real-dir " and ") "") " link " run-dir) + (if (and real-dir + (> (string-length real-dir) 5) + (file-exists? real-dir)) ;; bad heuristic but should prevent /tmp /home etc. + (begin ;; let* ((realpath (resolve-pathname run-dir))) + (debug:print-info 1 "Recursively removing " real-dir) + (if (file-exists? real-dir) + (runs:safe-delete-test-dir real-dir) + (debug:print 0 "WARNING: test dir " real-dir " appears to not exist or is not readable"))) + (if real-dir + (debug:print 0 "WARNING: directory " real-dir " does not exist") + (debug:print 0 "WARNING: no real directory corrosponding to link " run-dir ", nothing done"))) + (if (symbolic-link? run-dir) + (begin + (debug:print-info 1 "Removing symlink " run-dir) + (handle-exceptions + exn + (debug:print 0 "ERROR: Failed to remove symlink " run-dir ((condition-property-accessor 'exn 'message) exn) ", attempting to continue") + (delete-file run-dir))) + (if (directory? run-dir) + (if (> (directory-fold (lambda (f x)(+ 1 x)) 0 run-dir) 0) + (debug:print 0 "WARNING: refusing to remove " run-dir " as it is not empty") + (handle-exceptions + exn + (debug:print 0 "ERROR: Failed to remove directory " run-dir ((condition-property-accessor 'exn 'message) exn) ", attempting to continue") + (delete-directory run-dir))) + (if (and run-dir + (not (member run-dir (list "n/a" "/tmp/badname")))) + (debug:print 0 "WARNING: not removing " run-dir " as it either doesn't exist or is not a symlink") + (debug:print 0 "NOTE: the run dir for this test is undefined. Test may have already been deleted.")) + )) + ;; Only delete the records *after* removing the directory. If things fail we have a record + (if remove-data-only + (mt:test-set-state-status-by-id (db:test-get-run_id test)(db:test-get-id test) "NOT_STARTED" "n/a" #f) + (rmt:delete-test-records (db:test-get-run_id test) (db:test-get-id test))))) + ;;====================================================================== ;; Routines for manipulating runs ;;====================================================================== ;; Since many calls to a run require pretty much the same setup ;; this wrapper is used to reduce the replication of code (define (general-run-call switchname action-desc proc) - (let ((runname (args:get-arg ":runname")) - (target (if (args:get-arg "-target") - (args:get-arg "-target") - (args:get-arg "-reqtarg")))) - ;; (th1 #f)) + (let ((runname (or (args:get-arg "-runname")(args:get-arg ":runname"))) + (target (common:args-get-target))) (cond ((not target) (debug:print 0 "ERROR: Missing required parameter for " switchname ", you must specify the target with -target") (exit 3)) ((not runname) - (debug:print 0 "ERROR: Missing required parameter for " switchname ", you must specify the run name with :runname runname") + (debug:print 0 "ERROR: Missing required parameter for " switchname ", you must specify the run name with -runname runname") (exit 3)) (else (let ((db #f) - (keys #f) - (target (or (args:get-arg "-reqtarg") - (args:get-arg "-target")))) - (if (not (setup-for-run)) + (keys #f)) + (if (not (launch:setup-for-run)) (begin (debug:print 0 "Failed to setup, exiting") (exit 1))) ;; (if (args:get-arg "-server") ;; (cdb:remote-run server:start db (args:get-arg "-server"))) @@ -1459,11 +1645,11 @@ ;; Update the test_meta table for this test (define (runs:update-test_meta test-name test-conf) (let ((currrecord (rmt:testmeta-get-record test-name))) (if (not currrecord) (begin - (set! currrecord (make-vector 10 #f)) + (set! currrecord (make-vector 11 #f)) (rmt:testmeta-add-record test-name))) (for-each (lambda (key) (let* ((idx (cadr key)) (fld (car key)) @@ -1471,11 +1657,11 @@ ;; (debug:print 5 "idx: " idx " fld: " fld " val: " val) (if (and val (not (equal? (vector-ref currrecord idx) val))) (begin (print "Updating " test-name " " fld " to " val) (rmt:testmeta-update-field test-name fld val))))) - '(("author" 2)("owner" 3)("description" 4)("reviewed" 5)("tags" 9))))) + '(("author" 2)("owner" 3)("description" 4)("reviewed" 5)("tags" 9)("jobgroup" 10))))) ;; Update test_meta for all tests (define (runs:update-all-test_meta db) (let ((test-names (tests:get-all))) ;; (tests:get-valid-tests))) (for-each @@ -1486,12 +1672,13 @@ ;; This could probably be refactored into one complex query ... ;; NOT PORTED - DO NOT USE YET ;; (define (runs:rollup-run keys runname user keyvals) - (debug:print 4 "runs:rollup-run, keys: " keys " :runname " runname " user: " user) + (debug:print 4 "runs:rollup-run, keys: " keys " -runname " runname " user: " user) (let* ((db #f) + ;; register run operates on the main db (new-run-id (rmt:register-run keyvals runname "new" "n/a" user)) (prev-tests (rmt:get-matching-previous-test-run-records new-run-id "%" "%")) (curr-tests (mt:get-tests-for-run new-run-id "%/%" '() '())) (curr-tests-hash (make-hash-table))) (rmt:update-run-event_time new-run-id) Index: sdb.scm ================================================================== --- sdb.scm +++ sdb.scm @@ -20,27 +20,20 @@ (import (prefix base64 base64:)) (declare (unit sdb)) ;; -(define (sdb:open) ;; (conc *toppath* "/megatest.db") (car *configinfo*))) - (if (not *toppath*) - (if (not (setup-for-run)) - (begin - (debug:print 0 "ERROR: Attempted to open db when not in megatest area. Exiting.") - (exit)))) - (let* ((dbpath (conc *toppath* "/db/sdb.db")) ;; fname) - (dbexists (let ((fe (file-exists? dbpath))) +(define (sdb:open fname) + (let* ((dbpath (pathname-directory fname)) + (dbexists (let ((fe (file-exists? fname))) (if fe fe (begin - (create-directory (conc *toppath* "/db") #t) + (create-directory dbpath #t) #f)))) - (sdb (sqlite3:open-database dbpath)) - (handler (make-busy-timeout (if (args:get-arg "-override-timeout") - (string->number (args:get-arg "-override-timeout")) - 136000)))) + (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)) @@ -48,11 +41,11 @@ (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 strindx ON strs (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)) @@ -77,26 +70,38 @@ (hash-table-set! id-cache id str)) sdb "SELECT str FROM strs WHERE id=?;" id)) str)) -(define sdb:qry +;; 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) - (if (not sdb)(set! sdb (sdb:open))) (case cmd - ((init) (if (not sdb)(set! sdb (sdb:open)))) - ((finalize!) (if sdb (sqlite3:finalize! sdb))) - ((getid) (let ((id (sdb:string->id sdb scache var))) + ((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 @@ -8,11 +8,11 @@ ;; implied warranty of MERCHANTABILITY or FITNESS FOR A PARTICULAR ;; PURPOSE. (require-extension (srfi 18) extras tcp s11n) -(use srfi-1 posix regex regex-case srfi-69 hostinfo md5 message-digest) +(use srfi-1 posix regex regex-case srfi-69 hostinfo md5 message-digest directory-utils) ;; (use zmq) (use spiffy uri-common intarweb http-client spiffy-request-vars) (declare (unit server)) @@ -20,10 +20,11 @@ (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 launch)) ;; (declare (uses zmq-transport)) (declare (uses daemon)) (include "common_records.scm") (include "db_records.scm") @@ -42,54 +43,23 @@ ;; Call this to start the actual server ;; ;; all routes though here end in exit ... -(define (server:launch transport) - (if (not *toppath*) - (if (not (setup-for-run)) - (begin - (debug:print 0 "ERROR: cannot find megatest.config, exiting") - (exit)))) - (debug:print-info 2 "Starting server using " transport " transport") - (set! *transport-type* transport) - (case transport - ((fs) (exit)) ;; there is no "fs" server transport - ((http) (http-transport:launch)) - ((zmq) (zmq-transport:launch)) - (else - (debug:print "WARNING: unrecognised transport " transport) - (exit)))) +;; +;; start_server +;; +(define (server:launch run-id) + (http-transport:launch run-id)) ;;====================================================================== ;; Q U E U E M A N A G E M E N T ;;====================================================================== ;; We don't want to flush the queue if it was just flushed (define *server:last-write-flush* (current-milliseconds)) -;; Flush the queue every third of a second. Can we assume that setup-for-run -;; has already been done? -;; (define (server:write-queue-handler) -;; (if (setup-for-run) -;; (let ((db (open-db))) -;; (let loop () -;; (let ((last-write-flush-time #f)) -;; (mutex-lock! *incoming-mutex*) -;; (set! last-write-flush-time *server:last-write-flush*) -;; (mutex-unlock! *incoming-mutex*) -;; (if (> (- (current-milliseconds) last-write-flush-time) 10) -;; (begin -;; (mutex-lock! *db:process-queue-mutex*) -;; (db:process-cached-writes db) -;; (mutex-unlock! *db:process-queue-mutex*) -;; (thread-sleep! 0.005)))) -;; (loop))) -;; (begin -;; (debug:print 0 "ERROR: failed to setup for Megatest in server:write-queue-handler") -;; (exit 1)))) - ;;====================================================================== ;; S E R V E R U T I L I T I E S ;;====================================================================== ;; Generate a unique signature for this server @@ -103,45 +73,123 @@ ;; 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 "server:reply return-addr=" return-addr ", result=" result) - ;; (send-message pubsock target send-more: #t) - ;; (send-message pubsock - (case *transport-type* - ((fs) result) - ((http)(db:obj->string (vector success/fail query-sig result))) - ((zmq) - (let ((pub-socket (vector-ref *runremote* 1))) - (send-message pub-socket return-addr send-more: #t) - (send-message pub-socket (db:obj->string (vector success/fail query-sig result))))) - (else - (debug:print 0 "ERROR: unrecognised transport type: " *transport-type*) - result))) - -(define (server:ensure-running) - (let loop ((servers (open-run-close tasks:get-best-server tasks:open-db)) - (trycount 0)) - (if (or (not servers) - (null? servers)) - (begin - (if (even? trycount) ;; just do the server start every other time through this loop (every 8 seconds) - (let ((cmdln (conc (if (getenv "MT_MEGATEST") (getenv "MT_MEGATEST") "megatest") - " -server - -daemonize"))) - (debug:print 0 "INFO: Starting server (" cmdln ") as none running ...") - ;; (server:launch (string->symbol (args:get-arg "-transport" "http")))) - ;; no need to use fork, no need to do the list-servers trick. Just start the damn server, it will exit on it's own - ;; if there is an existing server - (system cmdln) - (thread-sleep! 3) - ;; (process-run (car (argv)) (list "-server" "-" "-daemonize" "-transport" (args:get-arg "-transport" "http"))) - ) - (begin - (debug:print-info 0 "Waiting for server to start") - (thread-sleep! 4))) - (if (< trycount 10) - (loop (open-run-close tasks:get-best-server tasks:open-db) - (+ trycount 1)) - (debug:print 0 "WARNING: Couldn't start or find a server."))) - (debug:print 2 "INFO: Server(s) running " servers) - ))) + (db:obj->string (vector success/fail query-sig 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 +;; +(define (server:run run-id) + (let* ((curr-host (get-host-name)) + (curr-ip (server:get-best-guess-address curr-host)) + (target-host (configf:lookup *configdat* "server" "homehost" )) + (logfile (conc *toppath* "/logs/" run-id ".log")) + (cmdln (conc (common:get-megatest-exe) + " -server " (or target-host "-") " -run-id " run-id (if (equal? (configf:lookup *configdat* "server" "daemonize") "yes") + (conc " -daemonize -log " logfile) + "") + " -debug 4 "))) ;; (conc " >> " logfile " 2>&1 &"))))) + (debug:print 0 "INFO: Starting server (" cmdln ") as none running ...") + (push-directory *toppath*) + (if (not (directory-exists? "logs"))(create-directory "logs")) + ;; 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 "Starting server on " target-host ", logfile is " logfile) + (setenv "TARGETHOST" target-host))) + (setenv "TARGETHOST_LOGF" logfile) + (system (conc "nbfake " cmdln)) + ;; (system cmdln) + (pop-directory))) + +;; kind start up of servers, wait 40 seconds before allowing another server for a given +;; run-id to be launched +(define (server:kind-run run-id) + (let ((last-run-time (hash-table-ref/default *server-kind-run* run-id #f))) + (if (or (not last-run-time) + (> (- (current-seconds) last-run-time) 40)) + (begin + (server:run run-id) + (hash-table-set! *server-kind-run* run-id (current-seconds)))))) + +;; The generic run a server command. Dispatches the call to server 0 if run-id != 0 +;; +(define (server:try-running run-id) + (if (eq? run-id 0) + (server:run run-id) + (rmt:start-server run-id))) + +(define (server:check-if-running run-id) + (let loop ((server (tasks:get-server (tasks:get-db) run-id)) + (trycount 0)) + (if server + ;; note: client:start will set *runremote*. this needs to be changed + ;; also, client:start will login to the server, also need to change that. + ;; + ;; client:start returns #t if login was successful. + ;; + (let ((res (server:ping-server run-id + (tasks:hostinfo-get-interface server) + (tasks:hostinfo-get-port server)))) + ;; if the server didn't respond we must remove the record + (if res + #t + (begin + (debug:print-info 0 "server at " server " not responding, removing record") + (tasks:server-force-clean-running-records-for-run-id (tasks:get-db) run-id + " server:check-if-running") + res))) + #f))) + +;; called in megatest.scm, host-port is string hostname:port +;; +(define (server:ping run-id host:port) + (let* ((host-port (let ((slst (string-split host:port ":"))) + (if (eq? (length slst) 2) + (list (car slst)(string->number (cadr slst))) + #f))) + (toppath (launch:setup-for-run)) + (server-db-dat (if (not host-port)(tasks:get-server (tasks:get-db) run-id) #f))) + (if (not run-id) + (begin + (debug:print 0 "ERROR: must specify run-id when doing ping, -run-id n") + (print "ERROR: No run-id") + (exit 1)) + (if (and (not host-port) + (not server-db-dat)) + (begin + (print "ERROR: bad host:port") + (exit 1)) + (let* ((iface (if host-port (car host-port) (tasks:hostinfo-get-interface server-db-dat))) + (port (if host-port (cadr host-port)(tasks:hostinfo-get-port server-db-dat))) + (server-dat (http-transport:client-connect iface port)) + (login-res (rmt:login-no-auto-client-setup server-dat run-id))) + (if (and (list? login-res) + (car login-res)) + (begin + (print "LOGIN_OK") + (exit 0)) + (begin + (print "LOGIN_FAILED") + (exit 1)))))))) + +;; run ping in separate process, safest way in some cases +;; +(define (server:ping-server run-id iface port) + (with-input-from-pipe + (conc (common:get-megatest-exe) " -run-id " run-id " -ping " (conc iface ":" port)) + (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)))))) Index: synchash.scm ================================================================== --- synchash.scm +++ synchash.scm @@ -12,11 +12,12 @@ ;;====================================================================== ;; A hash of hashes that can be kept in sync by sending minial deltas ;;====================================================================== (use format) -(use srfi-1 srfi-69) +(use srfi-1 srfi-69 sqlite3) +(import (prefix sqlite3 sqlite3:)) (declare (unit synchash)) (declare (uses db)) (declare (uses server)) (include "db_records.scm") @@ -62,11 +63,12 @@ ;; (cdb:remote-run db:get-runs #f runnamepatt numruns *start-run-offset* keypatts) ;; ;; keynum => the field to use as the unique key (usually 0 but can be other field) ;; (define (synchash:client-get proc synckey keynum synchash . params) - (let* ((data (apply cdb:remote-run synchash:server-get #f proc synckey keynum params)) + (let* ((data ;; (apply cdb:remote-run synchash:server-get #f proc synckey keynum params)) + (apply synchash:server-get #f proc synckey keynum params)) (newdat (car data)) (removs (cadr data)) (myhash (hash-table-ref/default synchash synckey #f))) (if (not myhash) (begin @@ -87,13 +89,14 @@ ;; data)) ;; return the changed and deleted list (list newdat removs))) ;; synchash)) (define *synchashes* (make-hash-table)) -(define (synchash:server-get db proc synckey keynum . params) +(define (synchash:server-get indb proc synckey keynum . params) ;; (debug:print-info 2 "synckey: " synckey ", keynum: " keynum ", params: " params) - (let* ((synchash (hash-table-ref/default *synchashes* synckey #f)) + (let* ((db (if indb indb (db:open-megatest-db))) + (synchash (hash-table-ref/default *synchashes* synckey #f)) (newdat (apply (case proc ((db:get-runs) db:get-runs) ((db:get-tests-for-runs-mindata) db:get-tests-for-runs-mindata) ((db:get-test-info-by-ids) db:get-test-info-by-ids) (else @@ -114,11 +117,12 @@ (map make-indexed data)))) ;; add each element keyed by the keynum'th val (else ;; (debug:print-info 2 "Non-get runs call") (map make-indexed newdat)))) ;; (debug:print-info 2 "postdat: " postdat) + (if (not indb)(sqlite3:finalize! db)) (if (not synchash) (begin (set! synchash (make-hash-table)) (hash-table-set! *synchashes* synckey synchash))) (synchash:get-delta postdat synchash))) Index: tasks.scm ================================================================== --- tasks.scm +++ tasks.scm @@ -20,31 +20,69 @@ ;;====================================================================== ;; Tasks db ;;====================================================================== +;; wait up to aprox n seconds for a journal to go away +;; +(define (tasks:wait-on-journal path n #!key (remove #f)) + (let ((fullpath (conc path "-journal"))) + (let loop ((journal-exists (file-exists? fullpath)) + (count n)) ;; wait ten times ... + (if journal-exists + (if (> count 0) + (begin + (thread-sleep! 1) + (loop (file-exists? fullpath) + (- count 1))) + (begin + (if remove (system (conc "rm -rf " path))) + #f)) + #t)))) + +(define (tasks:get-task-db-path) + (if *task-db* + (vector-ref *task-db* 1) + (let* ((linktree (configf:lookup *configdat* "setup" "linktree")) + (dbpath (conc linktree "/.db/monitor.db"))) + dbpath))) + +;; If file exists AND +;; file readable +;; ==> open it +;; If file exists AND +;; file NOT readable +;; ==> open in-mem version +;; If file NOT exists +;; ==> open in-mem version +;; (define (tasks:open-db) - (let* ((dbpath (conc *toppath* "/db/monitor.db")) + (let* ((dbpath (tasks:get-task-db-path)) + (avail (tasks:wait-on-journal dbpath 10)) ;; wait up to about 10 seconds for the journal to go away (exists (file-exists? dbpath)) (write-access (file-write-access? dbpath)) - (mdb (sqlite3:open-database dbpath)) ;; (never-give-up-open-db dbpath)) + (mdb (cond + ((file-write-access? *toppath*)(sqlite3:open-database dbpath)) + ((file-read-access? dbpath) (sqlite3:open-database dbpath)) + (else (sqlite3:open-database ":memory:")))) ;; (never-give-up-open-db dbpath)) (handler (make-busy-timeout 36000))) (if (and exists (not write-access)) (set! *db-write-access* write-access)) ;; only unset so other db's also can use this control (sqlite3:set-busy-handler! mdb handler) (sqlite3:execute mdb (conc "PRAGMA synchronous = 0;")) - (if (not exists) + (if (or (and (not exists) + (file-write-access? *toppath*)) + (not (file-read-access? dbpath))) (begin (sqlite3:execute mdb "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 '', - test TEXT DEFAULT '', - item TEXT DEFAULT '', + testpatt TEXT DEFAULT '', keylock TEXT, params TEXT, creation_time TIMESTAMP, execution_time TIMESTAMP);") (sqlite3:execute mdb "CREATE TABLE IF NOT EXISTS monitors (id INTEGER PRIMARY KEY, @@ -64,12 +102,12 @@ priority INTEGER, state TEXT, mt_version TEXT, heartbeat TIMESTAMP, transport TEXT, - run_id INTEGER, - CONSTRAINT servers_constraint UNIQUE (pid,hostname,port));") + run_id INTEGER);") +;; CONSTRAINT servers_constraint UNIQUE (pid,hostname,port));") (sqlite3:execute mdb "CREATE TABLE IF NOT EXISTS clients (id INTEGER PRIMARY KEY, server_id INTEGER, pid INTEGER, hostname TEXT, cmdline TEXT, @@ -77,11 +115,19 @@ logout_time TIMESTAMP DEFAULT -1, CONSTRAINT clients_constraint UNIQUE (pid,hostname));") )) mdb)) - + +(define (tasks:get-db) + (if *task-db* + (vector-ref *task-db* 0) + (let ((db (tasks:open-db)) + (pth (tasks:get-task-db-path))) + (set! *task-db* (vector db pth)) + db))) + ;;====================================================================== ;; Server and client management ;;====================================================================== ;; make-vector-record tasks hostinfo id interface port pubport transport pid hostname @@ -91,217 +137,224 @@ (define (tasks:hostinfo-get-pubport vec) (vector-ref vec 3)) (define (tasks:hostinfo-get-transport vec) (vector-ref vec 4)) (define (tasks:hostinfo-get-pid vec) (vector-ref vec 5)) (define (tasks:hostinfo-get-hostname vec) (vector-ref vec 6)) -;; state: 'live, 'shutting-down, 'dead -(define (tasks:server-register mdb pid interface port priority state transport #!key (pubport -1)) - (debug:print-info 11 "tasks:server-register " pid " " interface " " port " " priority " " state) +(define (tasks:server-lock-slot mdb run-id) + (tasks:server-clean-out-old-records-for-run-id mdb run-id " tasks:server-lock-slot") + (if (< (tasks:num-in-available-state mdb run-id) 4) + (begin + (tasks:server-set-available mdb run-id) + (thread-sleep! 2) ;; Try removing this. It may not be needed. + (tasks:server-am-i-the-server? mdb run-id)) + #f)) + +;; register that this server may come online (first to register goes though with the process) +(define (tasks:server-set-available mdb run-id) (sqlite3:execute mdb - "INSERT OR REPLACE INTO servers (pid,hostname,port,pubport,start_time,priority,state,mt_version,heartbeat,interface,transport) - VALUES(?, ?, ?, ?, strftime('%s','now'), ?, ?, ?, strftime('%s','now'),?,?);" - pid (get-host-name) port pubport priority (conc state) - (common:version-signature) - interface - (conc transport)) - (vector - (tasks:server-get-server-id mdb (get-host-name) interface port pid) - interface - port - pubport - transport + "INSERT INTO servers (pid,hostname,port,pubport,start_time, priority,state,mt_version,heartbeat, interface,transport,run_id) + VALUES(?, ?, ?, ?, strftime('%s','now'), ?, ?, ?,-1,?, ?, ?);" + (current-process-id) ;; pid + (get-host-name) ;; hostname + -1 ;; port + -1 ;; pubport + (random 1000) ;; priority (used a tiebreaker on get-available) + "available" ;; state + (common:version-signature) ;; mt_version + -1 ;; interface + "http" ;; transport + run-id )) -;; NB// two servers with same pid on different hosts will be removed from the list if pid: is used! -(define (tasks:server-deregister mdb hostname #!key (port #f)(pid #f)(action 'delete)) - (debug:print-info 11 "server-deregister " hostname ", port " port ", pid " pid) - (if *db-write-access* - (if pid - (case action - ((delete)(sqlite3:execute mdb "DELETE FROM servers WHERE pid=?;" pid)) - (else (sqlite3:execute mdb "UPDATE servers SET state='dead' WHERE pid=?;" pid))) - (if port - (case action - ((delete)(sqlite3:execute mdb "DELETE FROM servers WHERE (interface=? or hostname=?) AND port=?;" hostname hostname port)) - (else (sqlite3:execute mdb "UPDATE servers SET state='dead' WHERE (interface=? or hostname=?) AND port=?;" hostname hostname port))) - (debug:print 0 "ERROR: tasks:server-deregister called with neither pid nor port specified"))))) - -(define (tasks:server-deregister-self mdb hostname) - (tasks:server-deregister mdb hostname pid: (current-process-id))) - -;; need a simple call for robustly removing records given host and port -(define (tasks:server-delete mdb hostname port) - (tasks:server-deregister mdb hostname port: port action: 'delete)) - -(define (tasks:server-get-server-id mdb hostname iface port pid) - (debug:print-info 12 "tasks:server-get-server-id " mdb " " hostname " " iface " " port " " pid) +(define (tasks:num-in-available-state mdb run-id) + (let ((res 0)) + (sqlite3:for-each-row + (lambda (num-in-queue) + (set! res num-in-queue)) + mdb + "SELECT count(id) FROM servers WHERE run_id=? AND state = 'available' AND (strftime('%s','now') - start_time) < 30 ;" + run-id) + res)) + +(define (tasks:num-servers-non-zero-running mdb) + (let ((res 0)) + (sqlite3:for-each-row + (lambda (num-running) + (set! res num-running)) + mdb + "SELECT count(id) FROM servers WHERE run_id != 0 AND state = 'running';") + res)) + +(define (tasks:server-clean-out-old-records-for-run-id mdb run-id tag) + (sqlite3:execute mdb "UPDATE servers SET state=?,heartbeat=strftime('%s','now') WHERE state in ('available','dbprep','shutting-down') AND (strftime('%s','now') - start_time) > 50 AND run_id=?;" + (conc "defunct" tag) run-id)) + +(define (tasks:server-force-clean-running-records-for-run-id mdb run-id tag) + (sqlite3:execute mdb "UPDATE servers SET state=?,heartbeat=strftime('%s','now') WHERE state = 'running' AND run_id=?;" + (conc "defunct" tag) run-id)) + +(define (tasks:server-force-clean-run-record mdb run-id iface port tag) + (sqlite3:execute mdb "UPDATE servers SET state=?,heartbeat=strftime('%s','now') WHERE state = 'running' AND run_id=? AND interface=? AND port=?;" + (conc "defunct" tag) run-id iface port)) + +(define (tasks:server-delete-records-for-this-pid mdb tag) + (sqlite3:execute mdb "UPDATE servers SET state=?,heartbeat=strftime('%s','now') WHERE hostname=? AND pid=?;" + (conc "defunct" tag) (get-host-name) (current-process-id))) + +(define (tasks:server-delete-record mdb server-id tag) + (sqlite3:execute mdb "UPDATE servers SET state=?,heartbeat=strftime('%s','now') WHERE id=?;" + (conc "defunct" tag) server-id) + ;; use this opportuntity to clean out records over one month old or over 10 minutes old with port = -1 (i.e. a never used placeholder) + (sqlite3:execute mdb "DELETE FROM servers WHERE state not in ('running','shutting-down','dbprep') AND (strftime('%s','now') - start_time) > 2628000;") + (sqlite3:execute mdb "DELETE FROM servers WHERE state like 'defunct%' AND port=-1 AND (strftime('%s','now') - start_time) > 600;") + ) + +(define (tasks:server-set-state! mdb server-id state) + (sqlite3:execute mdb "UPDATE servers SET state=?,heartbeat=strftime('%s','now') WHERE id=?;" state server-id)) + +(define (tasks:server-set-interface-port mdb server-id interface port) + (sqlite3:execute mdb "UPDATE servers SET interface=?,port=?,heartbeat=strftime('%s','now') WHERE id=?;" interface port server-id)) + +;; Get random port not used in long time +;; +(define (tasks:server-get-next-port mdb) + (let* ((lownum 30000) + (highnum 64000) + (used-ports '()) + (get-rand-port (lambda () + (+ lownum (random (- highnum lownum))))) + (port-param (if (and (args:get-arg "-port") + (string->number (args:get-arg "-port"))) + (string->number (args:get-arg "-port")) + #f)) + ;; (config-port (if (and (config-lookup *configdat* "server" "port") + ;; (string->number (config-lookup *configdat* "server" "port"))) + ;; (string->number (config-lookup *configdat* "server" "port")) + ;; #f)) + ) + (sqlite3:for-each-row + (lambda (port) + (set! used-ports (cons port used-ports))) + mdb + "SELECT port FROM servers;") + (cond + ((and port-param res) (if (> res port-param) res port-param)) + (port-param port-param) + ;; ((and config-port res) (if (> res config-port) res config-port)) + ;; (config-port config-port) + (else + (let loop ((port (get-rand-port)) + (remtries 100)) + (if (member port used-ports) + (if (> remtries 0) + (loop (get-rand-port)(- remtries 1)) + (get-rand-port)) + port)))))) + +(define (tasks:server-am-i-the-server? mdb run-id) + (let* ((all (tasks:server-get-servers-vying-for-run-id mdb run-id)) + (first (if (null? all) + (begin (debug:print 0 "ERROR: no servers listed, should be at least one by now.") + (sqlite3:finalize! mdb) + (exit 1)) + (car (db:get-rows all)))) + (header (db:get-header all)) + (id (db:get-value-by-header first header "id")) + (hostname (db:get-value-by-header first header "hostname")) + (pid (db:get-value-by-header first header "pid")) + (priority (db:get-value-by-header first header "priority"))) + (debug:print 0 "INFO: am-i-the-server got record " first) + ;; for now a basic check. add tiebreaking by priority later + (if (and (equal? hostname (get-host-name)) + (equal? pid (current-process-id))) + id + #f))) + +;; Use: (db:get-value-by-header (car (db:get-rows dat)) (db:get-header dat) "fieldname") +;; to extract info from the structure returned +;; +(define (tasks:server-get-servers-vying-for-run-id mdb run-id) + (let* ((header (list "id" "hostname" "pid" "interface" "port" "pubport" "state" "run_id" "priority" "start_time")) + (selstr (string-intersperse header ",")) + (res '())) + (sqlite3:for-each-row + (lambda (a . b) + (set! res (cons (apply vector a b) res))) + mdb + (conc "SELECT " selstr " FROM servers WHERE run_id=? AND state in ('available','running','dbprep') ORDER BY start_time DESC;") + run-id) + (vector header res))) + +(define (tasks:get-server mdb run-id) + (let ((res #f) + (best #f)) + (sqlite3:for-each-row + (lambda (id interface port pubport transport pid hostname) + (set! res (vector id interface port pubport transport pid hostname))) + mdb + ;; removed: + ;; strftime('%s','now')-heartbeat < 10 AND mt_version = ? + "SELECT id,interface,port,pubport,transport,pid,hostname FROM servers + WHERE run_id=? AND state='running' + ORDER BY start_time DESC LIMIT 1;" run-id) ;; (common:version-signature) run-id) + res)) + +(define (tasks:server-running-or-starting? mdb run-id) (let ((res #f)) (sqlite3:for-each-row (lambda (id) (set! res id)) - mdb - (cond - ((and hostname pid) "SELECT id FROM servers WHERE hostname=? AND pid=?;") - ((and iface port) "SELECT id FROM servers WHERE interface=? AND port=?;") - ((and hostname port) "SELECT id FROM servers WHERE hostname=? AND port=?;") - (else - (begin - (debug:print 0 "ERROR: tasks:server-get-server-id needs (hostname and pid) OR (iface and port) OR (hostname and port)") - "SELECT id FROM servers WHERE pid=-999;"))) - (if hostname hostname iface)(if pid pid port)) + mdb ;; NEEDS dbprep ADDED + "SELECT id FROM servers WHERE run_id=? AND (state = 'running' OR (state = 'dbprep' AND (strftime('%s','now') - start_time) < 60));" run-id) res)) - -(define (tasks:server-update-heartbeat mdb server-id) - (debug:print-info 1 "Heart beat update of server id=" server-id) - (handle-exceptions - exn - (begin - (debug:print 0 "WARNING: probable timeout on monitor.db access") - (thread-sleep! 1) - (tasks:server-update-heartbeat mdb server-id)) - (sqlite3:execute mdb "UPDATE servers SET heartbeat=strftime('%s','now') WHERE id=?;" server-id))) - -;; alive servers keep the heartbeat field upto date with seconds every 6 or so seconds -(define (tasks:server-alive? mdb server-id #!key (iface #f)(hostname #f)(port #f)(pid #f)) - (let* ((server-id (if server-id - server-id - (tasks:server-get-server-id mdb hostname iface port pid))) - (heartbeat-delta 99e9)) - (sqlite3:for-each-row - (lambda (delta) - (set! heartbeat-delta delta)) - mdb "SELECT strftime('%s','now')-heartbeat FROM servers WHERE id=?;" server-id) - (< heartbeat-delta 10))) - -(define (tasks:client-register mdb pid hostname cmdline) - (sqlite3:execute - mdb - "INSERT OR REPLACE INTO clients (server_id,pid,hostname,cmdline,login_time) VALUES(?,?,?,?,strftime('%s','now'));") - (tasks:server-get-server-id mdb hostname #f #f pid) - pid hostname cmdline) - -(define (tasks:client-logout mdb pid hostname cmdline) - (sqlite3:execute - mdb - "UPDATE clients SET logout_time=strftime('%s','now') WHERE pid=? AND hostname=? AND cmdline=?;" - pid hostname cmdline)) - -(define (tasks:get-logged-in-clients mdb server-id) - (let ((res '())) - (sqlite3:for-each-row - (lambda (id server-id pid hostname cmdline login-time logout-time) - (set! res (cons (vector id server-id pid hostname cmdline login-time lougout-time) res))) - mdb - "SELECT id,server_id,pid,hostname,cmdline,login_time,logout_time FROM clients WHERE server_id=?;" - server-id))) - -(define (tasks:have-clients? mdb server-id) - (null? (tasks:get-logged-in-clients mdb server-id))) - -;; ping each server in the db and return first found that responds. -;; remove any others. will not necessarily remove all! -(define (tasks:get-best-server mdb) - (let ((res '()) - (best #f) - (transport (if (and *transport-type* - (not (eq? *transport-type* 'fs))) - (conc *transport-type*) - "%"))) - (sqlite3:for-each-row - (lambda (id interface port pubport transport pid hostname) - (set! res (cons (vector id interface port pubport transport pid hostname) res)) - ;;(debug:print-info 2 "Found existing server " hostname ":" port " registered in db")) - ) - mdb - - "SELECT id,interface,port,pubport,transport,pid,hostname FROM servers - WHERE strftime('%s','now')-heartbeat < 10 - AND mt_version=? AND transport LIKE ? - ORDER BY start_time DESC LIMIT 1;" (common:version-signature) transport) - ;; for now we are keeping only one server registered in the db, return #f or first server found - (if (null? res) #f (car res)))) - -;; BUG: This logic is probably needed unless methodology changes completely... -;; -;; (if (null? res) #f -;; (let loop ((hed (car res)) -;; (tal (cdr res))) -;; ;; (print "hed=" hed ", tal=" tal) -;; (let* ((host (list-ref hed 0)) -;; (iface (list-ref hed 1)) -;; (port (list-ref hed 2)) -;; (pid (list-ref hed 4)) -;; (alive (open-run-close tasks:server-alive? tasks:open-db #f hostname: host port: port))) -;; (if alive -;; (begin -;; (debug:print-info 2 "Found an existing, alive, server " host ", " port ".") -;; (list host iface port)) -;; (begin -;; (debug:print-info 1 "Marking " host ":" port " as dead in server registry.") -;; (if port -;; (open-run-close tasks:server-deregister tasks:open-db host port: port) -;; (open-run-close tasks:server-deregister tasks:open-db host pid: pid)) -;; (if (null? tal) -;; #f -;; (loop (car tal)(cdr tal)))))))))) - -(define (tasks:remove-server-records mdb) - (sqlite3:execute mdb "DELETE FROM servers;")) - -(define (tasks:mark-server hostname port pid state transport) - (if port - (open-run-close tasks:server-deregister tasks:open-db hostname port: port) - (open-run-close tasks:server-deregister tasks:open-db hostname pid: pid))) - - -(define (tasks:kill-server status hostname port pid transport) - (debug:print-info 1 "Removing defunct server record for " hostname ":" port) - (if port - (open-run-close tasks:server-deregister tasks:open-db hostname port: port) - (open-run-close tasks:server-deregister tasks:open-db hostname pid: pid)) - (if status ;; #t means alive - (begin - (if (equal? hostname (get-host-name)) - (handle-exceptions - exn - (debug:print-info 0 "server may or may not be dead, check for megatest -server running as pid " pid "\n" - " EXCEPTION: " ((condition-property-accessor 'exn 'message) exn)) - (debug:print 1 "Sending signal/term to " pid " on " hostname) - (process-signal pid signal/term) - (thread-sleep! 5) ;; give it five seconds to die peacefully then do a brutal kill - ;;(process-signal pid signal/kill) - ) ;; local machine, send sig term - (begin - ;;(debug:print-info 1 "Stopping remote servers not yet supported.")))) - (debug:print-info 1 "Telling alive server on " hostname ":" port " to commit servercide") - (let ((serverdat (list hostname port))) - (case (if (string? transport) (string->symbol transport) transport) - ((http)(http-transport:client-connect hostname port)) - (else (debug:print "ERROR: remote stopping servers of type " transport " not supported yet"))) - (cdb:kill-server serverdat pid))))) ;; remote machine, try telling server to commit suicide - (begin - (if status - (if (equal? hostname (get-host-name)) - (begin - (debug:print-info 1 "Sending signal/term to " pid " on " hostname) - (process-signal pid signal/term) ;; local machine, send sig term - (thread-sleep! 5) ;; give it five seconds to die peacefully then do a brutal kill - (process-signal pid signal/kill)) - (debug:print 0 "WARNING: Can't kill frozen server on remote host " hostname)))))) - - (define (tasks:get-all-servers mdb) (let ((res '())) (sqlite3:for-each-row - (lambda (id pid hostname interface port pubport start-time priority state mt-version last-update transport) - (set! res (cons (vector id pid hostname interface port pubport start-time priority state mt-version last-update transport) res))) + (lambda (id pid hostname interface port pubport start-time priority state mt-version last-update transport run-id) + ;; 0 1 2 3 4 5 6 7 8 9 10 11 12 + (set! res (cons (vector id pid hostname interface port pubport start-time priority state mt-version last-update transport run-id) res))) mdb - "SELECT id,pid,hostname,interface,port,pubport,start_time,priority,state,mt_version,strftime('%s','now')-heartbeat AS last_update,transport FROM servers ORDER BY start_time DESC;") + "SELECT id,pid,hostname,interface,port,pubport,start_time,priority,state,mt_version,strftime('%s','now')-heartbeat AS last_update,transport,run_id FROM servers WHERE state NOT LIKE 'defunct%' ORDER BY start_time DESC;") res)) - + +;; no elegance here ... +;; +(define (tasks:kill-server hostname pid) + (debug:print-info 0 "Attempting to kill server process " pid " on host " hostname) + (setenv "TARGETHOST" hostname) + (system (conc "nbfake kill " pid))) + +;; (if status ;; #t means alive +;; (begin +;; (if (equal? hostname (get-host-name)) +;; (handle-exceptions +;; exn +;; (debug:print-info 0 "server may or may not be dead, check for megatest -server running as pid " pid "\n" +;; " EXCEPTION: " ((condition-property-accessor 'exn 'message) exn)) +;; (debug:print 1 "Sending signal/term to " pid " on " hostname) +;; (process-signal pid signal/term) +;; (thread-sleep! 5) ;; give it five seconds to die peacefully then do a brutal kill +;; ;;(process-signal pid signal/kill) +;; ) ;; local machine, send sig term +;; (begin +;; ;;(debug:print-info 1 "Stopping remote servers not yet supported.")))) +;; (debug:print-info 1 "Telling alive server on " hostname ":" port " to commit servercide") +;; (let ((serverdat (list hostname port))) +;; (hash-table-set! *runremote* run-id (http-transport:client-connect hostname port)) +;; (cdb:kill-server serverdat pid))))) ;; remote machine, try telling server to commit suicide +;; (begin +;; (if status +;; (if (equal? hostname (get-host-name)) +;; (begin +;; (debug:print-info 1 "Sending signal/term to " pid " on " hostname) +;; (process-signal pid signal/term) ;; local machine, send sig term +;; (thread-sleep! 5) ;; give it five seconds to die peacefully then do a brutal kill +;; (process-signal pid signal/kill)) +;; (debug:print 0 "WARNING: Can't kill frozen server on remote host " hostname)))))) + ;;====================================================================== ;; Tasks and Task monitors ;;====================================================================== @@ -334,19 +387,18 @@ "SELECT count(id) FROM monitors WHERE last_update < (strftime('%s','now') - 300) AND username=?;" (car (user-information (current-user-id)))) res)) ;; register a task -(define (tasks:add mdb action owner target runname test item params) - (sqlite3:execute mdb "INSERT INTO tasks_queue (action,owner,state,target,name,test,item,params,creation_time,execution_time) - VALUES (?,?,'new',?,?,?,?,?,strftime('%s','now'),0);" +(define (tasks:add mdb action owner target runname testpatt params) + (sqlite3:execute mdb "INSERT INTO tasks_queue (action,owner,state,target,name,testpatt,params,creation_time,execution_time) + VALUES (?,?,'new',?,?,?,?,strftime('%s','now'),0);" action owner target runname - test - item + testpatt (if params params ""))) (define (keys:key-vals-hash->target keys key-params) (let ((tmp (hash-table-ref/default key-params (vector-ref (car keys) 0) ""))) (if (> (length keys) 1) @@ -426,11 +478,11 @@ ;; (define (tasks:start-monitor db mdb) (if (> (tasks:get-num-alive-monitors mdb) 2) ;; have two running, no need for more (debug:print-info 1 "Not starting monitor, already have more than two running") (let* ((megatestdb (conc *toppath* "/megatest.db")) - (monitordbf (conc *toppath* "/db/monitor.db")) + (monitordbf (conc (configf:lookup *configdat* "setup" "linktree") "/.db/monitor.db")) (last-db-update 0)) ;; (file-modification-time megatestdb))) (task:register-monitor mdb) (let loop ((count 0) (next-touch 0)) ;; next-touch is the time where we need to update last_update ;; if the db has been modified we'd best look at the task queue @@ -524,10 +576,81 @@ (define (tasks:set-state mdb task-id state) (sqlite3:execute mdb "UPDATE tasks_queue SET state=? WHERE id=?;" state task-id)) + +;;====================================================================== +;; Access using task key (stored in params; (hash-table->alist flags) hostname pid +;;====================================================================== + +(define (tasks:param-key->id mdb task-params) + (handle-exceptions + exn + #f + (sqlite3:first-result mdb "SELECT id FROM tasks_queue WHERE params LIKE ?;" task-params))) + +(define (tasks:set-state-given-param-key mdb param-key new-state) + (sqlite3:execute mdb "UPDATE tasks_queue SET state=? WHERE params LIKE ?;" new-state param-key)) + +(define (tasks:get-records-given-param-key mdb param-key state-patt action-patt test-patt) + (handle-exceptions + exn + '() + (sqlite3:first-row mdb "SELECT id,action,owner,state,target,name,testpatt,keylock,params WHERE + params LIKE ? AND state LIKE ? AND action LIKE ? AND testpatt LIKE ?;" + param-key state-patt action-patt test-patt))) + + +;;====================================================================== +;; Rogue items, no place to put these yet +;;====================================================================== + +(define (tasks:find-task-queue-records mdb target run-name test-patt state-patt action-patt) + ;; (handle-exceptions + ;; exn + ;; '() + ;; (sqlite3:first-row + (let ((res '())) + (sqlite3:for-each-row + (lambda (a . b) + (set! res (cons (cons a b) res))) + mdb "SELECT id,action,owner,state,target,name,testpatt,keylock,params FROM tasks_queue + WHERE + target = ? AND name = ? AND state LIKE ? AND action LIKE ? AND testpatt LIKE ?;" + target run-name state-patt action-patt test-patt) + res)) ;; ) + + +(define (tasks:kill-runner mdb target run-name) + (let ((records (tasks:find-task-queue-records mdb target run-name "%" "running" "run-tests")) + (hostpid-rx (regexp "\\s+(\\w+)\\s+(\\d+)$"))) ;; host pid is at end of param string + (if (null? records) + (debug:print 0 "No run launching processes found for " target " / " run-name) + (debug:print 0 "Found " (length records) " run(s) to kill.")) + (for-each + (lambda (record) + (let* ((param-key (list-ref record 8)) + (match-dat (string-search hostpid-rx param-key)) + (hostname (cadr match-dat)) + (pid (caddr match-dat))) + (debug:print 0 "Sending SIGINT to process " pid " on host " hostname) + (if (equal? (get-host-name) hostname) + (begin + (process-signal (string->number pid) signal/int) + (thread-sleep! 5) + (handle-exceptions + exn + #t + (process-signal (string->number pid) signal/kill))) + ;; (call-with-environment-variables + (let ((old-targethost (getenv "TARGETHOST"))) + (set-environment-variable "TARGETHOST" hostname) + (system (conc "nbfake " kill " " pid)) + (if old-targethost (set-environment-variable "TARGETHOST" old-targethost)))))) + records))) + ;;====================================================================== ;; The routines to process tasks ;;====================================================================== Index: tdb.scm ================================================================== --- tdb.scm +++ tdb.scm @@ -11,25 +11,19 @@ ;;====================================================================== ;; Database access ;;====================================================================== -(require-extension (srfi 18) extras tcp) ;; rpc) -;; (import (prefix rpc rpc:)) - +(require-extension (srfi 18) extras tcp) (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:)) -;; Note, try to remove this dependency -;; (use zmq) - (declare (unit tdb)) (declare (uses common)) (declare (uses keys)) (declare (uses ods)) -(declare (uses fs-transport)) (declare (uses client)) (declare (uses mt)) (include "common_records.scm") (include "db_records.scm") @@ -61,11 +55,12 @@ (handle-exceptions exn (begin (debug:print 2 "ERROR: problem accessing test db " work-area ", you probably should clean and re-run this test" ((condition-property-accessor 'exn 'message) exn)) - (set! db (sqlite3:open-database ":memory:"))) ;; open an in-memory db to allow readonly access + (set! db (sqlite3:open-database ":memory:")) ;; open an in-memory db to allow readonly access + (set! dbexists #f)) ;; must force re-creation of tables, more tom-foolery (set! db (sqlite3:open-database dbpath))) (if *db-write-access* (sqlite3:set-busy-handler! db handler)) (if (not dbexists) (begin (sqlite3:execute db "PRAGMA synchronous = FULL;") @@ -97,22 +92,22 @@ (rmt:test-get-rundir-from-test-id test-id)))) (debug:print 3 "TEST PATH: " test-path) (open-test-db test-path))) ;; find and open the testdat.db file for an existing test -(define (tdb:open-test-db-by-test-id-local test-id #!key (work-area #f)) +(define (tdb:open-test-db-by-test-id-local dbstruct run-id test-id #!key (work-area #f)) (let* ((test-path (if work-area work-area - (open-run-close db:test-get-rundir-from-test-id #f test-id)))) + (db:test-get-rundir-from-test-id dbstruct run-id test-id)))) (debug:print 3 "TEST PATH: " test-path) (open-test-db test-path))) ;; find and open the testdat.db file for an existing test -(define (tdb:open-run-close-db-by-test-id-local test-id work-area proc . params) +(define (tdb:open-run-close-db-by-test-id-local dbstruct run-id test-id work-area proc . params) (let* ((test-path (if work-area work-area - (open-run-close db:test-get-rundir-from-test-id #f test-id))) + (db:test-get-rundir-from-test-id dbstruct run-id test-id))) (tdb (open-test-db test-path))) (apply proc tdb params))) (define (tdb:testdb-initialize db) (debug:print 11 "db:testdb-initialize START") @@ -187,20 +182,20 @@ ;; (sqlite3:finalize! tdb) ;; (reverse res)) ;; '()))) ;; NOTE: Run this local with #f for db !!! -(define (tdb:load-test-data test-id) +(define (tdb:load-test-data run-id test-id) (let loop ((lin (read-line))) (if (not (eof-object? lin)) (begin (debug:print 4 lin) - (rmt:csv->test-data test-id lin) + (rmt:csv->test-data run-id test-id lin) (loop (read-line))))) ;; roll up the current results. ;; FIXME: Add the status too - (rmt:test-data-rollup test-id #f)) + (rmt:test-data-rollup run-id test-id #f)) (define (tdb:get-prev-tol-for-test tdb test-id category variable) ;; Finish me? (values #f #f #f)) @@ -357,14 +352,14 @@ (conc (vector-ref b 2))) #f)) (string notpatt: " notpatt ", newpatt: " newpatt ", finpatt: " finpatt) (set! res (string-match (regexp finpatt (if like #t #f)) str)) (if notpatt (not res) res)))) @@ -133,12 +133,14 @@ ;; Check for waiver eligibility ;; (define (tests:check-waiver-eligibility testdat prev-testdat) (let* ((test-registry (make-hash-table)) (testconfig (tests:get-testconfig (db:test-get-testname testdat) test-registry #f)) - (test-rundir (db:test-get-rundir testdat)) - (prev-rundir (db:test-get-rundir prev-testdat)) + (test-rundir ;; (sdb:qry 'passstr + (db:test-get-rundir testdat)) ;; ) + (prev-rundir ;; (sdb:qry 'passstr + (db:test-get-rundir prev-testdat)) ;; ) (waivers (configf:section-vars testconfig "waivers")) (waiver-rx (regexp "^(\\S+)\\s+(.*)$")) (diff-rule "diff %file1% %file2%") (logpro-rule "diff %file1% %file2% | logpro %waivername%.logpro %waivername%.html")) (if (not (file-exists? test-rundir)) @@ -190,21 +192,20 @@ (loop (car tal)(cdr tal))) #f)))))) (pop-directory) result))))) -(define (tests:test-force-state-status! test-id state status) - (rmt:test-set-status-state test-id status state #f) - (mt:process-triggers test-id state status)) +(define (tests:test-force-state-status! run-id test-id state status) + (rmt:test-set-status-state run-id test-id status state #f) + (mt:process-triggers run-id test-id state status)) ;; Do not rpc this one, do the underlying calls!!! -(define (tests:test-set-status! test-id state status comment dat #!key (work-area #f)) +(define (tests:test-set-status! run-id test-id state status comment dat #!key (work-area #f)) (let* ((real-status status) (otherdat (if dat dat (make-hash-table))) - (testdat (rmt:get-test-info-by-id test-id)) - (run-id (db:test-get-run_id testdat)) - (test-name (db:test-get-testname testdat)) + (testdat (rmt:get-test-info-by-id run-id test-id)) + (test-name (db:test-get-testname testdat)) (item-path (db:test-get-item-path testdat)) ;; before proceeding we must find out if the previous test (where all keys matched except runname) ;; was WAIVED if this test is FAIL ;; NOTES: @@ -235,17 +236,17 @@ (debug:print 4 "real-status " real-status ", waived " waived ", status " status) ;; update the primary record IF state AND status are defined (if (and state status) (begin - (rmt:test-set-status-state test-id real-status state (if waived waived comment)) - (mt:process-triggers test-id state real-status))) + (rmt:test-set-status-state run-id test-id real-status state (if waived waived comment)) + (mt:process-triggers run-id test-id state real-status))) ;; if status is "AUTO" then call rollup (note, this one modifies data in test ;; run area, it does remote calls under the hood. (if (and test-id state status (equal? status "AUTO")) - (rmt:test-data-rollup test-id status)) + (rmt:test-data-rollup run-id test-id status)) ;; add metadata (need to do this way to avoid SQL injection issues) ;; :first_err ;; (let ((val (hash-table-ref/default otherdat ":first_err" #f))) @@ -275,12 +276,12 @@ expected "," tol "," units "," dcomment ",," ;; extra comma for status type ))) - ;; This was run remote, don't think that makes sense. - (db:csv->test-data #f test-id + ;; This was run remote, don't think that makes sense. Perhaps not, but that is the easiest path for the moment. + (rmt:csv->test-data run-id test-id dat)))) ;; need to update the top test record if PASS or FAIL and this is a subtest (if (not (equal? item-path "")) (rmt:roll-up-pass-fail-counts run-id test-name item-path status)) @@ -287,14 +288,14 @@ (if (or (and (string? comment) (string-match (regexp "\\S+") comment)) waived) (let ((cmt (if waived waived comment))) - (rmt:general-call 'set-test-comment cmt test-id))))) + (rmt:general-call 'set-test-comment run-id cmt test-id))))) (define (tests:test-set-toplog! run-id test-name logf) - (rmt:general-call 'tests:test-set-toplog logf run-id test-name)) + (rmt:general-call 'tests:test-set-toplog run-id logf run-id test-name)) (define (tests:summarize-items run-id test-id test-name force) ;; if not force then only update the record if one of these is true: ;; 1. logf is "log/final.log ;; 2. logf is same as outputfilename @@ -308,11 +309,11 @@ (directory? path)) ;; can get #f here under some wierd conditions. why, unknown ... (begin (debug:print 4 "Found path: " path) (change-directory path)) ;; (set! outputfilename (conc path "/" outputfilename))) - (print "No such path: " path)) + (debug:print 0 "ERROR: summarize-items for run-id=" run-id ", test-name=" test-name ", no such path: " path)) (debug:print 4 "summarize-items with logf " logf ", outputfilename " outputfilename " and force " force) (if (or (equal? logf "logs/final.log") (equal? logf outputfilename) force) (begin @@ -349,11 +350,16 @@ ">" status "" "" (if (equal? comment "") " " comment) "" "")))) - testdat) + (if (list? testdat) + testdat + (begin + (print "ERROR: failed to get records with rmt:test-get-records-for-index-file run-id=" run-id "test-name=" test-name) + '()))) + (print "
") ;; Print out stats for status (set! tot 0) (print "") (for-each (lambda (state) @@ -383,10 +389,33 @@ (change-directory orig-dir) ;; NB// tests:test-set-toplog! is remote internal... (tests:test-set-toplog! run-id test-name outputfilename) ))))))) +;; MUST BE CALLED local! +;; +(define (tests:test-get-paths-matching keynames target fnamepatt #!key (res '())) + ;; BUG: Move the values derived from args to parameters and push to megatest.scm + (let* ((testpatt (if (args:get-arg "-testpatt")(args:get-arg "-testpatt") "%")) + (statepatt (if (args:get-arg ":state") (args:get-arg ":state") "%")) + (statuspatt (if (args:get-arg ":status") (args:get-arg ":status") "%")) + (runname (if (args:get-arg ":runname") (args:get-arg ":runname") "%")) + (paths-from-db (rmt:test-get-paths-matching-keynames-target-new keynames target res + testpatt + statepatt + statuspatt + runname))) + (if fnamepatt + (apply append + (map (lambda (p) + (if (directory-exists? p) + (glob (conc p "/" fnamepatt)) + '())) + paths-from-db)) + paths-from-db))) + + ;;====================================================================== ;; Gather data from test/task specifications ;;====================================================================== ;; (define (tests:get-valid-tests testsdir test-patts) ;; #!key (test-names '())) @@ -449,11 +478,11 @@ #f ;; cannot have a which is waiting on b happening before b (if (and b-waitons (member (tests:testqueue-get-testname a-record) b-waitons)) #t ;; this is the correct order, b is waiting on a and b is before a (if (> a-priority b-priority) #t ;; if a is a higher priority than b then we are good to go - #f)))))))) + (string-compare3 a b))))))))) ;; for each test: ;; (define (tests:filter-non-runnable run-id testkeynames testrecordshash) (let ((runnables '())) @@ -464,11 +493,11 @@ (itemdat (tests:testqueue-get-itemdat test-record)) (item-path (tests:testqueue-get-item_path test-record)) (waitons (tests:testqueue-get-waitons test-record)) (keep-test #t) (test-id (rmt:get-test-id run-id test-name item-path)) - (tdat (rmt:get-testinfo-state-status test-id))) ;; (cdb:get-test-info-by-id *runremote* test-id))) + (tdat (rmt:get-testinfo-state-status run-id test-id))) ;; (cdb:get-test-info-by-id *runremote* test-id))) (if tdat (begin ;; Look at the test state and status (if (or (and (member (db:test-get-status tdat) '("PASS" "WARN" "WAIVED" "CHECK" "SKIP")) @@ -481,11 +510,11 @@ ;; from the runnable list (if keep-test (for-each (lambda (waiton) ;; for now we are waiting only on the parent test (let* ((parent-test-id (rmt:get-test-id run-id waiton "")) - (wtdat (rmt:get-testinfo-state-status test-id))) ;; (cdb:get-test-info-by-id *runremote* test-id))) + (wtdat (rmt:get-testinfo-state-status run-id test-id))) ;; (cdb:get-test-info-by-id *runremote* test-id))) (if (or (and (equal? (db:test-get-state wtdat) "COMPLETED") (member (db:test-get-status wtdat) '("FAIL"))) (member (db:test-get-status wtdat) '("KILLED")) (member (db:test-get-state wtdat) '("INCOMPETE"))) ;; (if (or (member (db:test-get-status wtdat) @@ -587,12 +616,12 @@ ;; test steps ;;====================================================================== ;; teststep-set-status! used to be here -(define (test-get-kill-request test-id) ;; run-id test-name itemdat) - (let* ((testdat (rmt:get-test-info-by-id test-id))) +(define (test-get-kill-request run-id test-id) ;; run-id test-name itemdat) + (let* ((testdat (rmt:get-test-info-by-id run-id test-id))) (and testdat (equal? (test:get-state testdat) "KILLREQ")))) (define (test:tdb-get-rundat-count tdb) (if tdb @@ -603,30 +632,69 @@ tdb "SELECT count(id) FROM test_rundat;") res)) 0) -(define (tests:update-central-meta-info test-id cpuload diskfree minutes uname hostname) - (rmt:general-call 'update-cpuload-diskfree cpuload diskfree test-id) +(define (tests:update-central-meta-info run-id test-id cpuload diskfree minutes uname hostname) + (rmt:general-call 'update-cpuload-diskfree run-id cpuload diskfree test-id) (if minutes - (rmt:general-call 'update-run-duration minutes test-id)) + (rmt:general-call 'update-run-duration run-id minutes test-id)) (if (and uname hostname) - (rmt:general-call 'update-uname-host uname hostname test-id))) + (rmt:general-call 'update-uname-host run-id uname hostname test-id))) -(define (tests:set-full-meta-info test-id run-id minutes work-area) - (let* ((num-records 0) - (cpuload (get-cpu-load)) +;; This one is for running with no db access (i.e. via rmt: internally) +(define (tests:set-full-meta-info db test-id run-id minutes work-area remtries) +;; (define (tests:set-full-meta-info test-id run-id minutes work-area) +;; (let ((remtries 10)) + (let* ((cpuload (get-cpu-load)) (diskfree (get-df (current-directory))) (uname (get-uname "-srvpio")) (hostname (get-host-name))) - (tdb:update-testdat-meta-info test-id work-area cpuload diskfree minutes) - (tests:update-central-meta-info test-id cpuload diskfree minutes uname hostname))) - -(define (tests:set-partial-meta-info test-id run-id minutes work-area) + ;; (handle-exceptions + ;; exn + ;; (if (> remtries 0) + ;; (begin + ;; (set! remtries (- remtries 1)) + ;; (thread-sleep! 10) + ;; (tests:set-full-meta-info db test-id run-id minutes work-area (- remtries 1))) + ;; (let ((err-status ((condition-property-accessor 'sqlite3 'status #f) exn))) + ;; (debug:print 0 "ERROR: tried for over a minute to update meta info and failed. Giving up") + ;; (debug:print 0 "EXCEPTION: database probably overloaded or unreadable.") + ;; (debug:print 0 " message: " ((condition-property-accessor 'exn 'message) exn)) + ;; (print "exn=" (condition->list exn)) + ;; (debug:print 0 " status: " ((condition-property-accessor 'sqlite3 'status) exn)) + ;; (print-call-chain))) + ;; (let* ((num-records 0) ;; (test:tdb-get-rundat-count tdb)) + ;; (cpuload (get-cpu-load)) + ;; (diskfree (get-df (current-directory))) + ;; (uname (get-uname "-srvpio")) + ;; (hostname (get-host-name))) + ;; ;(tests:update-testdat-meta-info db test-id work-area cpuload diskfree minutes) + ;; (tests:update-central-meta-info run-id test-id cpuload diskfree minutes uname hostname) + (tests:update-central-meta-info run-id test-id cpuload diskfree minutes uname hostname))) + +;; (define (tests:set-partial-meta-info test-id run-id minutes work-area) +(define (tests:set-partial-meta-info test-id run-id minutes work-area remtries) (let* ((cpuload (get-cpu-load)) - (diskfree (get-df (current-directory)))) - (tdb:update-testdat-meta-info test-id work-area cpuload diskfree minutes))) + (diskfree (get-df (current-directory))) + (remtries 10)) + (handle-exceptions + exn + (if (> remtries 0) + (begin + (set! remtries (- remtries 1)) + (thread-sleep! 10) + (tests:set-full-meta-info db test-id run-id minutes work-area (- remtries 1))) + (let ((err-status ((condition-property-accessor 'sqlite3 'status #f) exn))) + (debug:print 0 "ERROR: tried for over a minute to update meta info and failed. Giving up") + (debug:print 0 "EXCEPTION: database probably overloaded or unreadable.") + (debug:print 0 " message: " ((condition-property-accessor 'exn 'message) exn)) + (print "exn=" (condition->list exn)) + (debug:print 0 " status: " ((condition-property-accessor 'sqlite3 'status) exn)) + (print-call-chain))) + (tests:update-testdat-meta-info db test-id work-area cpuload diskfree minutes) + ))) ;;====================================================================== ;; A R C H I V I N G ;;====================================================================== Index: tests/Makefile ================================================================== --- tests/Makefile +++ tests/Makefile @@ -1,18 +1,19 @@ # # run some tests -BINPATH=$(shell readlink -m $(PWD)/../bin) -MEGATEST=$(BINPATH)/megatest -DASHBOARD=$(BINPATH)/dashboard -PATH := $(BINPATH):$(PATH) -RUNNAME := $(shell date +w%V.%u.%H.%M) -IPADDR := "-" -# Set SERVER to "-server -" -SERVER = -DEBUG = 1 -LOGGING = +BINPATH = $(shell readlink -m $(PWD)/../bin) +MEGATEST = $(BINPATH)/megatest +DASHBOARD = $(BINPATH)/dashboard +PATH := $(BINPATH):$(PATH) +RUNNAME := $(shell date +w%V.%u.%H.%M) +IPADDR := "-" +RUNID := 1 +SERVER = +DEBUG = 1 +LOGGING = +ROWS = 20 OS = $(shell grep ID /etc/*-release|cut -d= -f2) FS = $(shell df -T .|tail -1|awk '{print $$2}') VER = $(shell fsl info|grep checkout|awk '{print $$2}'|cut -c 1-5) @@ -21,158 +22,163 @@ TARGET = "ubuntu/nfs/none" all : test1 test2 test3 test4 test5 test6 test7 test8 test9 server : - cd ..;make;make install - cd fullrun;../../bin/megatest -server - -debug 22 + cd ..;make -j;make install + cd fullrun;$(MEGATEST) -server - -debug $(DEBUG) -run-id $(RUNID) stopserver : - cd ..;make && make install + cd ..;make -j && make install cd fullrun;$(MEGATEST) -stop-server 0 repl : - cd ..;make && make install + cd ..;make -j && make install cd fullrun;$(MEGATEST) -repl test0 : cleanprep cd simplerun ; $(MEGATEST) -server - -debug $(DEBUG) test1 : cleanprep test2 : fullprep - cd fullrun;$(MEGATEST) -runtests ez_pass,runfirst/a/% -reqtarg ubuntu/nfs/none :runname $(RUNNAME) -debug $(DEBUG) $(LOGGING) - cd fullrun;megatest -runtests % -target ubuntu/nfs/none :runname $(RUNNAME)_01 -testpatt %/,%/ai -debug $(DEBUG) - cd fullrun;megatest -runtests %/,%/ai -target ubuntu/nfs/none :runname $(RUNAME)_02 -debug $(DEBUG) - cd fullrun;megatest -runtests runfirst/%,%/ai -target ubuntu/nfs/none :runname $(RUNNAME)_02 -debug $(DEBUG) + cd fullrun;$(MEGATEST) -preclean -runtests ez_pass,runfirst/a/% -reqtarg ubuntu/nfs/none :runname $(RUNNAME) -debug $(DEBUG) $(LOGGING) + cd fullrun;megatest -preclean -runtests % -target ubuntu/nfs/none :runname $(RUNNAME)_01 -testpatt %/,%/ai -debug $(DEBUG) + cd fullrun;megatest -preclean -runtests %/,%/ai -target ubuntu/nfs/none :runname $(RUNAME)_02 -debug $(DEBUG) + cd fullrun;megatest -preclean -runtests runfirst/%,%/ai -target ubuntu/nfs/none :runname $(RUNNAME)_02 -debug $(DEBUG) cd fullrun;megatest -runtests %/,%/winter -target ubuntu/nfs/none :runname $(RUNNAME)_03 -debug $(DEBUG) sleep 40;cd fullrun;megatest -target ubuntu/nfs/none :runname $(RUNNAME) -set-state-status COMPLETED,FORCED :state COMPLETED :status PASS -testpatt ez_p%s,runfirst/ -debug $(DEBUG) $(LOGGING) test3 : fullprep test3a test3b test3a : @echo Run runfirst and any waitons. - cd fullrun;$(MEGATEST) -runtests runfirst -reqtarg ubuntu/nfs/none :runname $(RUNNAME)_b + cd fullrun;$(MEGATEST) -preclean -runtests runfirst -reqtarg ubuntu/nfs/none :runname $(RUNNAME)_b test3b : @echo Run all_toplevel and all waitons - cd fullrun;$(MEGATEST) -runtests all_toplevel -reqtarg ubuntu/nfs/none :runname $(RUNNAME)_c + cd fullrun;$(MEGATEST) -preclean -runtests all_toplevel -reqtarg ubuntu/nfs/none :runname $(RUNNAME)_c test4 : cleanprep @echo "WARNING: No longer running fullprep, test converage may be lessened" - cd fullrun;time $(MEGATEST) -debug $(DEBUG) -runtests % -reqtarg ubuntu/nfs/none :runname $(RUNNAME)_b -m "This is a comment specific to a run" -v $(LOGGING) + cd fullrun;time $(MEGATEST) -debug $(DEBUG) -run-wait -runtests % -reqtarg ubuntu/nfs/none :runname $(RUNNAME)_b -m "This is a comment specific to a run" -v $(LOGGING) + +test4a : cleanprep + cd fullrun;time $(MEGATEST) -debug $(DEBUG) -preclean -runtests all_toplevel -reqtarg ubuntu/nfs/none :runname $(RUNNAME)_b -m "This is a comment specific to a run" -v $(LOGGING) # NOTE: Only one instance can be a server test5 : cleanprep @echo "WARNING: No longer running fullprep, test converage may be lessened" - cd fullrun;sleep 0;$(MEGATEST) -runtests % -target $(TARGET) :runname $(RUNNAME)_aa -debug $(DEBUG) $(LOGGING) > aa.log 2> aa.log & - cd fullrun;sleep 0;$(MEGATEST) -runtests % -target $(TARGET) :runname $(RUNNAME)_ab -debug $(DEBUG) $(LOGGING) > ab.log 2> ab.log & - cd fullrun;sleep 5;$(MEGATEST) -runtests % -target $(TARGET) :runname $(RUNNAME)_ac -debug $(DEBUG) $(LOGGING) > ac.log 2> ac.log & - cd fullrun;sleep 8;$(MEGATEST) -runtests % -target $(TARGET) :runname $(RUNNAME)_ad -debug $(DEBUG) $(LOGGING) > ad.log 2> ad.log & -# cd fullrun;sleep 0;$(MEGATEST) -runtests % -target $(TARGET) :runname $(RUNNAME)_ae -debug $(DEBUG) $(LOGGING) > ae.log 2> ae.log & -# cd fullrun;sleep 0;$(MEGATEST) -runtests % -target $(TARGET) :runname $(RUNNAME)_af -debug $(DEBUG) $(LOGGING) > af.log 2> af.log & a + cd fullrun;sleep 0;$(MEGATEST) -preclean -runtests % -target $(TARGET) :runname $(RUNNAME)_aa -debug $(DEBUG) $(LOGGING) > aa.log 2> aa.log & + cd fullrun;sleep 0;$(MEGATEST) -preclean -runtests % -target $(TARGET) :runname $(RUNNAME)_ab -debug $(DEBUG) $(LOGGING) > ab.log 2> ab.log & + cd fullrun;sleep 5;$(MEGATEST) -preclean -runtests % -target $(TARGET) :runname $(RUNNAME)_ac -debug $(DEBUG) $(LOGGING) > ac.log 2> ac.log & + cd fullrun;sleep 8;$(MEGATEST) -preclean -runtests % -target $(TARGET) :runname $(RUNNAME)_ad -debug $(DEBUG) $(LOGGING) > ad.log 2> ad.log & +# cd fullrun;sleep 0;$(MEGATEST) -preclean -runtests % -target $(TARGET) :runname $(RUNNAME)_ae -debug $(DEBUG) $(LOGGING) > ae.log 2> ae.log & +# cd fullrun;sleep 0;$(MEGATEST) -preclean -runtests % -target $(TARGET) :runname $(RUNNAME)_af -debug $(DEBUG) $(LOGGING) > af.log 2> af.log & # MUST ADD THIS BACK IN ASAP!!!! # cd fullrun;sleep 10;$(MEGATEST) -run-wait -target $(TARGET) :runname % -testpatt % :state RUNNING,LAUNCHED,NOT_STARTED,REMOTEHOSTSTART;echo ALL DONE test6: fullprep - cd fullrun;$(MEGATEST) -runtests runfirst -testpatt %/1 -reqtarg ubuntu/nfs/none :runname $(RUNNAME)_itempatt -v - cd fullrun;$(MEGATEST) -runtests runfirst -testpatt %blahha% -reqtarg ubuntu/nfs/none :runname $(RUNNAME)_itempatt -debug 10 + cd fullrun;$(MEGATEST) -preclean -runtests runfirst -testpatt %/1 -reqtarg ubuntu/nfs/none :runname $(RUNNAME)_itempatt -v + cd fullrun;$(MEGATEST) -preclean -runtests runfirst -testpatt %blahha% -reqtarg ubuntu/nfs/none :runname $(RUNNAME)_itempatt -debug 10 cd fullrun;$(MEGATEST) -rollup :runname newrun -target ubuntu/nfs/none -debug 10 test7: @echo Only a/c testname c should remain. If there is a run a/b/c then there is a cache issue. + cd simplerun;$(DASHBOARD) & (cd simplerun; \ $(MEGATEST) -server - -daemonize; \ $(MEGATEST) -remove-runs -target %/% :runname % -testpatt %; \ - $(MEGATEST) -runtests % -target a/b :runname c; sleep 5; \ + $(MEGATEST) -preclean -runtests % -target a/b :runname c; sleep 5; \ $(MEGATEST) -remove-runs -target a/c :runname c; \ - $(MEGATEST) -runtests % -target a/c :runname c; \ + $(MEGATEST) -preclean -runtests % -target a/c :runname c; \ $(MEGATEST) -remove-runs -target a/b :runname c -testpatt % ; \ - $(MEGATEST) -runtests % -target a/d :runname c;$(MEGATEST) -list-runs %|egrep ^Run:) > test7.log 2> test7.log + $(MEGATEST) -preclean -runtests % -target a/d :runname c;$(MEGATEST) -list-runs %|egrep ^Run:) > test7.log 2> test7.log logpro test7.logpro test7.html < test7.log @echo @echo Run \"firefox test7.html\" to see the results. # This one failed with v1.55 test8a : - cd fullrun;$(MEGATEST) -runtests priority_10_waiton_1 -target ubuntu/nfs/none :runname $(RUNNAME)_waiton_single + cd fullrun;$(MEGATEST) -preclean -runtests priority_10_waiton_1 -target ubuntu/nfs/none :runname $(RUNNAME)_waiton_single test8 : test8a - cd fullrun;$(MEGATEST) -runtests lineitem_fail 1 -target ubuntu/nfs/none :runname $(RUNNAME)_singletest - cd fullrun;$(MEGATEST) -runtests runfirst/fall 1 -target ubuntu/nfs/none :runname $(RUNNAME)_singleitem - cd fullrun;$(MEGATEST) -runtests test_mt_vars/2 -target ubuntu/nfs/none :runname $(RUNNAME)_singleitem_waiton + cd fullrun;$(MEGATEST) -preclean -runtests lineitem_fail 1 -target ubuntu/nfs/none :runname $(RUNNAME)_singletest + cd fullrun;$(MEGATEST) -preclean -runtests runfirst/fall 1 -target ubuntu/nfs/none :runname $(RUNNAME)_singleitem + cd fullrun;$(MEGATEST) -preclean -runtests test_mt_vars/2 -target ubuntu/nfs/none :runname $(RUNNAME)_singleitem_waiton # Some simple checks for bootstrapping and run loop logic test9 : minsetup test9a test9b test9c test9d test9e test9a : @echo Run super-simple mintest e, no waitons. - cd mintest;$(MEGATEST) -runtests e -target $(VER) :runname `date +%H.%M.%S` -debug $(DEBUG) + cd mintest;$(DASHBOARD)& + cd mintest;$(MEGATEST) -preclean -runtests e -target $(VER) :runname `date +%H.%M.%S` -debug $(DEBUG) test9b : @echo Run simple mintest d with one waiton c - cd mintest;$(MEGATEST) -runtests d -target $(VER) :runname `date +%H.%M.%S` -debug $(DEBUG) + cd mintest;$(MEGATEST) -preclean -runtests d -target $(VER) :runname `date +%H.%M.%S` -debug $(DEBUG) test9c : @echo Run mintest a with full waiton chain a -> b -> c -> d -> e - cd mintest;$(MEGATEST) -runtests a -target $(VER) :runname `date +%H.%M.%S` -debug $(DEBUG) + cd mintest;$(MEGATEST) -preclean -runtests a -target $(VER) :runname `date +%H.%M.%S` -debug $(DEBUG) test9d : @echo Run an itemized test with no items - cd mintest;$(MEGATEST) -runtests g -target $(VER) :runname `date +%H.%M.%S` -debug $(DEBUG) + cd mintest;$(MEGATEST) -preclean -runtests g -target $(VER) :runname `date +%H.%M.%S` -debug $(DEBUG) test9e : @echo Run mintest a1 with full waiton chain with d1fail: a1 -> b1 -> c1 -> d1fail -> e1 - cd mintest;$(MEGATEST) -runtests a1 -target $(VER) :runname `date +%H.%M.%S` -debug $(DEBUG) + cd mintest;$(MEGATEST) -preclean -runtests a1 -target $(VER) :runname `date +%H.%M.%S` -debug $(DEBUG) test10 : @echo Run a bunch of different targets simultaneously (cd fullrun;$(MEGATEST) -server - ;sleep 2)& for targ in mint/btrfs/mintdir sunos/sshfs/loc; do \ - (cd fullrun;$(MEGATEST) -runtests priority_10_waiton_1 -target $$targ :runname $(RUNNAME) &); done + (cd fullrun;$(MEGATEST) -preclean -runtests priority_10_waiton_1 -target $$targ :runname $(RUNNAME) &); done for sys in ubuntu suse redhat debian;do \ for fs in afs nfs zfs; do \ for dpath in none tmp; do \ - (cd fullrun;$(MEGATEST) -runtests priority_10_waiton_1 -target $$sys/$$fs/$$dpath :runname $(RUNNAME) &);\ + (cd fullrun;$(MEGATEST) -preclean -runtests priority_10_waiton_1 -target $$sys/$$fs/$$dpath :runname $(RUNNAME) &);\ done;done;done test11 : cd fullrun;time (for a in 1 2 3 4 5 6 7 8 9 10 1 2 3 4 5 6 7 8 9 10 1 2 3 4 5 6 7 8 9 10 1 2 3 4 5 6 7 8 9 10 ;do (megatest -test-paths -target %/%/% > /dev/null ) & done; wait; ) minsetup : - cd ..;make && make install + cd ..;make -j && make install mkdir -p mintest/runs mintest/links cd mintest;$(MEGATEST) -stop-server 0 cd mintest;$(MEGATEST) -server - -debug $(DEBUG) > server.log 2> server.log & sleep 3 cd mintest;$(DASHBOARD) -rows 18 & cleanprep : ../*.scm Makefile */*.config mkdir -p fullrun/tmp/mt_runs fullrun/tmp/mt_links - cd ..;make;make install + cd ..;make -j;make install rm -f */logging.db touch cleanprep fullprep : cleanprep cd fullrun;$(MEGATEST) -remove-runs :runname $(RUNNAME)% -target %/%/% -testpatt %/% cd fullrun;$(BINPATH)/dashboard -rows 15 & dashboard : cleanprep - cd fullrun && $(BINPATH)/dashboard -rows 20 & + cd fullrun && $(BINPATH)/dashboard -rows $(ROWS) & remove : cd fullrun;$(MEGATEST) -remove-runs :runname $(RUN) -testpatt % -itempatt % :sysname % :fsname % :datapath % clean : rm cleanprep kill : killall -v mtest main.sh dboard || true - rm -rf */megatest.db */logging.db */monitor.db fullrun/tmp/mt_*/* || true + rm -rf *run/db/* */megatest.db */logging.db */monitor.db fullrun/tmp/mt_*/* fullrun/tmp/mt_*/.db* fullrun/logs/*.log || true killall -v mtest dboard || true hardkill : kill sleep 2;killall -v mtest main.sh dboard -9 Index: tests/fdktestqa/fdk.config ================================================================== --- tests/fdktestqa/fdk.config +++ tests/fdktestqa/fdk.config @@ -2,11 +2,32 @@ SYSTEM TEXT RELEASE TEXT [setup] # Adjust max_concurrent_jobs to limit how much you load your machines -max_concurrent_jobs 150 +# max_concurrent_jobs 150 +max_concurrent_jobs 1000 # This is your link path, you can move it but it is generally better to keep it stable -linktree #{shell readlink -f #{getenv PWD}/../simplelinks} +linktree #{shell readlink -f #{getenv MT_RUN_AREA_HOME}/../simplelinks} [include testqa/configs/megatest.abc.config] + +# timeout 0.025 + +[jobtools] +maxload 4 +launcher nbfake + +[server] +# timeout 0.01 +# homehost xena +# homehost 143.182.225.38 + +# force server +server-query-threshold 0 + + +[jobtools] +# launcher nbq -P ch_vp -C SLES11_EM64T_4G -Q /ciaf/fdk +# launcher nbfake +# maxload 4 Index: tests/fdktestqa/testqa/Makefile ================================================================== --- tests/fdktestqa/testqa/Makefile +++ tests/fdktestqa/testqa/Makefile @@ -1,29 +1,34 @@ BINDIR = $(PWD)/../../../bin PATH := $(BINDIR):$(PATH) MEGATEST = $(BINDIR)/megatest DASHBOARD = $(BINDIR)/dashboard +RUNNAME = a + + all : $(MEGATEST) -remove-runs -target a/b :runname c -testpatt %/% $(MEGATEST) -runtests % -target a/b :runname c bigbig : - $(MEGATEST) -server - -daemonize ; sleep 3 for tn in a b c d;do \ ($(MEGATEST) -runtests % -target a/b :runname $tn & ) ; \ done bigrun : - $(MEGATEST) -runtests bigrun -target a/bigrun :runname a + $(MEGATEST) -runtests bigrun -target a/bigrun :runname a$(shell date +%V) bigrun2 : - $(MEGATEST) -runtests bigrun2 -target a/bigrun2 :runname a -transport http + $(MEGATEST) -runtests bigrun2 -target a/bigrun2 :runname a$(shell date +%V) + +bigrun3 : + $(MEGATEST) -runtests bigrun3 -target a/bigrun3 :runname $(RUNNAME) dashboard : $(DASHBOARD) -rows 20 & compile : - $(MEGATEST) -stop-server 0 - (cd ../../..;make && make install) + (cd ../../..;make -j && make install) clean : - rm -rf ../simple*/*/* megatest.db + rm -rf ../simple*/*/* megatest.db db/* ../simple*/.db/* logs/* monitor.db + Index: tests/fdktestqa/testqa/configs/megatest.abc.config ================================================================== --- tests/fdktestqa/testqa/configs/megatest.abc.config +++ tests/fdktestqa/testqa/configs/megatest.abc.config @@ -2,9 +2,8 @@ [validvalues] state start end completed # Job tools are more advanced ways to control how your jobs are launched [jobtools] -useshell yes -launcher nbfake +# useshell yes [include megatest.def.config] Index: tests/fdktestqa/testqa/configs/megatest.def.config ================================================================== --- tests/fdktestqa/testqa/configs/megatest.def.config +++ tests/fdktestqa/testqa/configs/megatest.def.config @@ -2,7 +2,7 @@ [env-override] EXAMPLE_VAR example value # As you run more tests you may need to add additional disks, the names are arbitrary but must be unique [disks] -disk0 #{scheme (nice-path "#{getenv PWD}/../simpleruns")} +disk0 #{scheme (nice-path "#{getenv MT_RUN_AREA_HOME}/../simpleruns")} Index: tests/fdktestqa/testqa/megatest.config ================================================================== --- tests/fdktestqa/testqa/megatest.config +++ tests/fdktestqa/testqa/megatest.config @@ -1,10 +1,9 @@ [setup] testcopycmd cp --remove-destination -rlv TEST_SRC_PATH/. TEST_TARG_PATH/. >> TEST_TARG_PATH/mt_launch.log 2>> TEST_TARG_PATH/mt_launch.log -runqueue 20 -transport http -launchwait no +# launchwait no + +[jobtools] +launcher nbfake [include ../fdk.config] -[server] -port 9080 Index: tests/fdktestqa/testqa/tests/bigrun/step1.sh ================================================================== --- tests/fdktestqa/testqa/tests/bigrun/step1.sh +++ tests/fdktestqa/testqa/tests/bigrun/step1.sh @@ -1,9 +1,13 @@ -#!/bin/sh -if [ $NUMBER -lt 15 ];then - sleep 2 - sleep `echo 2 * $NUMBER | bc` +#!/bin/bash +if [ $NUMBER -lt 10 ];then + sleep 20 + sleep `echo 4 * $NUMBER | bc` else - sleep 100 + sleep 130 fi -exit 0 +if [[ $RANDOM -lt 10000 ]];then + exit 1 +else + exit 0 +fi Index: tests/fdktestqa/testqa/tests/bigrun/testconfig ================================================================== --- tests/fdktestqa/testqa/tests/bigrun/testconfig +++ tests/fdktestqa/testqa/tests/bigrun/testconfig @@ -1,8 +1,11 @@ # Add additional steps here. Format is "stepname script" +[vars] +step1var step1.sh + [ezsteps] -step1 step1.sh +step1 #{get vars step1var} # Test requirements are specified here [requirements] # waiton setup priority 0 Index: tests/fdktestqa/testqa/tests/bigrun2/testconfig ================================================================== --- tests/fdktestqa/testqa/tests/bigrun2/testconfig +++ tests/fdktestqa/testqa/tests/bigrun2/testconfig @@ -5,15 +5,19 @@ # Test requirements are specified here [requirements] waiton bigrun priority 0 mode itemwait - +itemmap .*/ # Iteration for your tests are controlled by the items section [items] -NUMBER #{scheme (string-intersperse (map number->string (sort (let loop ((a 0)(res '()))(if (<= a (or (any->number (get-environment-variable "NUMTESTS")) 2500))(loop (+ a 1)(cons a res)) res)) <)) " ")} +NUMBER #{scheme (string-intersperse (map (lambda (x)(conc "blah/" x)) \ + (map number->string (sort (let loop ((a 0)(res '())) \ + (if (<= a (or (any->number (get-environment-variable "NUMTESTS")) 2500)) \ + (loop (+ a 1)(cons a res)) res)) <))) " ")} + # test_meta is a section for storing additional data on your test [test_meta] author matt owner matt Index: tests/fdktestqa/testqa/tests/bigrun3/testconfig ================================================================== --- tests/fdktestqa/testqa/tests/bigrun3/testconfig +++ tests/fdktestqa/testqa/tests/bigrun3/testconfig @@ -5,15 +5,18 @@ # Test requirements are specified here [requirements] waiton bigrun2 priority 0 mode itemwait - +itemmap .*/ # Iteration for your tests are controlled by the items section [items] -NUMBER #{scheme (string-intersperse (map number->string (sort (let loop ((a 0)(res '()))(if (<= a (or (any->number (get-environment-variable "NUMTESTS")) 2500))(loop (+ a 1)(cons a res)) res)) <)) " ")} +NUMBER #{scheme (string-intersperse (map (lambda (x)(conc "blah/" x)) \ + (map number->string (sort (let loop ((a 0)(res '())) \ + (if (<= a (or (any->number (get-environment-variable "NUMTESTS")) 2500)) \ + (loop (+ a 1)(cons a res)) res)) <))) " ")} # test_meta is a section for storing additional data on your test [test_meta] author matt owner matt Index: tests/fullrun/megatest.config ================================================================== --- tests/fullrun/megatest.config +++ tests/fullrun/megatest.config @@ -8,10 +8,15 @@ [refareas] area1 /tmp/oldarea/megatest [include ./configs/mt_include_1.config] +[dashboard] +pre-command xterm -geometry 180x20 -e " +post-command |& tee results.log ;echo Press any key to continue;bash -c 'read -n 1 -s'" & +testsort -event_time + [misc] home #{shell readlink -f $MT_RUN_AREA_HOME} parent #{shell readlink -f $MT_RUN_AREA_HOME/..} [tests-paths] @@ -20,13 +25,18 @@ [setup] # Set launchwait to no to use the more agressive code that does not wait for the launch to complete before proceeding # this may save a few milliseconds on launching tests # launchwait no waivercommentpatt ^WW\d+ [a-z].* +incomplete-timeout 1 + +# yes, anything else is no +run-wait yes + # Use http instead of direct filesystem access -transport http +# transport http # transport fs # If set to "default" the old code is used. Otherwise defaults to 200 or uses # numeric value given. # @@ -70,17 +80,27 @@ # override the html viewer launch command # # htmlviewercmd firefox -new-window htmlviewercmd konqueror +# -runtests automatically deletes the records for tests with the listed states on starting up a run allowing them to re-run +# (nb// this is in addition to NOT_STARTED which is automatically re-run) +# +allow-auto-rerun INCOMPLETE ZERO_ITEMS +# could add: STUCK STUCK/DEAD UNKNOWN KILLED KILLREQ PREQ_DISCARD + [validvalues] state start end 0 1 - 2 status pass fail n/a 0 1 running - 2 # These are set before all tests, override them # in the testconfig [pre-launch-env-overrides] section [env-override] + +# This variable is honored by the loadrunner script. The value is in percent +MAX_ALLOWED_LOAD 200 + # MT_XTERM_CMD overrides the terminal command # MT_XTERM_CMD xterm -bg lightgreen -fg black SPECIAL_ENV_VARS overide them here - should be seen at launch and in the runs TESTVAR [system readlink -f .] @@ -99,10 +119,11 @@ WRAPPEDVAR This var should have the work blah thrice: \ blah \ blah +MAX_ALLOWED_LOAD 200 # XTERM [system xterm] # RUNDEAD [system exit 56] [server] @@ -110,16 +131,33 @@ # it succeeds port 8080 # This server will keep running this number of hours after last access. # Three minutes is 0.05 hours -timeout 0.025 +# timeout 0.025 +timeout 0.01 + +# daemonize yes +# hostname #{scheme (get-host-name)} ## disks are: ## name host:/path/to/area ## -or- ## name /path/to/area [disks] disk0 /foobarbazz +disk1 not-a-disk + [include ./configs/mt_include_2.config] [include #{getenv USER}_testing.config] + +[jobgroups] + +# NOTE: job groups will falsely count the toplevel test as a job. If possible add N +# to your jobgroups where N is the number of parallel runs you are likely to see +# +sqlite3 6 +blockz 10 +# to your jobgroups where N is the number of parallel runs you are likely to see +# + Index: tests/fullrun/tests/blocktestxz/testconfig ================================================================== --- tests/fullrun/tests/blocktestxz/testconfig +++ tests/fullrun/tests/blocktestxz/testconfig @@ -16,5 +16,7 @@ that a test will never be run and thus remove it from\ the queue of tests to be run. tags first,single reviewed 1/1/1965 + +jobgroup blockz Index: tests/fullrun/tests/priority_1/testconfig ================================================================== --- tests/fullrun/tests/priority_1/testconfig +++ tests/fullrun/tests/priority_1/testconfig @@ -3,10 +3,11 @@ [requirements] priority 1 [test_meta] +jobgroup sqlite3 author matt owner bob description This test checks that a multi-lineitem test with mix of pass and non-fail rolls up a PASS tags first,single Index: tests/fullrun/tests/priority_2/testconfig ================================================================== --- tests/fullrun/tests/priority_2/testconfig +++ tests/fullrun/tests/priority_2/testconfig @@ -5,10 +5,11 @@ priority 2 # runtimelim 1d 1h 1m 10s runtimelim 20s [test_meta] +jobgroup sqlite3 author matt owner bob description This test checks that a multi-lineitem test with mix of pass and non-fail rolls up a PASS tags first,single Index: tests/fullrun/tests/priority_3/testconfig ================================================================== --- tests/fullrun/tests/priority_3/testconfig +++ tests/fullrun/tests/priority_3/testconfig @@ -4,10 +4,11 @@ [requirements] priority 3 [test_meta] +jobgroup sqlite3 author matt owner bob description This test checks that a multi-lineitem test with mix of pass and non-fail rolls up a PASS tags first,single Index: tests/fullrun/tests/priority_4/testconfig ================================================================== --- tests/fullrun/tests/priority_4/testconfig +++ tests/fullrun/tests/priority_4/testconfig @@ -3,10 +3,11 @@ [requirements] priority 4 [test_meta] +jobgroup sqlite3 author matt owner bob description This test checks that a multi-lineitem test with mix of pass and non-fail rolls up a PASS tags first,single Index: tests/fullrun/tests/sqlitespeed/testconfig ================================================================== --- tests/fullrun/tests/sqlitespeed/testconfig +++ tests/fullrun/tests/sqlitespeed/testconfig @@ -7,5 +7,7 @@ [items] MANYITEMS [system (env > envfile.txt;echo aa ab ac ad ae af ag ah ai)] # BORKED +[test_meta] +jobgroup sqlite3 Index: tests/fullrun/tests/test_mt_vars/currentisblah.sh ================================================================== --- tests/fullrun/tests/test_mt_vars/currentisblah.sh +++ tests/fullrun/tests/test_mt_vars/currentisblah.sh @@ -1,3 +1,3 @@ #!/usr/bin/env bash -grep CURRENT megatest.sh | grep /tmp/nada +grep -e '^export CURRENT' megatest.sh | grep /tmp/nada Index: tests/rununittest.sh ================================================================== --- tests/rununittest.sh +++ tests/rununittest.sh @@ -1,14 +1,17 @@ #!/bin/bash # Usage: rununittest.sh testname debuglevel # +# Ensure all is made +(cd ..;make && make install) + # Clean setup # rm -f simplerun/megatest.db simplerun/monitor.db simplerun/db/monitor.db -rm -rf simplelinks/ simpleruns/ +rm -rf simplelinks/ simpleruns/ simplerun/db/ mkdir -p simplelinks simpleruns (cd simplerun;cp ../../*_records.scm .;perl -pi.bak -e 's/define-inline/define/' *_records.scm) # Run the test $1 is the unit test to run cd simplerun;echo '(load "../tests.scm")' | ../../bin/megatest -repl -debug $2 $1 ADDED tests/simplerun/tests/test2/step1.sh Index: tests/simplerun/tests/test2/step1.sh ================================================================== --- /dev/null +++ tests/simplerun/tests/test2/step1.sh @@ -0,0 +1,3 @@ +#!/usr/bin/env bash + +# Run your step here DELETED tests/simplerun/tests/test2/step1.sh.sh Index: tests/simplerun/tests/test2/step1.sh.sh ================================================================== --- tests/simplerun/tests/test2/step1.sh.sh +++ /dev/null @@ -1,3 +0,0 @@ -#!/usr/bin/env bash - -# Run your step here ADDED tests/simplerun/tests/test2/step2.sh Index: tests/simplerun/tests/test2/step2.sh ================================================================== --- /dev/null +++ tests/simplerun/tests/test2/step2.sh @@ -0,0 +1,3 @@ +#!/usr/bin/env bash + +# Run your step here DELETED tests/simplerun/tests/test2/step2.sh.sh Index: tests/simplerun/tests/test2/step2.sh.sh ================================================================== --- tests/simplerun/tests/test2/step2.sh.sh +++ /dev/null @@ -1,3 +0,0 @@ -#!/usr/bin/env bash - -# Run your step here ADDED tests/stats.txt Index: tests/stats.txt ================================================================== --- /dev/null +++ tests/stats.txt @@ -0,0 +1,77 @@ +DB Stats: a1236d6bf92ec5cb8955f490761b21b0d3eea9d3 +======== +Cmd Count TotTime Avg +get-count-tests-running-for-run-id 1035 237.0 0.23 +get-count-tests-running-in-jobgroup 884 119.0 0.13 +get-count-tests-running 884 169.0 0.19 +get-prereqs-not-met 884 732.0 0.83 +get-test-info-by-id 673 122.0 0.18 +get-keys 476 1.0 0.00 +get-test-id 356 42.0 0.12 +testmeta-get-record 203 24.0 0.12 +roll-up-pass-fail-counts 159 39.0 0.25 +register-test 140 30.0 0.21 +test-set-rundir-shortdir 128 98.0 0.77 +test-set-status-state 94 45.0 0.48 +find-and-mark-incomplete 32 0.0 0.00 +state-status-msg 25 4.0 0.16 +delete-tests-in-state 12 4.0 0.33 +get-tests-for-run-mindata 8 0.0 0.00 +get-all-run-ids 5 2.0 0.40 +get-run-info 4 0.0 0.00 +register-run 4 5.0 1.25 +set-tests-state-status 4 15.0 3.75 +get-tests-for-run 4 15.0 3.75 + +# After converting first three functions above to sqlite3:first-result +DB Stats +======== +Cmd Count TotTime Avg +get-count-tests-running-for-run-id 1138 179.0 0.16 +get-count-tests-running-in-jobgroup 987 91.0 0.09 +get-count-tests-running 987 171.0 0.17 +get-prereqs-not-met 987 892.0 0.90 +get-test-info-by-id 672 95.0 0.14 +get-keys 476 0.0 0.00 +get-test-id 355 41.0 0.12 +testmeta-get-record 203 15.0 0.07 +roll-up-pass-fail-counts 159 30.0 0.19 +register-test 140 22.0 0.16 +test-set-rundir-shortdir 128 855.0 6.68 +test-set-status-state 94 20.0 0.21 +find-and-mark-incomplete 36 1.0 0.03 +state-status-msg 24 5.0 0.21 +delete-tests-in-state 12 2.0 0.17 +get-tests-for-run-mindata 9 0.0 0.00 +get-all-run-ids 5 1.0 0.20 +register-run 4 1.0 0.25 +get-tests-for-run 4 11.0 2.75 +get-run-info 4 0.0 0.00 +set-tests-state-status 4 17.0 4.25 + +DB Stats another run, converted one or two non-relevant functions to sqlite3:first-result +======== +Cmd Count TotTime Avg +get-count-tests-running-for-run-id 987 157.0 0.16 +get-count-tests-running-in-jobgroup 836 79.0 0.09 +get-count-tests-running 836 121.0 0.14 +get-prereqs-not-met 836 513.0 0.61 +get-test-info-by-id 673 85.0 0.13 +get-keys 476 0.0 0.00 +get-test-id 356 32.0 0.09 +testmeta-get-record 203 19.0 0.09 +roll-up-pass-fail-counts 159 27.0 0.17 +register-test 140 23.0 0.16 +test-set-rundir-shortdir 128 35.0 0.27 +test-set-status-state 94 20.0 0.21 +find-and-mark-incomplete 40 0.0 0.00 +state-status-msg 25 5.0 0.20 +delete-tests-in-state 12 1.0 0.08 +get-tests-for-run-mindata 10 0.0 0.00 +get-all-run-ids 5 0.0 0.00 +set-tests-state-status 4 15.0 3.75 +register-run 4 2.0 0.50 +get-run-info 4 1.0 0.25 +get-tests-for-run 4 12.0 3.00 + + Index: tests/tests.scm ================================================================== --- tests/tests.scm +++ tests/tests.scm @@ -31,6 +31,10 @@ (let* ((unit-test-name (list-ref (argv) 4)) (fname (conc "../unittests/" unit-test-name ".scm"))) (if (file-exists? fname) (load fname) (print "ERROR: Unit test " unit-test-name " not found in unittests directory"))) + (list "abc" "abc/%" "ab%/c%" "~abc/c%" "abc/~c%" "a,b/c,%/d" "%/,%/a" "%/,%/a" "%/,%/a" "%" "%" "%/" "%/" "%abc%") + (list "abc" "abc" "abcd" "abc" "abc" "a" "abc" "def" "ghi" "a" "a" "a" "a" "abc") + (list "" "" "cde" "cde" "cde" "" "" "a" "b" "" "b" "" "b" "abc") + (list #t #t #t #f #f #t #t #t #f #t #t #t #f #t)) ADDED tests/unittests/basicserver.scm Index: tests/unittests/basicserver.scm ================================================================== --- /dev/null +++ tests/unittests/basicserver.scm @@ -0,0 +1,114 @@ +;;====================================================================== +;; S E R V E R +;;====================================================================== + +;; Run like this: +;; +;; (cd ..;make && make install) && ./rununittest.sh server 1;(cd simplerun;megatest -stop-server 0) + +(set! *transport-type* 'http) + +(test "setup for run" #t (begin (setup-for-run) + (string? (getenv "MT_RUN_AREA_HOME")))) + +(test "server-register, get-best-server" #t (let ((res #f)) + (open-run-close tasks:server-register tasks:open-db 1 "bob" 1234 100 'live 'http) + (set! res (open-run-close tasks:get-best-server tasks:open-db)) + (number? (vector-ref res 3)))) + +(test "de-register server" #f (let ((res #f)) + (open-run-close tasks:server-deregister tasks:open-db "bob" port: 1234) + (vector? (open-run-close tasks:get-best-server tasks:open-db)))) + +(define server-pid #f) + +;; Not sure how the following should work, replacing it with system of megatest -server +;; (test "launch server" #t (let ((pid (process-fork (lambda () +;; ;; (daemon:ize) +;; (server:launch 'http))))) +;; (set! server-pid pid) +;; (number? pid))) +(system "../../bin/megatest -server - -debug 22 > server.log 2> server.log &") + +(let loop ((n 10)) + (thread-sleep! 1) ;; need to wait for server to start. + (let ((res (open-run-close tasks:get-best-server tasks:open-db))) + (print "tasks:get-best-server returned " res) + (if (and (not res) + (> n 0)) + (loop (- n 1))))) + +(test "get-best-server" #t (begin + (client:launch) + (let ((dat (open-run-close tasks:get-best-server tasks:open-db))) + (vector? dat)))) + +(define *keys* (keys:config-get-fields *configdat*)) +(define *keyvals* (keys:target->keyval *keys* "a/b/c")) + +(test #f #t (string? (car *runremote*))) +(test #f '(#t "successful login") (rmt:login)) ;; *runremote* *toppath* *my-client-signature*))) + +(test #f #f (rmt:get-test-info-by-id 99)) ;; get non-existant test + +;; RUNS +(test #f 1 (rmt:register-run *keyvals* "firstrun" "new" "n/a" (current-user-name))) +(test "get run info" "firstrun" (let ((rinfo (rmt:get-run-info 1))) + (vector-ref (vector-ref rinfo 1) 3))) +(test "get runname from id" "firstrun" (rmt:get-run-name-from-id 1)) + +;; TESTS +(test "get tests (no data)" '() (rmt:get-tests-for-run 1 "%" '() '() #f #f #f #f #f #f)) +(test "register test" #t (rmt:general-call 'register-test 1 "test1" "")) +(test "get tests (some data)" 1 (length (rmt:get-tests-for-run 1 "%" '() '() #f #f #f #f #f #f))) +(test "get test id" 1 (rmt:get-test-id 1 "test1" "")) +(test "sync back" #t (> (rmt:sync-inmem->db) 0)) +(test "get test id from main" 1 (db:get-test-id *db* 1 "test1" "")) +(test "get keys" #t (list? (rmt:get-keys))) +(test "set comment" #t (begin (rmt:general-call 'set-test-comment "this is a comment" 1) #t)) +(test "get comment" "this is a comment" (let ((trec (rmt:get-test-info-by-id 1))) + (db:test-get-comment trec))) + +;; MORE RUNS +(test "get runs" #t (let* ((runs (rmt:get-runs "%" #f #f '())) + (header (vector-ref runs 0)) + (data (vector-ref runs 1))) + (and (list? header) + (list? data) + (vector? (car data))))) + +(test "get local testinfo" "test1" (vector-ref (db:get-testinfo-state-status *db* 1) 2)) +(test "get testinfo" "test1" (vector-ref (rmt:get-testinfo-state-status 1) 2)) + +;;====================================================================== +;; D B +;;====================================================================== + +(test "pass fail counts" #t (rmt:general-call 'pass-fail-counts 10 9 1)) +(test "get pass fail counts" 19 (let ((dat (rmt:get-test-info-by-id 1))) + (+ (db:test-get-pass_count dat) + (db:test-get-fail_count dat)))) + +(define testregistry (make-hash-table)) +(for-each + (lambda (tname) + (for-each + (lambda (itempath) + (let ((tkey (conc tname "/" itempath)) + (rpass (random 10)) + (rfail (random 10))) + (hash-table-set! testregistry tkey (list tname itempath)) + (rmt:general-call 'register-test 1 tname itempath) + (let* ((tid (rmt:get-test-id 1 tname itempath)) + (tdat (rmt:get-test-info-by-id tid))) + (rmt:general-call 'pass-fail-counts rpass rfail (db:test-get-id tdat)) + (let* ((resdat (rmt:get-test-info-by-id tid))) + (test "set/get pass fail counts" (list rpass rfail) + (list (db:test-get-pass_count resdat) + (db:test-get-fail_count resdat))))))) + (list "" "a" "b" "c" "d" "e" "f" "g" "h" "i" "j"))) + (list "test1" "test2" "test3" "test4" "test5")) + + +(test #f '(#t "exit process started") (rmt:kill-server)) ;; *toppath* *my-client-signature* #f))) + ADDED tests/unittests/dbrdbstruct.scm Index: tests/unittests/dbrdbstruct.scm ================================================================== --- /dev/null +++ tests/unittests/dbrdbstruct.scm @@ -0,0 +1,33 @@ +;;====================================================================== +;; S E R V E R +;;====================================================================== + +;; Run like this: +;; +;; (cd ..;make && make install) && ./rununittest.sh server 1;(cd simplerun;megatest -stop-server 0) + +(test #f #t (vector? (make-dbr:dbstruct "/tmp"))) + +(define dbstruct (make-dbr:dbstruct "/tmp")) + +(test #f #t (begin (dbr:dbstruct-set-main! dbstruct "blah") #t)) +(test #f "blah" (dbr:dbstruct-get-main dbstruct)) +(for-each + (lambda (run-id) + (test #f #t (vector? (dbr:dbstruct-get-rundb-rec dbstruct run-id)))) + (list 1 2 3 4 5 6 7 8 9 #f)) + +(test #f 0 (dbr:dbstruct-field-name->num 'rundb)) +(test #f 1 (dbr:dbstruct-field-name->num 'inmem)) +(test #f 2 (dbr:dbstruct-field-name->num 'mtime)) + +(test #f #f (dbr:dbstruct-get-runvec-val dbstruct 1 'rundb)) +(test #f #t (begin (dbr:dbstruct-set-runvec-val! dbstruct 1 'rundb "rundb") #t)) +(test #f "rundb" (dbr:dbstruct-get-runvec-val dbstruct 1 'rundb)) + +(for-each + (lambda (k) + (test #f #t (begin (dbr:dbstruct-set-runvec-val! dbstruct 1 k (conc k)) #t)) + (test #f (conc k) (dbr:dbstruct-get-runvec-val dbstruct 1 k))) + '(rundb inmem mtime rtime stime inuse)) + Index: tests/unittests/inmemdb.scm ================================================================== --- tests/unittests/inmemdb.scm +++ tests/unittests/inmemdb.scm @@ -23,11 +23,11 @@ (define *keyvals* (keys:target->keyval *keys* "a/b/c")) (test #f #t (string? (car *runremote*))) (test #f '(#t "successful login") (rmt:login)) ;; *runremote* *toppath* *my-client-signature*))) -(define inmem (open-in-mem-db)) +(define inmem (db:open-inmem-db)) (define (inmem-test t b) (test "inmem sync to" t (db:sync-to *db* inmem)) (test "inmem sync back" b (db:sync-to inmem *db*))) Index: tests/unittests/server.scm ================================================================== --- tests/unittests/server.scm +++ tests/unittests/server.scm @@ -47,28 +47,30 @@ (define *keyvals* (keys:target->keyval *keys* "a/b/c")) (test #f #t (string? (car *runremote*))) (test #f '(#t "successful login") (rmt:login)) ;; *runremote* *toppath* *my-client-signature*))) -(test #f #f (rmt:get-test-info-by-id 99)) ;; get non-existant test +(test #f #f (rmt:get-test-info-by-id 1 99)) ;; get non-existant test ;; RUNS (test #f 1 (rmt:register-run *keyvals* "firstrun" "new" "n/a" (current-user-name))) (test "get run info" "firstrun" (let ((rinfo (rmt:get-run-info 1))) (vector-ref (vector-ref rinfo 1) 3))) (test "get runname from id" "firstrun" (rmt:get-run-name-from-id 1)) ;; TESTS (test "get tests (no data)" '() (rmt:get-tests-for-run 1 "%" '() '() #f #f #f #f #f #f)) -(test "register test" #t (rmt:general-call 'register-test 1 "test1" "")) +(test "register test" #t (rmt:general-call 'register-test 1 1 "test1" "")) (test "get tests (some data)" 1 (length (rmt:get-tests-for-run 1 "%" '() '() #f #f #f #f #f #f))) (test "get test id" 1 (rmt:get-test-id 1 "test1" "")) + (test "sync back" #t (> (rmt:sync-inmem->db) 0)) (test "get test id from main" 1 (db:get-test-id *db* 1 "test1" "")) + (test "get keys" #t (list? (rmt:get-keys))) -(test "set comment" #t (begin (rmt:general-call 'set-test-comment "this is a comment" 1) #t)) -(test "get comment" "this is a comment" (let ((trec (rmt:get-test-info-by-id 1))) +(test "set comment" #t (begin (rmt:general-call 'set-test-comment 1 "this is a comment" 1) #t)) +(test "get comment" "this is a comment" (let ((trec (rmt:get-test-info-by-id 1 1))) (db:test-get-comment trec))) ;; MORE RUNS (test "get runs" #t (let* ((runs (rmt:get-runs "%" #f #f '())) (header (vector-ref runs 0)) @@ -75,12 +77,12 @@ (data (vector-ref runs 1))) (and (list? header) (list? data) (vector? (car data))))) -(test "get local testinfo" "test1" (vector-ref (db:get-testinfo-state-status *db* 1) 2)) -(test "get testinfo" "test1" (vector-ref (rmt:get-testinfo-state-status 1) 2)) +(test "get local testinfo" "test1" (vector-ref (db:get-testinfo-state-status *db* 1 1) 2)) +(test "get testinfo" "test1" (vector-ref (rmt:get-testinfo-state-status 1 1) 2)) ;;====================================================================== ;; D B ;;====================================================================== ADDED tests/watch-monitor.sh Index: tests/watch-monitor.sh ================================================================== --- /dev/null +++ tests/watch-monitor.sh @@ -0,0 +1,10 @@ +#!/bin/bash + +if [ -e fullrun/db/monitor.db ];then +sqlite3 fullrun/db/monitor.db << EOF +.header on +.mode column +select * from servers order by start_time desc; +.q +EOF +fi Index: tree.scm ================================================================== --- tree.scm +++ tree.scm @@ -65,14 +65,15 @@ (loop hed tal depth (+ nodenum 1))))) #f)))) ;; top is the top node name zeroeth node VALUE=0 (define (tree:add-node obj top nodelst #!key (userdata #f)) - (if (not (iup:attribute obj "TITLE0")) + (if (or (not (string? (iup:attribute obj "TITLE0"))) + (string-null? (iup:attribute obj "TITLE0"))) (iup:attribute-set! obj "ADDBRANCH0" top)) (cond - ((not (string=? top (iup:attribute obj "TITLE0"))) + ((not (equal? top (iup:attribute obj "TITLE0"))) (print "ERROR: top name " top " doesn't match " (iup:attribute obj "TITLE0"))) ((null? nodelst)) (else (let loop ((hed (car nodelst)) (tal (cdr nodelst)) @@ -112,5 +113,24 @@ (if (>= currnode nodenum) newpath (loop (+ currnode 1) newpath))))) +#| + + (let* ((tb (iup:treebox + #:value 0 + #:name "Runs" + #:expand "YES" + #:addexpanded "NO" + #:selection-cb + (lambda (obj id state) + ;; (print "obj: " obj ", id: " id ", state: " state) + (let* ((run-path (tree:node->path obj id)) + (run-id (tree-path->run-id (cdr run-path)))) + (if run-id + (begin + (dboard:data-set-curr-run-id! *data* run-id) + (dashboard:update-run-summary-tab))) + ;; (print "path: " (tree:node->path obj id) " run-id: " run-id) + )))) +|# Index: txtdb/txtdb.scm ================================================================== --- txtdb/txtdb.scm +++ txtdb/txtdb.scm @@ -15,10 +15,11 @@ (use srfi-69) (use regex-case) (use posix) (use json) (use csv) +(use srfi-18) (include "../megatest-fossil-hash.scm") ;; Read a non-compressed gnumeric file (define (refdb:read-gnumeric-xml fname) @@ -112,21 +113,23 @@ (let ((ref-colnums (map (lambda (c) (list (cdr c)(car c))) (hash-table->alist colnums)))) (with-output-to-file (conc targdir "/" sheet-name ".dat") (lambda () - (print "[" col0title "]") + (if (not (string-null? col0title))(print "[" col0title "]")) (for-each (lambda (colname) (print "[" colname "]") (for-each (lambda (row) (let ((key (car row)) (val (cadr row))) (if (string-search comment-rx key) (print val) (if (string-search blank-rx key) (print) - (print key " " val))))) + (if (string-search " " key) + (print "\"" key "\" " val) + (print key " " val)))))) (reverse (hash-table-ref cols colname))) ;; (print) ) (sort (hash-table-keys cols)(lambda (a b) (let ((colnum-a (assoc a ref-colnums)) @@ -216,10 +219,11 @@ (hash-table-fold ht (lambda (k v res)(if (equal? v val) k res)) #f)) (define (read-dat fname) (let ((section-rx (regexp "^\\[(.*)\\]\\s*$")) (comment-rx (regexp "^#.*")) ;; This means a cell name cannot start with # + (quoted-cell-rx (regexp "^\"([^\"]*)\" (.*)$")) (cell-rx (regexp "^(\\S+) (.*)$")) ;; One space only for the cellname content separator (blank-rx (regexp "^\\s*$")) (continue-rx (regexp ".*\\\\$")) (var-no-val-rx (regexp "^(\\S+)\\s*$")) (inp (open-input-file fname)) @@ -251,10 +255,13 @@ (if (not first-section) (set! first-section sname)) (loop (read-line inp) sname res))) + (quoted-cell-rx (x k v)(loop (read-line inp) + section + (cons (list k section v) res))) (cell-rx (x k v) (loop (read-line inp) section (cons (list k section v) res))) (var-no-val-rx (x k) (loop (read-line inp) section @@ -263,10 +270,11 @@ (print "ERROR: Unrecognised line in input file " fname ", ignoring it") (loop (read-line inp) section res)))))))) (define (get-value-type val expressions) (cond + ((not val) '(ValueType "60")) ((string->number val) '(ValueType "40")) ((equal? val "") '(ValueType "60")) ((equal? (substring val 0 1) "=") (let ((exid (hash-table-ref/default expressions val #f))) (if exid @@ -454,13 +462,29 @@ (exit))) (let* ((dbname (pathname-strip-directory path)) (tmpf (conc (create-temporary-file dbname) ".gnumeric"))) (if (file-exists? (conc path "/sheet-names.cfg")) (refdb-export path tmpf)) - (let ((pid (process-run "gnumeric" (list tmpf)))) - (process-wait pid) - (import-gnumeric-file tmpf path)))) + (let* ((pid (process-run "gnumeric" (list tmpf)))) + (let loop ((last-mod-time (current-seconds))) + (let-values (((pid-code exit-status exit-signal)(process-wait pid #t))) + (if (eq? pid-code 0) ;; still going + (if (file-exists? tmpf) + (let ((mod-time (file-modification-time tmpf))) + (if (> mod-time last-mod-time) + (begin + (print "saved data to " path) + (import-gnumeric-file tmpf path))) + (thread-sleep! 0.5) + (loop mod-time)) + (begin + (thread-sleep! 0.5) + (loop last-mod-time)))))) + ;; all done + (print "all done, writing new data to " path) + (import-gnumeric-file tmpf path) + (print "data written, exiting refdb edit.")))) ;;====================================================================== ;; This routine dispaches or executes most of the commands for refdb ;;====================================================================== ;; Index: utils/Makefile.installall ================================================================== --- utils/Makefile.installall +++ utils/Makefile.installall @@ -1,31 +1,28 @@ -# Copyright 2013, Matthew Welland. +# Copyright 2013,2014 Matthew Welland. # # This program is made available under the GNU GPL version 2.0 or # greater. See the accompanying file COPYING for details. # # This program is distributed WITHOUT ANY WARRANTY; without even the # implied warranty of MERCHANTABILITY or FITNESS FOR A PARTICULAR # PURPOSE. +# make PREFIX=/mfs/pkgs/chicken/chicken-core all + help : @echo You may need to do the following first: @echo sudo apt-get install libreadline-dev - @echo sudo apt-get install libwebkitgtk-dev - @echo sudo apt-get install libmotif3 -OR- set KTYPE=26g4 - @echo KTYPE can be 26, 26g4, or 32 - @echo KTYPE=$KTYPE - @echo You are using PREFIX=$PREFIX - @echo You are using proxy="$(proxy)" - @echo If needed set proxy to host.dom:port - @echo - @echo "Set additional_libpath to help find gtk or other libraries, don't forget a leading :" - @echo ADDITIONAL_LIBPATH=$(ADDITIONAL_LIBPATH) - @echo - @echo To use previous IUP libraries set USEOLDIUP to yes - @echo USEOLDIUP=$(USEOLDIUP) + @echo sudo apt-get install libwebkitgtk-dev libfreetype6-dev libx11-dev libxpm-dev libxmu-dev libxft-dev libgtk2.0-dev libgl1-mesa-dev libglu1-mesa-dev libpangox-1.0-dev bison + @echo sudo apt-get install libmotif3 + @echo For IUP set IUPBRANCH, currently $(IUPBRANCH) + @echo You are using PREFIX=$(PREFIX) + @echo You are using PROXY="$(PROXY)" + @echo If needed set PROXY to host.dom:port + @echo http_proxy=$(http_proxy) + @echo PROX=$(PROX) @echo @echo To make all do: make all # Put the installation here ifeq ($(PREFIX),) @@ -33,29 +30,34 @@ endif # Set this on the command line of your make call if needed: make PROXY=host.com:1234 PROXY= -# Select IUP library type -KTYPE=26g4 - # Select version of chicken, sqlite3 etc -CHICKEN_VERSION=4.8.0 -SQLITE3_VERSION=3071401 +CHICKEN_VERSION=4.9.0.1 +SQLITE3_VERSION=3080500 +# http://www.sqlite.org/2014/sqlite-autoconf-3080500.tar.gz + +# Override IUPBRANCH to use other than trunk +IUPBRANCH=iup-3.10.1 # 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 +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 \ + spiffy-directory-listing ssax sxml-serializer sxml-modifications sql-de-lite \ + srfi-19 refdb ini-file # # Derived variables # ifeq ($(PROXY),) -PROX= +PROX:= else -http_proxy=http://$(PROXY) -PROX="-proxy $(PROXY)" +http_proxy:=http://$(PROXY) +PROX:=-proxy $(PROXY) endif BUILDHOME=$(PWD) PATH:=$(PREFIX)/bin:$(PATH) LIBPATH=$(PREFIX)/lib$(ADDITIONAL_LIBPATH) @@ -77,27 +79,30 @@ ARCHSIZE= else ARCHSIZE=64_ endif -IUPFILES=cd-5.5.1_Linux$(KTYPE)_$(ARCHSIZE)lib.tar.gz im-3.8_Linux$(KTYPE)_$(ARCHSIZE)lib.tar.gz iup-3.6_Linux$(KTYPE)_$(ARCHSIZE)lib.tar.gz CSCLIBS=$(shell echo $(LD_LIBRARY_PATH) | sed 's/:/ -L/g') -CSC_OPTIONS=-I$(PREFIX)/include -L$(CSCLIBS) +CSC_OPTIONS="-I$(PREFIX)/include -L$(CSCLIBS)" +# CSC_OPTIONS=-I$(PREFIX)/include -L$(CSCLIBS) -all : chkn eggs iup +all : chkn eggs libiup logprobin $(PREFIX)/lib/sqlite3.so $(PREFIX)/bin/hs chkn : $(CHICKEN_INSTALL) eggs : $(EGGSOFILES) -sqlite3 : $(CHICKEN_EGG_DIR)/sqlite3.so +libiup : $(PREFIX)/lib/libavcall.a $(CHICKEN_EGG_DIR)/iup.so $(CHICKEN_EGG_DIR)/canvas-draw.so + +logprobin : $(PREFIX)/bin/logpro -iup : $(PREFIX)/lib/libavcall.a $(CHICKEN_EGG_DIR)/iup.so $(CHICKEN_EGG_DIR)/canvas-draw.so +$(PREFIX)/bin/logpro : $(CHICKEN_EGG_DIR)/regex-literals.so + $(CHICKEN_INSTALL) logpro # Silly rule to make installing eggs more makeish, I don't understand why I need the basename -$(CHICKEN_EGG_DIR)/%.so : %.flag - $(CHICKEN_INSTALL) $(PROX) $(shell basename $*) +$(CHICKEN_EGG_DIR)/%.so : eggflags/%.flag + $(CHICKEN_INSTALL) $(PROX) -keep-installed $(shell basename $*) $(EGGFLAGS) : # $(CHICKEN_INSTALL) mkdir -p eggflags touch $(EGGFLAGS) @@ -106,79 +111,97 @@ setup-chicken4x.sh : $(EGGFLAGS) (echo "export PATH=$(PATH)" > setup-chicken4x.sh) (echo "export LD_LIBRARY_PATH=$(LD_LIBRARY_PATH)" >> setup-chicken4x.sh) mkdir -p $(PREFIX) -# Download chicken source -chicken-$(CHICKEN_VERSION).tar.gz : - wget http://code.call-cc.org/releases/$(CHICKEN_VERSION)/chicken-$(CHICKEN_VERSION).tar.gz - -# NB// Must touch csi.scm since tar puts original date on it and deps are wrong then -chicken-$(CHICKEN_VERSION)/csi.scm : chicken-$(CHICKEN_VERSION).tar.gz - tar xfvz chicken-$(CHICKEN_VERSION).tar.gz - touch -c chicken-$(CHICKEN_VERSION)/csi.scm - -$(CHICKEN_INSTALL) : chicken-$(CHICKEN_VERSION)/csi.scm setup-chicken4x.sh - cd chicken-$(CHICKEN_VERSION);make PLATFORM=linux PREFIX=$(PREFIX) - cd chicken-$(CHICKEN_VERSION);make PLATFORM=linux PREFIX=$(PREFIX) install - -sqlite-autoconf-$(SQLITE3_VERSION).tar.gz : - wget http://www.sqlite.org/sqlite-autoconf-$(SQLITE3_VERSION).tar.gz - -sqlite-autoconf-$(SQLITE3_VERSION) : sqlite-autoconf-$(SQLITE3_VERSION).tar.gz - tar xfz sqlite-autoconf-$(SQLITE3_VERSION).tar.gz - -$(PREFIX)/bin/sqlite3 : sqlite-autoconf-$(SQLITE3_VERSION) - (cd sqlite-autoconf-$(SQLITE3_VERSION);./configure --prefix=$(PREFIX);make;make install) - -$(CHICKEN_EGG_DIR)/sqlite3.so : $(PREFIX)/bin/sqlite3 +chicken-core/chicken.scm : chicken-$(CHICKEN_VERSION).tar.gz + tar xfz chicken-$(CHICKEN_VERSION).tar.gz + ln -sf chicken-$(CHICKEN_VERSION) chicken-core + + +chicken-4.9.0rc1.tar.gz : + wget http://code.call-cc.org/dev-snapshots/2014/04/17/chicken-4.9.0rc1.tar.gz + +chicken-4.9.0.1.tar.gz : + wget http://code.call-cc.org/releases/4.9.0/chicken-4.9.0.1.tar.gz + +# git clone git://code.call-cc.org/chicken-core +# git clone http://code.call-cc.org/git/chicken-core.git + +$(CHICKEN_INSTALL) : chicken-core/chicken.scm setup-chicken4x.sh + cd chicken-core;make PLATFORM=linux PREFIX=$(PREFIX) + cd chicken-core;make PLATFORM=linux PREFIX=$(PREFIX) install + +#====================================================================== +# S Q L I T E 3 +#====================================================================== + +sqlite-autoconf-$(SQLITE3_VERSION).tar.gz : + wget http://www.sqlite.org/2014/sqlite-autoconf-$(SQLITE3_VERSION).tar.gz + +sqlite-autoconf-$(SQLITE3_VERSION)/config.log : sqlite-autoconf-$(SQLITE3_VERSION).tar.gz + tar xfz sqlite-autoconf-$(SQLITE3_VERSION).tar.gz + +$(PREFIX)/bin/sqlite3 : sqlite-autoconf-$(SQLITE3_VERSION)/config.log + cd sqlite-autoconf-$(SQLITE3_VERSION);./configure --prefix=$(PREFIX);make;make install + +$(PREFIX)/lib/sqlite3.so : $(PREFIX)/bin/sqlite3 CSC_OPTIONS="-I$(PREFIX)/include -L$(PREFIX)/lib" $(CHICKEN_INSTALL) $(PROX) sqlite3 +#====================================================================== +# M A T T S U T I L S +#====================================================================== + +opensrc.fossil : + fossil clone http://www.kiatoa.com/fossils/opensrc opensrc.fossil -# Get and install my various utilities that haven't been eggified yet. -opensrc/margs/margs.scm opensrc/dbi/dbi.scm opensrc/qtree/qtree.scm : $(CHICKEN_INSTALL) $(CHICKEN_EGG_DIR)/sqlite3.so +opensrc/histstore/histstore.scm : opensrc.fossil mkdir -p opensrc - cd opensrc;if [ ! -e opensrc.fossil ]; then fossil clone http://www.kiatoa.com/fossils/opensrc opensrc.fossil; fi - cd opensrc;if [ -e dbi/dbi.scm ]; then fossil update; else fossil open opensrc.fossil; fi - -$(CHICKEN_EGG_DIR)/dbi.so : opensrc/dbi/dbi.scm - cd opensrc/dbi;chicken-install - -$(CHICKEN_EGG_DIR)/margs.so : opensrc/margs/margs.scm - cd opensrc/margs;chicken-install - -$(CHICKEN_EGG_DIR)/qtree.so : opensrc/qtree/qtree.scm - cd opensrc/qtree;chicken-install - -# $(CHICKEN_EGG_DIR)/dbi.so # Don't include as requires postgres -mattseggs : $(CHICKEN_EGG_DIR)/margs.so $(CHICKEN_EGG_DIR)/qtree.so - -# -# IUP -# - -ffcall.tar.gz : - wget http://www.kiatoa.com/matt/iup/ffcall.tar.gz - -ffcall/README : ffcall.tar.gz - tar xfvz ffcall.tar.gz - touch -c ffcall/README - + cd opensrc;fossil open ../opensrc.fossil + +opensrc/histstore/hs : opensrc/histstore/histstore.scm chkn eggs $(PREFIX)/lib/sqlite3.so + cd opensrc/histstore;$(PREFIX)/bin/csc histstore.scm -o hs + +$(PREFIX)/bin/hs : opensrc/histstore/hs + cp -f opensrc/histstore/hs $(PREFIX)/bin/hs + +#====================================================================== +# I U P +#====================================================================== + +ffcall.fossil : + fossil clone http://www.kiatoa.com/fossils/ffcall ffcall.fossil + +ffcall/README : ffcall.fossil + mkdir -p ffcall + cd ffcall && if [ -e README ];then fossil update; else fossil open ../ffcall.fossil; fi + +# NOTE: This worked fine *without* the enable-shared +# $(PREFIX)/lib/libavcall.a : ffcall/README cd ffcall;./configure --prefix=$(PREFIX) --enable-shared && make && make install -$(IUPFILES) : - wget http://www.kiatoa.com/matt/iup/$@ - cd $(PREFIX)/lib;tar xfvz $(BUILDHOME)/$@ - mv $(PREFIX)/lib/include/* $(PREFIX)/include +iuplib.fossil : + fossil clone http://www.kiatoa.com/fossils/iuplib iuplib.fossil + +iup/installall.sh : iuplib.fossil + mkdir -p iup + cd iup && if [ -e installall.sh ];then fossil update $(IUPBRANCH); else fossil open ../iuplib.fossil;fossil update $(IUPBRANCH); fi + +iup/alldone : iup/installall.sh $(PREFIX)/include/iup.h $(PREFIX)/lib/libiup.so + cd iup && ./makeall.sh + +$(PREFIX)/lib/libiup.so $(PREFIX)/include/iup.h : iup/installall.sh iup/alldone + cd iup && ./installall.sh -$(PREFIX)/lib/libiup.so : $(IUPFILES) - touch -c $(PREFIX)/lib/libiup.so +# $(PREFIX)/lib/libiup.so : iup/iup/alldone +# touch -c $(PREFIX)/lib/libiup.so $(CHICKEN_EGG_DIR)/iup.so : $(PREFIX)/lib/libiup.so - $(CHICKEN_INSTALL) $(PROX) -D no-library-checks -feature disable-iup-web iup + LD_LIBRARY_PATH=$(LD_LIBRARY_PATH) CSC_OPTIONS=$(CSC_OPTIONS) $(CHICKEN_INSTALL) $(PROX) -D no-library-checks -feature disable-iup-web iup $(CHICKEN_EGG_DIR)/canvas-draw.so : $(PREFIX)/lib/libiup.so - $(CHICKEN_INSTALL) $(PROX) -D no-library-checks canvas-draw + CSC_OPTIONS=$(CSC_OPTIONS) $(CHICKEN_INSTALL) $(PROX) -D no-library-checks canvas-draw + clean : rm -rf chicken-4.8.0 eggflags ffcall sqlite-autoconf-$(SQLITE3_VERSION) Index: utils/installall.sh ================================================================== --- utils/installall.sh +++ utils/installall.sh @@ -1,10 +1,10 @@ #! /usr/bin/env bash # set -x -# Copyright 2007-2010, Matthew Welland. +# Copyright 2007-2014, Matthew Welland. # # This program is made available under the GNU GPL version 2.0 or # greater. See the accompanying file COPYING for details. # # This program is distributed WITHOUT ANY WARRANTY; without even the @@ -15,10 +15,11 @@ echo sudo apt-get install libreadline-dev echo sudo apt-get install libwebkitgtk-dev echo sudo apt-get install libssl-dev echo sudo apt-get install libmotif3 -OR- set KTYPE=26g4 echo KTYPE can be 26, 26g4, or 32 +echo echo KTYPE=$KTYPE echo You are using PREFIX=$PREFIX echo You are using proxy="$proxy" echo echo "Set additional_libpath to help find gtk or other libraries, don't forget a leading :" @@ -59,14 +60,20 @@ export KTYPE=26 else echo Using KTYPE=$KTYPE fi +# Put all the downloaded tar files in tgz +mkdir -p tgz + +# http://code.call-cc.org/releases/4.8.0/chicken-4.8.0.5.tar.gz export CHICKEN_VERSION=4.8.0.5 export CHICKEN_BASEVER=4.8.0 -if ! [[ -e chicken-${CHICKEN_VERSION}.tar.gz ]]; then - wget http://code.call-cc.org/releases/${CHICKEN_BASEVER}/chicken-${CHICKEN_VERSION}.tar.gz +chicken_targz=chicken-${CHICKEN_VERSION}.tar.gz +if ! [[ -e tgz/$chicken_targz ]]; then + wget http://code.call-cc.org/releases/${CHICKEN_BASEVER}/${chicken_targz} + mv $chicken_targz tgz fi BUILDHOME=$PWD DEPLOYTARG=$BUILDHOME/deploy @@ -83,11 +90,11 @@ echo PATH=$PATH echo LD_LIBRARY_PATH=$LD_LIBRARY_PATH if ! [[ -e $PREFIX/bin/csi ]]; then - tar xfvz chicken-${CHICKEN_VERSION}.tar.gz + tar xfvz tgz/$chicken_targz cd chicken-${CHICKEN_VERSION} # make PLATFORM=linux PREFIX=$PREFIX spotless make PLATFORM=linux PREFIX=$PREFIX make PLATFORM=linux PREFIX=$PREFIX install cd $BUILDHOME @@ -115,56 +122,65 @@ export LIBPATH=$PREFIX/lib$ADDITIONAL_LIBPATH export LD_LIBRARY_PATH=$LIBPATH export SQLITE3_VERSION=3071401 echo Install sqlite3 -if ! [[ -e sqlite-autoconf-$SQLITE3_VERSION.tar.gz ]]; then - wget http://www.sqlite.org/sqlite-autoconf-$SQLITE3_VERSION.tar.gz +sqlite3_tgz=sqlite-autoconf-$SQLITE3_VERSION.tar.gz +if ! [[ -e tgz/$sqlite3_tgz ]]; then + wget http://www.sqlite.org/$sqlite3_tgz + mv $sqlite3_tgz tgz fi if ! [[ -e $PREFIX/bin/sqlite3 ]] ; then - if [[ -e sqlite-autoconf-$SQLITE3_VERSION.tar.gz ]]; then - tar xfz sqlite-autoconf-$SQLITE3_VERSION.tar.gz + if [[ -e tgz/sqlite-autoconf-$SQLITE3_VERSION.tar.gz ]]; then + tar xfz tgz/sqlite-autoconf-$SQLITE3_VERSION.tar.gz (cd sqlite-autoconf-$SQLITE3_VERSION;./configure --prefix=$PREFIX;make;make install) # CSC_OPTIONS="-I$PREFIX/include -L$PREFIX/lib" $CHICKEN_INSTALL -prefix $DEPLOYTARG -deploy $PROX sqlite3 CSC_OPTIONS="-I$PREFIX/include -L$PREFIX/lib" $CHICKEN_INSTALL $PROX sqlite3 fi fi # $CHICKEN_INSTALL $PROX sqlite3 + +# IUP versions +CDVER=5.7 +IUPVER=3.8 +IMVER=3.8 if [[ `uname -a | grep x86_64` == "" ]]; then export ARCHSIZE='' else export ARCHSIZE=64_ fi # export files="cd-5.4.1_Linux${KTYPE}_lib.tar.gz im-3.6.3_Linux${KTYPE}_lib.tar.gz iup-3.5_Linux${KTYPE}_lib.tar.gz" if [[ x$USEOLDIUP == "x" ]];then - export files="cd-5.5.1_Linux${KTYPE}_${ARCHSIZE}lib.tar.gz im-3.8_Linux${KTYPE}_${ARCHSIZE}lib.tar.gz iup-3.6_Linux${KTYPE}_${ARCHSIZE}lib.tar.gz" + export files="cd-${CDVER}_Linux${KTYPE}_${ARCHSIZE}lib.tar.gz im-${IMVER}_Linux${KTYPE}_${ARCHSIZE}lib.tar.gz iup-${IUPVER}_Linux${KTYPE}_${ARCHSIZE}lib.tar.gz" else echo WARNING: Using old IUP libraries export files="cd-5.4.1_Linux${KTYPE}_${ARCHSIZE}lib.tar.gz im-3.6.3_Linux${KTYPE}_${ARCHSIZE}lib.tar.gz iup-3.5_Linux${KTYPE}_${ARCHSIZE}lib.tar.gz" fi mkdir -p $PREFIX/iuplib for a in `echo $files` ; do - if ! [[ -e $a ]] ; then + if ! [[ -e tgz/$a ]] ; then wget http://www.kiatoa.com/matt/iup/$a fi - echo Untarring $a into $BUILDHOME/lib - (cd $PREFIX/lib;tar xfvz $BUILDHOME/$a;mv include/* ../include) + mv $a tgz/$a + echo Untarring tgz/$a into $BUILDHOME/lib + (cd $PREFIX/lib;tar xfvz $BUILDHOME/tgz/$a;mv include/* ../include) # (cd $DEPLOYTARG;tar xfvz $BUILDHOME/$a) done # ffcall obtained from: # cvs -z3 -d:pserver:anonymous@cvs.savannah.gnu.org:/sources/libffcall co ffcall -if ! [[ -e ffcall.tar.gz ]] ; then +if ! [[ -e tgz/ffcall.tar.gz ]] ; then wget http://www.kiatoa.com/matt/iup/ffcall.tar.gz + mv ffcall.tar.gz tgz fi -tar xfvz ffcall.tar.gz +tar xfvz tgz/ffcall.tar.gz cd ffcall ./configure --prefix=$PREFIX --enable-shared make make install @@ -176,138 +192,19 @@ # CSC_OPTIONS="-I$PREFIX/include -L$CSCLIBS" $CHICKEN_INSTALL $PROX -D no-library-checks -feature disable-iup-web -deploy -prefix $DEPLOYTARG iup # iup:1.0.2 CSC_OPTIONS="-I$PREFIX/include -L$CSCLIBS" $CHICKEN_INSTALL $PROX -D no-library-checks canvas-draw # CSC_OPTIONS="-I$PREFIX/include -L$CSCLIBS" $CHICKEN_INSTALL $PROX -D no-library-checks -deploy -prefix $DEPLOYTARG canvas-draw -# disabled zmq # #====================================================================== -# disabled zmq # # Note uuid needed only for zmq 2.x series -# disabled zmq # #====================================================================== -# disabled zmq # -# disabled zmq # # http://download.zeromq.org/zeromq-3.2.1-rc2.tar.gz -# disabled zmq # # zpatchlev=-rc2 -# disabled zmq # # http://download.zeromq.org/zeromq-2.2.0.tar.gz -# disabled zmq # -# disabled zmq # if [[ -e /usr/lib/libzmq.so ]]; then -# disabled zmq # echo "Using system installed zmq library" -# disabled zmq # $CHICKEN_INSTALL zmq -# disabled zmq # else -# disabled zmq # ZEROMQ=zeromq-2.2.0 -# disabled zmq # # ZEROMQ=zeromq-3.2.2 -# disabled zmq # -# disabled zmq # # wget http://www.kernel.org/pub/linux/utils/util-linux/v2.22/util-linux-2.22.tar.gz -# disabled zmq # UTIL_LINUX=2.21 -# disabled zmq # # UTIL_LINUX=2.20.1 -# disabled zmq # if ! [[ -e util-linux-${UTIL_LINUX}.tar.gz ]] ; then -# disabled zmq # # wget http://www.kiatoa.com/matt/util-linux-2.20.1.tar.gz -# disabled zmq # wget http://www.kernel.org/pub/linux/utils/util-linux/v${UTIL_LINUX}/util-linux-${UTIL_LINUX}.tar.gz -# disabled zmq # fi -# disabled zmq # -# disabled zmq # if [[ -e util-linux-${UTIL_LINUX}.tar.gz ]] ; then -# disabled zmq # tar xfz util-linux-${UTIL_LINUX}.tar.gz -# disabled zmq # cd util-linux-${UTIL_LINUX} -# disabled zmq # mkdir -p build -# disabled zmq # cd build -# disabled zmq # if [[ $UTIL_LINUX = "2.22" ]] ; then -# disabled zmq # ../configure --prefix=$PREFIX \ -# disabled zmq # --enable-shared \ -# disabled zmq # --disable-use-tty-group \ -# disabled zmq # --disable-makeinstall-chown \ -# disabled zmq # --disable-makeinstall-setuid \ -# disabled zmq # --disable-libtool-lock \ -# disabled zmq # --disable-login \ -# disabled zmq # --disable-sulogin \ -# disabled zmq # --disable-su \ -# disabled zmq # --disable-schedutils \ -# disabled zmq # --disable-libmount \ -# disabled zmq # --disable-mount \ -# disabled zmq # --disable-losetup \ -# disabled zmq # --disable-fsck \ -# disabled zmq # --disable-partx \ -# disabled zmq # --disable-mountpoint \ -# disabled zmq # --disable-fallocate \ -# disabled zmq # --disable-unshare \ -# disabled zmq # --disable-eject \ -# disabled zmq # --disable-agetty \ -# disabled zmq # --disable-cramfs \ -# disabled zmq # --disable-switch_root \ -# disabled zmq # --disable-pivot_root \ -# disabled zmq # --disable-kill \ -# disabled zmq # --disable-libblkid \ -# disabled zmq # --disable-utmpdump \ -# disabled zmq # --disable-rename \ -# disabled zmq # --disable-chsh-only-listed \ -# disabled zmq # --disable-wall \ -# disabled zmq # --disable-pg-bell \ -# disabled zmq # --disable-require-password \ -# disabled zmq # --disable-libtool-lock \ -# disabled zmq # --disable-nls \ -# disabled zmq # --disable-dmesg \ -# disabled zmq # --without-ncurses -# disabled zmq # else -# disabled zmq # ../configure --prefix=$PREFIX \ -# disabled zmq # --enable-shared \ -# disabled zmq # --disable-mount \ -# disabled zmq # --disable-fsck \ -# disabled zmq # --disable-partx \ -# disabled zmq # --disable-largefile \ -# disabled zmq # --disable-tls \ -# disabled zmq # --disable-libmount \ -# disabled zmq # --disable-mountpoint \ -# disabled zmq # --disable-nls \ -# disabled zmq # --disable-rpath \ -# disabled zmq # --disable-agetty \ -# disabled zmq # --disable-cramfs \ -# disabled zmq # --disable-switch_root \ -# disabled zmq # --disable-pivot_root \ -# disabled zmq # --disable-fallocate \ -# disabled zmq # --disable-unshare \ -# disabled zmq # --disable-rename \ -# disabled zmq # --disable-schedutils \ -# disabled zmq # --disable-libblkid \ -# disabled zmq # --disable-wall CFLAGS='-fPIC' -# disabled zmq # -# disabled zmq # # --disable-makeinstall-chown \ -# disabled zmq # # --disable-makeinstall-setuid \ -# disabled zmq # -# disabled zmq # # --disable-chsh-only-listed -# disabled zmq # # --disable-pg-bell let pg not ring the bell on invalid keys -# disabled zmq # # --disable-require-password -# disabled zmq # # --disable-use-tty-group do not install wall and write setgid tty -# disabled zmq # # --disable-makeinstall-chown -# disabled zmq # # --disable-makeinstall-setuid -# disabled zmq # fi -# disabled zmq # -# disabled zmq # (cd libuuid;make install) -# disabled zmq # # make -# disabled zmq # # make install -# disabled zmq # cp $PREFIX/include/uuid/uuid.h $PREFIX/include/uuid.h -# disabled zmq # fi -# disabled zmq # -# disabled zmq # -# disabled zmq # cd $BUILDHOME -# disabled zmq # -# disabled zmq # if ! [[ -e ${ZEROMQ}${zpatchlev}.tar.gz ]] ; then -# disabled zmq # wget http://download.zeromq.org/${ZEROMQ}${zpatchlev}.tar.gz -# disabled zmq # fi -# disabled zmq # -# disabled zmq # if [[ -e ${ZEROMQ}${zpatchlev}.tar.gz ]] ; then -# disabled zmq # tar xfz ${ZEROMQ}.tar.gz -# disabled zmq # cd ${ZEROMQ} -# disabled zmq # ln -s $PREFIX/include/uuid src -# disabled zmq # # LDFLAGS=-L$PREFIX/lib ./configure --prefix=$PREFIX -# disabled zmq # -# disabled zmq # ./configure --enable-static --prefix=$PREFIX --with-uuid=$PREFIX LDFLAGS="-L$PREFIX/lib" CPPFLAGS="-fPIC -I$PREFIX/include" LIBS="-lgcc" -# disabled zmq # # --disable-shared CPPFLAGS="-fPIC -# disabled zmq # # LDFLAGS="-L/usr/lib64 -L$PREFIX/lib" ./configure --enable-static --prefix=$PREFIX -# disabled zmq # make -# disabled zmq # make install -# disabled zmq # CSC_OPTIONS="-I$PREFIX/include -L$CSCLIBS" $CHICKEN_INSTALL $PROX zmq -# disabled zmq # # CSC_OPTIONS="-I$PREFIX/include -L$CSCLIBS" $CHICKEN_INSTALL $PROX -deploy -prefix $DEPLOYTARG zmq -# disabled zmq # fi -# disabled zmq # fi # if zmq is in /usr/lib -# disabled zmq # +# NB// Removed bunch of zmq compiling tricks. Look at older versions of this file if you need to recreate... + cd $BUILDHOME + +git clone https://bitbucket.org/DerGuteMoritz/zmq/commits/branch/3.2 zmq-3.2 +cd zmq-3.2 +chicken-install + +cd $BUILDHOME ## WEBKIT=WebKit-r131972 ## if ! [[ -e ${WEBKIT}.tar.bz2 ]] ; then ## # http://builds.nightly.webkit.org/files/trunk/src/WebKit-r131972.tar.bz2 ## wget http://builds.nightly.webkit.org/files/trunk/src/${WEBKIT}.tar.bz2 ADDED utils/installck.sh Index: utils/installck.sh ================================================================== --- /dev/null +++ utils/installck.sh @@ -0,0 +1,22 @@ +#!/bin/bash + +myhome=$(dirname $0) + +if [[ $proxy == "" ]]; then + echo 'Please set the environment variable "proxy" to host.com:port (e.g. foo.com:1234) to use a proxy' + echo PROX="" +else + export http_proxy=http://$proxy + export PROX="-proxy $proxy" +fi + +if [[ -z $PREFIX ]];then + echo "\$PREFIX variable is required" + exit +fi + +export LD_LIBRARY_NAME=$PREFIX/lib + +logname=$(basename $PREFIX) + +script -c "make -f $myhome/Makefile_latest.installall all" $logname.log ADDED utils/loadrunner Index: utils/loadrunner ================================================================== --- /dev/null +++ utils/loadrunner @@ -0,0 +1,78 @@ +#!/bin/bash + +LOADRUNNER=$0 + +# load=`uptime|awk '{print $10}'|cut -d, -f1` +load=$(uptime|perl -pe 's/.*: (\d+.\d+),.*/$1/') +load2=$(uptime|perl -pe 's/.*: (\d+.\d+), (\d+.\d+),.*/$2/') +# echo "load2=$load2, load=$load" + +# Run a job detached from stdin/stdout (i.e. daemonized) +# Launch on remotehost if specified by TARGETHOST +# +function launchjob () { + # Can't always trust $PWD + CURRWD=`pwd` + if [[ $TARGETHOST_LOGF == "" ]]; then + TARGETHOST_LOGF=NBFAKE-`date +%GWW%V.%u_%T` + fi + # echo "#======================================================================" + # echo "# NBFAKE Running command:" + # echo "# \"$*\"" + # echo "#======================================================================" + + if [[ $TARGETHOST == "" ]]; then + sh -c "cd $CURRWD;export DISPLAY=$DISPLAY; export PATH=$PATH; nohup $* > $TARGETHOST_LOGF 2>&1 &" + else + ssh -n -f $TARGETHOST "sh -c \"cd $CURRWD;export DISPLAY=$DISPLAY; export PATH=$PATH; nohup $* > $TARGETHOST_LOGF 2>&1 &\"" + fi +} + +function get_delay_time () { + RANGE=$1 + number=$RANDOM + let "number %= $RANGE" + echo $number +} + +if which cpucheck > /dev/null;then + numcpu=`cpucheck|tail -1|awk '{print $6}'` +elif which lscpu > /dev/null;then + numcpu=`lscpu|grep "CPU.s.:"|awk '{print $2}'` +else + numcpu=2 +fi + +# NB// max_load is in units of percent. +# +lperc=$(echo "100 * $load / $numcpu"|bc) +lperc2=$(echo "100 * $load2 / $numcpu"|bc) +let "lperc2adj=$lperc2 + $numcpu" +if [[ "x$MAX_ALLOWED_LOAD" == "x" ]]; then + max_load=100 +else + max_load=$MAX_ALLOWED_LOAD +fi + +lfile=/tmp/loadrunner-$USER.lockfile +lockfile -r 5 -l 60 $lfile &> /dev/null + +if [[ $lperc -lt $max_load ]];then + if [[ $lperc -le $lperc2adj ]];then + # echo "Load acceptable: lperc=$lperc %, max_load=$max_load %, load=$load, numcpu=$numcpu, MAX_ALLOWED_LOAD=$MAX_ALLOWED_LOAD % and $lperc2 < $lperc" + # echo "Starting command: \"$@\"" + launchjob "$@" + # we sleep ten seconds here to keep the lock a little longer and give time for + # the uptime to show a response + # sleep 2 + else + echo "$LOADRUNNER $@" | at now + 2 minutes &> /dev/null + # sleep 5 + fi +else + # echo "Load too high: lperc=$lperc, max_load=$max_load, waiting two minutes before trying to run command: \"$@\"" + echo "$LOADRUNNER $@" | at now + 2 minutes &> /dev/null +fi + +sleep $(get_delay_time 3) +rm -f $lfile ADDED utils/loadrunner.scm.notfinished Index: utils/loadrunner.scm.notfinished ================================================================== --- /dev/null +++ utils/loadrunner.scm.notfinished @@ -0,0 +1,192 @@ + +;; Copyright 2006-2013, Matthew Welland. +;; +;; This program is made available under the GNU GPL version 2.0 or +;; greater. See the accompanying file COPYING for details. +;; +;; This program is distributed WITHOUT ANY WARRANTY; without even the +;; implied warranty of MERCHANTABILITY or FITNESS FOR A PARTICULAR +;; PURPOSE. + +(use ssax) +(use sxml-serializer) +(use sxml-modifications) +(use regex) +(use srfi-69) +(use regex-case) +(use posix) +(use json) +(use csv) +(use srfi-18) +(use format) + +(require-library iup) +(import (prefix iup iup:)) +(require-library ini-file) +(import (prefix ini-file ini:)) + +(use canvas-draw) +(import canvas-draw-iup) + +(use sqlite3 srfi-1 posix regex regex-case srfi-69) +(import (prefix sqlite3 sqlite3:)) + +(include "megatest-fossil-hash.scm") + +;; +;; GLOBALS +;; +(define *loadrunner:current-tab-number* 0) +(define loadrunner:unrecognised-command "ERROR: Unrecognised command or missing params. Try \"loadrunner help\"") +(define loadrunner:help (conc "Usage: loadrunner [action [params ...]] + +Note: run loadrunner without parameters to start the gui. + + run cmd [params ..] : Run cmd params ... when system load drops + process : Process the queue + +Part of the Megatest tool suite. Learn more at http://www.kiatoa.com/fossils/megatest + +Version: " megatest-fossil-hash)) ;; " + +;;====================================================================== +;; DB +;;====================================================================== + +(define (loadrunner:initialize-db db) + (for-each + (lambda (qry) + (sqlite3:execute db qry)) + (list + "CREATE TABLE pkgs + (id INTEGER PRIMARY KEY, + cmd TEXT, + datetime TEXT);"))) + +;; Create the sqlite db +(define (loadrunner:open-db path) + (if (and path + (directory? path) + (file-read-access? path)) + (let* ((dbpath (conc path "/loadrunner.db")) + (writeable (file-write-access? dbpath)) + (dbexists (file-exists? dbpath)) + (handler (make-busy-timeout 136000))) + (handle-exceptions + exn + (begin + (debug:print 2 "ERROR: problem accessing db " dbpath + ((condition-property-accessor 'exn 'message) exn)) + (exit)) + (set! db (sqlite3:open-database dbpath))) + (if *db-write-access* (sqlite3:set-busy-handler! db handler)) + (if (not dbexists) + (begin + (loadrunner:initialize-db db))) + db))) + +;;====================================================================== +;; GUI +;;====================================================================== + +;; The main menu +(define (loadrunner:main-menu) + (iup:menu ;; a menu is a special attribute to a dialog (think Gnome putting the menu at screen top) + (iup:menu-item "Files" (iup:menu ;; Note that you can use either #:action or action: for options + (iup:menu-item "Open" action: (lambda (obj) + (iup:show (iup:file-dialog)) + (print "File->open " obj))) + (iup:menu-item "Save" #:action (lambda (obj)(print "File->save " obj))) + (iup:menu-item "Exit" #:action (lambda (obj)(exit))))) + (iup:menu-item "Tools" (iup:menu + (iup:menu-item "Create new blah" #:action (lambda (obj)(print "Tools->new blah"))) + ;; (iup:menu-item "Show dialog" #:action (lambda (obj) + ;; (show message-window + ;; #:modal? #t + ;; ;; set positon using coordinates or center, start, top, left, end, bottom, right, parent-center, current + ;; ;; #:x 'mouse + ;; ;; #:y 'mouse + ;; ) + )))) + +(define (loadrunner:publish-view) + (iup:vbox + (iup:hbox + (iup:button "Pushme" + #:expand "YES" + )))) + +(define (loadrunner:get-view) + (iup:vbox + (iup:hbox + (iup:button "Pushme" + #:expand "YES" + )))) + +(define (loadrunner:manage-view) + (iup:vbox + (iup:hbox + (iup:button "Pushme" + #:expand "YES" + )))) + +(define (loadrunner:gui) + (iup:show + (iup:dialog + #:title (conc "Loadrunner dashboard " (current-user-name) ":" (current-directory)) + #:menu (loadrunner:main-menu) + (let* ((tabs (iup:tabs + #:tabchangepos-cb (lambda (obj curr prev) + (set! *loadrunner:current-tab-number* curr)) + (loadrunner:publish-view) + (loadrunner:get-view) + (loadrunner:manage-view) + ))) + ;; (set! (iup:callback tabs tabchange-cb:) (lambda (a b c)(print "SWITCHED TO TAB: " a " " b " " c))) + (iup:attribute-set! tabs "TABTITLE0" "Publish") + (iup:attribute-set! tabs "TABTITLE1" "Get") + (iup:attribute-set! tabs "TABTITLE2" "Manage") + ;; (iup:attribute-set! tabs "BGCOLOR" "190 190 190") + tabs))) + (iup:main-loop)) + +;;====================================================================== +;; MAIN +;;====================================================================== + +(define (loadrunner:load-config path) + (let ((fname (conc path "/.loadrunner.config"))) + (ini:property-separator-patt " * *") + (ini:property-separator #\space) + (if (file-exists? fname) + (ini:read fname) + '()))) + +(define (main) + (let* ((args (argv)) + (prog (car args)) + (rema (cdr args)) + (conf (loadrunner:load-config (pathname-directory prog)))) + ;; ( ????? + (cond + ((eq? (length rema) 1) + (case (string->symbol (car rema)) + ((process)(loadrunner:process-queue)) + ((pause) + (loadrunner:pause-queue (cdr rema))) + ((help -h -help --h --help) + (print loadrunner:help)) + (else + (print loadrunner:unrecognised-command)))) + ((null? rema)(loadrunner:gui)) + ((>= (length rema) 2) + (case (string->symbol (car rema)) + ((run) + (loadrunner:process-cmd (cdr rema))) + ((remove) + (loadrunner:remove-cmds (cdr rema))) + (else + (print loadrunner:unrecognised-command)))) + (else (print loadrunner:unrecognised-command))))) + +(main) Index: utils/mk_wrapper ================================================================== --- utils/mk_wrapper +++ utils/mk_wrapper @@ -1,16 +1,26 @@ #!/bin/bash prefix=$1 cmd=$2 +target=$3 -echo "#!/bin/bash" if [ "$LD_LIBRARY_PATH" != "" ];then + cfgfile="$prefix/bin/.$(lsb_release -sr)/cfg.sh" echo "INFO: Using LD_LIBRARY_PATH=$LD_LIBRARY_PATH" >&2 - echo "export LD_LIBRARY_PATH=$LD_LIBRARY_PATH" +( cat << __EOF +if [ "\$LD_LIBRARY_PATH" != "" ];then + export LD_LIBRARY_PATH=$LD_LIBRARY_PATH:\$LD_LIBRARY_PATH +else + export LD_LIBRARY_PATH=$LD_LIBRARY_PATH +fi +__EOF +) > $cfgfile + echo else echo "INFO: LD_LIBRARY_PATH not set" >&2 fi -fullcmd="exec $prefix/bin/$cmd" +echo "#!/bin/bash" > $target +echo "source $prefix/bin/.\$(lsb_release -sr)/cfg.sh" >> $target +echo "exec $prefix/bin/.\$(lsb_release -sr)/$cmd \"\$@\"" >> $target -echo "$fullcmd \"\$@\"" Index: utils/mtgetfile ================================================================== --- utils/mtgetfile +++ utils/mtgetfile @@ -18,11 +18,11 @@ ((not key-vals) "missing -target") ((not target) "missing -target") ((not scriptn) "missing file name to find") (else #f)))) (if errmsg - (begin + (begin (print "THEPATH: Missing required switch: " errmsg) (print "THEPATH: Usage: mtgetfile -target target scriptname [searchpath]") (exit))) (print "THEPATH: key-vals=" key-vals " path=" path " scriptn=" scriptn)) EOF Index: utils/nbfake ================================================================== --- utils/nbfake +++ utils/nbfake @@ -1,12 +1,20 @@ #!/bin/bash -# ssh localhost "nohup $* > nbfake.log 2> nbfake.err < /dev/null" - # Can't always trust $PWD CURRWD=`pwd` +if [[ $TARGETHOST_LOGF == "" ]]; then + TARGETHOST_LOGF=NBFAKE-`date +%GWW%V.%u_%T` +fi +echo "#======================================================================" +echo "# NBFAKE Running command:" +echo "# \"$*\"" +echo "#======================================================================" if [[ $TARGETHOST == "" ]]; then - sh -c "cd $CURRWD;export DISPLAY=$DISPLAY; export PATH=$PATH; nohup $* > NBFAKE-`date +%GWW%V.%u_%T` 2>&1 &" + unset TARGETHOST + TARGETHOST_LOGF_TEMP=$TARGETHOST_LOGF + unset TARGETHOST_LOGF + sh -c "cd $CURRWD;export DISPLAY=$DISPLAY; export PATH=$PATH; nohup $* > $TARGETHOST_LOGF_TEMP 2>&1 &" else - ssh -n -f $TARGETHOST "sh -c \"cd $CURRWD;export DISPLAY=$DISPLAY; export PATH=$PATH; nohup $* > NBFAKE-`date +%GWW%V.%u_%T` 2>&1 &\"" + ssh -n -f $TARGETHOST "sh -c \"cd $CURRWD;export DISPLAY=$DISPLAY; export PATH=$PATH; nohup $* > $TARGETHOST_LOGF 2>&1 &\"" fi DELETED utils/nbload Index: utils/nbload ================================================================== --- utils/nbload +++ /dev/null @@ -1,24 +0,0 @@ -#!/bin/bash - -# load=`uptime|awk '{print $10}'|cut -d, -f1` -load=`uptime|perl -pe 's/.*: (\d+.\d+),.*/$1/'` -if which cpucheck > /dev/null;then - numcpu=`cpucheck|tail -1|awk '{print $6}'` -else - numcpu=`lscpu|grep "CPU.s.:"|awk '{print $2}'` -fi - -lperc=`echo "100 * $load / $numcpu"|bc` -if [[ "x$MAX_ALLOWED_LOAD" == "x" ]]; then - max_load=50 -else - max_load=$MAX_ALLOWED_LOAD -fi -if [[ $lperc -lt $max_load ]];then - echo "$@" | at now + 0 minutes -elif [[ "x$NBLAUNCHER" == "x" ]];then - echo "nbfind $@" | at now + 2 minutes -else - $NBLAUNCHER "$@" -fi - ADDED utils/plot-code.scm Index: utils/plot-code.scm ================================================================== --- /dev/null +++ utils/plot-code.scm @@ -0,0 +1,148 @@ +#!/mfs/pkgs/chicken/4.8.0.5/bin/csi -nbq + +(use regex srfi-69 srfi-13) + +(define targs #f) +(define files (cddddr (argv))) + +(let ((targdat (cadddr (argv)))) + (if (equal? targdat "-") + (set! targs files) + (set! targs (string-split targdat ",")))) + +(define filedat-defns (make-hash-table)) +(define filedat-usages (make-hash-table)) + +(define defn-rx (regexp "^\\s*\\(define\\s+\\(([^\\s\\)]+).*")) +(define all-regexs (make-hash-table)) + +(define all-fns '()) + +(define (print-err . data) + (with-output-to-port (current-error-port) + (lambda () + (apply print data)))) + +(print-err "Making graph for files: " (string-intersperse targs ", ")) +(print-err "Looking at files: " (string-intersperse files ", ")) + +;; Gather the functions +;; +(for-each + (lambda (fname) + (print-err "Processing file " fname) + (with-input-from-file fname + (lambda () + (let loop ((inl (read-line))) + (if (not (eof-object? inl)) + (let ((match (string-match defn-rx inl))) + (if match + (let ((fnname (cadr match))) + ;; (print " " fnname) + (set! all-fns (cons fnname all-fns)) + (hash-table-set! + filedat-defns + fname + (cons fnname (hash-table-ref/default filedat-defns fname '()))) + )) + (loop (read-line)))))))) + files) + +;; fill up the regex hash +(print-err "Make the huge regex hash") +(for-each + (lambda (fnname) + (hash-table-set! all-regexs fnname (regexp (conc "^(|.*[^a-zA-Z]+)" fnname "([^a-zA-Z]+|)$")))) + (cons "toplevel" all-fns)) + +(define breadcrumbs (make-hash-table)) + +(define (have-function inl) + (let loop ((hed (car all-fns)) + (tal (cdr all-fns))) + (if (string-contains inl hed) + #t + (if (null? tal) + #f + (loop (car tal)(cdr tal)))))) + +(define (look-for-all-calls inl fnname) + (if (have-function inl) ;; (string-search have-function-rx inl) + (let loop ((hed (car all-fns)) + (tal (cdr all-fns)) + (res '())) + (let ((match (string-match (hash-table-ref all-regexs hed) inl))) + (if match + (let ((newres (cons hed res))) + (if (null? tal) + newres + (loop (car tal) + (cdr tal) + newres))) + (if (null? tal) + res + (loop (car tal)(cdr tal) res))))) + '())) + +;; Gather the usages +(print "digraph G {") +(define curr-cluster-num 0) +(define function-calls '()) + +(for-each + (lambda (fname) + (let ((last-func #f)) + (print-err "Processing file " fname) + (print "subgraph cluster_" curr-cluster-num " {") + (set! curr-cluster-num (+ curr-cluster-num 1)) + (with-input-from-file fname + (lambda () + (with-output-to-port (current-error-port) + (lambda () + (print "Analyzing file " fname))) + (print "label=\"" fname "\";") + (let loop ((inl (read-line)) + (fnname "toplevel") + (allcalls '())) + (if (eof-object? inl) + (begin + (set! function-calls (cons (list fnname allcalls) function-calls)) + (for-each + (lambda (call-name) + (hash-table-set! breadcrumbs call-name #t)) + allcalls) + (print-err "function: " fnname " allcalls: " allcalls)) + (let ((match (string-match defn-rx inl))) + (if match + (let ((func-name (cadr match))) + (if last-func + (print "\"" func-name "\" -> \"" last-func "\";") + (print "\"" func-name "\";")) + (set! last-func func-name) + (hash-table-set! breadcrumbs func-name #t) + (loop (read-line) + func-name + allcalls)) + (let ((calls (look-for-all-calls inl fnname))) + (loop (read-line) fnname (append allcalls calls))))))))) + (print "}"))) + targs) + +(print-err "breadcrumbs: " (hash-table-keys breadcrumbs)) +(print-err "function-calls: " function-calls) + +(for-each + (lambda (function-call) + (print-err "function-call: " function-call) + (let ((fnname (car function-call)) + (calls (cadr function-call))) + (for-each + (lambda (callname) + (print (if (hash-table-ref/default breadcrumbs callname #f) "" "// ") + "\"" fnname "\" -> \"" callname "\";")) + calls))) + function-calls) + +(print "}") + +(exit) ADDED widgets.scm Index: widgets.scm ================================================================== --- /dev/null +++ widgets.scm @@ -0,0 +1,189 @@ +(require-library srfi-4 iup) +(import srfi-4 iup iup-pplot iup-glcanvas) ;; iup-web + +(define (popup dlg . args) + (apply show dlg #:modal? 'yes args) + (destroy! dlg)) + +(define (properties ih) + (popup (element-properties-dialog ih)) + 'default) + +(define dlg + (dialog + (vbox + (hbox ; headline + (fill) + (frame (label " Inspect control and dialog classes " + fontsize: 15)) + (fill) + margin: '0x0) + + (label "") + (label "Dialogs" fontsize: 12) + (hbox + (button "dialog" + action: (lambda (self) (properties (dialog (vbox))))) + (button "color-dialog" + action: (lambda (self) (properties (color-dialog)))) + (button "file-dialog" + action: (lambda (self) (properties (file-dialog)))) + (button "font-dialog" + action: (lambda (self) (properties (font-dialog)))) + (button "message-dialog" + action: (lambda (self) (properties (message-dialog)))) + (fill) + margin: '0x0) + (hbox + (button "layout-dialog" + action: (lambda (self) (properties (layout-dialog)))) + (button "element-properties-dialog" + action: (lambda (self) + (properties + (element-properties-dialog (create 'user))))) + (fill) + margin: '0x0) + + (label "") + (label "Composition widgets" fontsize: 12) + (hbox + (button "fill" + action: (lambda (self) (properties (fill)))) + (button "hbox" + action: (lambda (self) (properties (hbox)))) + (button "vbox" + action: (lambda (self) (properties (vbox)))) + (button "zbox" + action: (lambda (self) (properties (zbox)))) + (button "radio" + action: (lambda (self) (properties (radio (vbox))))) + (button "normalizer" + action: (lambda (self) (properties (normalizer)))) + (button "cbox" + action: (lambda (self) (properties (cbox)))) + (button "sbox" + action: (lambda (self) (properties (sbox (vbox))))) + (button "split" + action: (lambda (self) (properties (split (vbox) (vbox))))) + (fill) + margin: '0x0) + + (label "") + (label "Standard widgets" fontsize: 12) + (hbox + (button "button" + action: (lambda (self) (properties (button)))) + (button "canvas" + action: (lambda (self) (properties (canvas)))) + (button "frame" + action: (lambda (self) (properties (frame)))) + (button "label" + action: (lambda (self) (properties (label)))) + (button "listbox" + action: (lambda (self) (properties (listbox)))) + (button "progress-bar" + action: (lambda (self) (properties (progress-bar)))) + (button "spin" + action: (lambda (self) (properties (spin)))) + (fill) + margin: '0x0) + (hbox + (button "tabs" + action: (lambda (self) (properties (tabs)))) + (button "textbox" + action: (lambda (self) (properties (textbox)))) + (button "toggle" + action: (lambda (self) (properties (toggle)))) + (button "treebox" + action: (lambda (self) (properties (treebox)))) + (button "valuator" + action: (lambda (self) (properties (valuator "")))) + (fill) + margin: '0x0) + + (label "") + (label "Additional widgets" fontsize: 12) + (hbox + (button "cells" + action: (lambda (self) (properties (cells)))) + (button "color-bar" + action: (lambda (self) (properties (color-bar)))) + (button "color-browser" + action: (lambda (self) (properties (color-browser)))) + (button "dial" + action: (lambda (self) (properties (dial "")))) + (button "matrix" + action: (lambda (self) (properties (matrix)))) + (fill) + margin: '0x0) + (hbox + (button "pplot" + action: (lambda (self) (properties (pplot)))) + (button "glcanvas" + action: (lambda (self) (properties (glcanvas)))) + ;; (button "web-browser" + ;; action: (lambda (self) (properties (web-browser)))) + (fill) + margin: '0x0) + + (label "") + (label "Menu widgets" fontsize: 12) + (hbox + (button "menu" + action: (lambda (self) (properties (menu)))) + (button "menu-item" + action: (lambda (self) (properties (menu-item)))) + (button "menu-separator" + action: (lambda (self) (properties (menu-separator)))) + (fill) + margin: '0x0) + + (label "") + (label "Images" fontsize: 12) + (hbox + (button "image/palette" + action: (lambda (self) + (properties + (image/palette 1 1 (u8vector->blob (u8vector 0)))))) + (button "image/rgb" + action: (lambda (self) + (properties + (image/rgb 1 1 (u8vector->blob (u8vector 0)))))) + (button "image/rgba" + action: (lambda (self) + (properties + (image/rgba 1 1 (u8vector->blob (u8vector 0)))))) + (button "image/file" + action: (lambda (self) + (properties + ;; same attributes as image/palette + (image/palette 1 1 (u8vector->blob (u8vector 0)))))) + ;; needs a file in current directory + ;(image/file "chicken.ico")))) ; ok + ;(image/file "chicken.png")))) ; doesn't work + (fill) + margin: '0x0) + + (label "") + (label "Other widgets" fontsize: 12) + (hbox + (button "clipboard" + action: (lambda (self) (properties (clipboard)))) + (button "timer" + action: (lambda (self) (properties (timer)))) + (button "spinbox" + action: (lambda (self) (properties (spinbox (vbox))))) + (fill) + margin: '0x0) + + (fill) + (button "E&xit" + expand: 'horizontal + action: (lambda (self) 'close)) + ) + margin: '15x15 + title: "Iup inspector")) + +(show dlg) +(main-loop) +(exit 0) DELETED zmq-transport.scm Index: zmq-transport.scm ================================================================== --- zmq-transport.scm +++ /dev/null @@ -1,493 +0,0 @@ - -;; Copyright 2006-2012, Matthew Welland. -;; -;; This program is made available under the GNU GPL version 2.0 or -;; greater. See the accompanying file COPYING for details. -;; -;; This program is distributed WITHOUT ANY WARRANTY; without even the -;; implied warranty of MERCHANTABILITY or FITNESS FOR A PARTICULAR -;; PURPOSE. - -(require-extension (srfi 18) extras tcp s11n) - -(use sqlite3 srfi-1 posix regex regex-case srfi-69 hostinfo md5 message-digest) -(import (prefix sqlite3 sqlite3:)) - -(use zmq) - -(declare (unit zmq-transport)) - -(declare (uses common)) -(declare (uses db)) -(declare (uses tests)) -(declare (uses tasks)) ;; tasks are where stuff is maintained about what is running. -(declare (uses server)) - -(include "common_records.scm") -(include "db_records.scm") - -;; Transition to pub --> sub with pull <-- push -;; -;; 1. client sends request to server via push to the pull port -;; 2. server puts request in queue or processes immediately as appropriate -;; 3. server puts responses from completed requests into pub port -;; -;; TODO -;; -;; Done Tested -;; [x] [ ] 1. Add columns pullport pubport to servers table -;; [x] [ ] 2. Add rm of monitor.db if older than 11/12/2012 -;; [x] [ ] 3. Add create of pullport and pubport with finding of available ports -;; [x] [ ] 4. Add client compose of request -;; [x] [ ] - name of client: testname/itempath-test_id-hostname -;; [x] [ ] - name of request: callname, params -;; [x] [ ] - request key: f(clientname, callname, params) -;; [x] [ ] 5. Add processing of subscription hits -;; [x] [ ] - done when get key -;; [x] [ ] - return results -;; [x] [ ] 6. Add timeout processing -;; [x] [ ] - after 60 seconds -;; [ ] [ ] i. check server alive, connect to new if necessary -;; [ ] [ ] ii. resend request -;; [ ] [ ] 7. Turn self ping back on - -(define (zmq-transport:make-server-url hostport) - (if (not hostport) - #f - (conc "tcp://" (car hostport) ":" (cadr hostport)))) - -(define *server-loop-heart-beat* (current-seconds)) -(define *heartbeat-mutex* (make-mutex)) - -;;====================================================================== -;; S E R V E R -;;====================================================================== - -(define-inline (zmqsock:get-pub dat)(vector-ref dat 0)) -(define-inline (zmqsock:get-pull dat)(vector-ref dat 1)) -(define-inline (zmqsock:set-pub! dat s)(vector-set! dat s 0)) -(define-inline (zmqsock:set-pull! dat s)(vector-set! dat s 0)) - -(define (zmq-transport:run hostn) - (debug:print 2 "Attempting to start the server ...") - (if (not *toppath*) - (if (not (setup-for-run)) - (begin - (debug:print 0 "ERROR: cannot find megatest.config, cannot start server, exiting") - (exit)))) - (let* ((db (open-db)) ;; here we *do not* want to be opening and closing the db - (zmq-sdat1 #f) - (zmq-sdat2 #f) - (pull-socket #f) - (pub-socket #f) - (p1 #f) - (p2 #f) - (zmq-sockets-dat #f) - (iface (if (string=? "-" hostn) - "*" ;; (get-host-name) - hostn)) - (hostname (get-host-name)) - (ipaddrstr (let ((ipstr (if (string=? "-" hostn) - (string-intersperse (map number->string (u8vector->list (hostname->ip hostname))) ".") - #f))) - (if ipstr ipstr hostname))) - (last-run 0)) - (set! zmq-sockets-dat (zmq-transport:setup-ports ipaddrstr (if (args:get-arg "-port") - (string->number (args:get-arg "-port")) - (+ 5000 (random 1001))))) - - (set! zmq-sdat1 (car zmq-sockets-dat)) - (set! pull-socket (cadr zmq-sdat1)) ;; (iface s port) - (set! p1 (caddr zmq-sdat1)) - - (set! zmq-sdat2 (cadr zmq-sockets-dat)) - (set! pub-socket (cadr zmq-sdat2)) - (set! p2 (caddr zmq-sdat2)) - - (set! *cache-on* #t) - - (set! *runremote* (vector pull-socket pub-socket)) ;; overloading the use of *runremote* BUG!? - - ;; what to do when we quit - ;; -;; (on-exit (lambda () -;; (if (and *toppath* *server-info*) -;; (open-run-close tasks:server-deregister-self tasks:open-db (car *server-info*)) -;; (let loop () -;; (let ((queue-len 0)) -;; (thread-sleep! (random 5)) -;; (mutex-lock! *incoming-mutex*) -;; (set! queue-len (length *incoming-data*)) -;; (mutex-unlock! *incoming-mutex*) -;; (if (> queue-len 0) -;; (begin -;; (debug:print-info 0 "Queue not flushed, waiting ...") -;; (loop)))))))) - - ;; The heavy lifting - ;; - ;; make-vector-record cdb packet client-sig qtype immediate query-sig params qtime - ;; - (debug:print-info 11 "Server setup complete, start listening for messages") - (let loop ((queue-lst '())) - (let* ((rawmsg (receive-message* pull-socket)) - (packet (db:string->obj rawmsg)) - (qtype (cdb:packet-get-qtype packet))) - (debug:print-info 12 "server=> received packet=" packet) - (if (not (member qtype '(sync ping))) - (begin - (mutex-lock! *heartbeat-mutex*) - (set! *last-db-access* (current-seconds)) - (mutex-unlock! *heartbeat-mutex*))) - (if #t ;; (cdb:packet-get-immediate packet) ;; process immediately or put in queue - (begin - (db:process-queue-item db packet) - ;; (open-run-close db:process-queue #f pub-socket (cons packet queue-lst)) - - (loop '())) - (loop (cons packet queue-lst))))))) - -;; run zmq-transport:keep-running in a parallel thread to monitor that the db is being -;; used and to shutdown after sometime if it is not. -;; -(define (zmq-transport:keep-running) - ;; if none running or if > 20 seconds since - ;; server last used then start shutdown - ;; This thread waits for the server to come alive - (let* ((server-info (let loop () - (let ((sdat #f)) - (mutex-lock! *heartbeat-mutex*) - (set! sdat *server-info*) - (mutex-unlock! *heartbeat-mutex*) - (if sdat sdat - (begin - (debug:print 12 "WARNING: server not started yet, waiting few seconds before trying again") - (sleep 4) - (loop)))))) - (iface (cadr server-info)) - (pullport (caddr server-info)) - (pubport (cadddr server-info)) ;; id interface pullport pubport) - ;; (zmq-sockets (zmq-transport:client-connect iface pullport pubport)) - (last-access 0)) - (debug:print-info 11 "heartbeat started for zmq server on " iface " " pullport " " pubport) - (let loop ((count 0)) - (thread-sleep! 4) ;; no need to do this very often - ;; NB// sync currently does NOT return queue-length - ;; GET REAL QUEUE LENGTH FROM THE VARIABLE - (let ((queue-len 0)) ;; FOR NOW DO NOT DO THIS (cdb:client-call zmq-sockets 'sync #t 1))) - ;; (print "Server running, count is " count) - (if (< count 1) ;; 3x3 = 9 secs aprox - (loop (+ count 1))) - - ;; NOTE: Get rid of this mechanism! It really is not needed... - (open-run-close tasks:server-update-heartbeat tasks:open-db (car server-info)) - - ;; (if ;; (or (> numrunning 0) ;; stay alive for two days after last access - (mutex-lock! *heartbeat-mutex*) - (set! last-access *last-db-access*) - (mutex-unlock! *heartbeat-mutex*) - (if (> (+ last-access - ;; (* 50 60 60) ;; 48 hrs - ;; 60 ;; one minute - ;; (* 60 60) ;; one hour - (* 45 60) ;; 45 minutes, until the db deletion bug is fixed. - ) - (current-seconds)) - (begin - (debug:print-info 2 "Server continuing, seconds since last db access: " (- (current-seconds) last-access)) - (loop 0)) - (begin - (debug:print-info 0 "Starting to shutdown the server.") - ;; need to delete only *my* server entry (future use) - (set! *time-to-exit* #t) - (open-run-close tasks:server-deregister-self tasks:open-db (get-host-name)) - (thread-sleep! 1) - (debug:print-info 0 "Max cached queries was " *max-cache-size*) - (debug:print-info 0 "Server shutdown complete. Exiting") - (exit))))))) - -(define (zmq-transport:find-free-port-and-open iface s port stype #!key (trynum 50)) - (let ((s (if s s (make-socket stype))) - (p (if (number? port) port 5555)) - (old-handler (current-exception-handler))) - (handle-exceptions - exn - (begin - (debug:print 0 "Failed to bind to port " p ", trying next port") - (debug:print 0 " EXCEPTION: " ((condition-property-accessor 'exn 'message) exn)) - ;; (old-handler) - ;; (print-call-chain) - (if (> trynum 0) - (zmq-transport:find-free-port-and-open iface s (+ p 1) trynum: (- trynum 1)) - (debug:print-info 0 "Tried ports up to " p - " but all were in use. Please try a different port range by starting the server with parameter \" -port N\" where N is the starting port number to use")) - (exit)) ;; To exit or not? That is the question. - (let ((zmq-url (conc "tcp://" iface ":" p))) - (debug:print 2 "Trying to start server on " zmq-url) - (bind-socket s zmq-url) - (list iface s port))))) - -(define (zmq-transport:setup-ports ipaddrstr startport) - (let* ((s1 (zmq-transport:find-free-port-and-open ipaddrstr #f startport 'pull)) - (p1 (caddr s1)) - (s2 (zmq-transport:find-free-port-and-open ipaddrstr #f (+ 1 (if p1 p1 (+ startport 1))) 'pub)) - (p2 (caddr s2))) - (set! *runremote* #f) - (debug:print 0 "Server started on " ipaddrstr " ports " p1 " and " p2) - (mutex-lock! *heartbeat-mutex*) - (set! *server-info* (open-run-close tasks:server-register - tasks:open-db - (current-process-id) - ipaddrstr p1 - 0 - 'live - 'zmq - pubport: p2)) - (debug:print-info 11 "*server-info* set to " *server-info*) - (mutex-unlock! *heartbeat-mutex*) - (list s1 s2))) - -(define (zmq-transport:mk-signature) - (message-digest-string (md5-primitive) - (with-output-to-string - (lambda () - (write (list (current-directory) - (argv))))))) - -;;====================================================================== -;; S E R V E R U T I L I T I E S -;;====================================================================== - -;;====================================================================== -;; C L I E N T S -;;====================================================================== - -;; -(define (zmq-transport:client-socket-connect iface port #!key (context #f)(type 'req)(subscriptions '())) - (debug:print-info 3 "client-connect " iface ":" port ", type=" type ", subscriptions=" subscriptions) - (let ((connect-ok #f) - (zmq-socket (if context - (make-socket type context) - (make-socket type))) - (conurl (zmq-transport:make-server-url (list iface port)))) - (if (socket? zmq-socket) - (begin - ;; first apply subscriptions - (for-each (lambda (subscription) - (debug:print 2 "Subscribing to " subscription) - (socket-option-set! zmq-socket 'subscribe subscription)) - subscriptions) - (connect-socket zmq-socket conurl) - zmq-socket) - (begin - (debug:print 0 "ERROR: Failed to open socket to " conurl) - #f)))) - -(define (zmq-transport:client-connect iface pullport pubport) - (let* ((push-socket (zmq-transport:client-socket-connect iface pullport type: 'push)) - (sub-socket (zmq-transport:client-socket-connect iface pubport - type: 'sub - subscriptions: (list (client:get-signature) "all"))) - (zmq-sockets (vector push-socket sub-socket)) - (login-res #f)) - (debug:print-info 11 "zmq-transport:client-connect started. Next is login") - (set! login-res (client:login serverdat zmq-sockets)) - (if (and (not (null? login-res)) - (car login-res)) - (begin - (debug:print-info 2 "Logged in and connected to " iface ":" pullport "/" pubport ".") - (set! *runremote* zmq-sockets) - zmq-sockets) - (begin - (debug:print-info 2 "Failed to login or connect to " conurl) - (set! *runremote* #f) - #f)))) - -;; run zmq-transport:keep-running in a parallel thread to monitor that the db is being -;; used and to shutdown after sometime if it is not. -;; -(define (zmq-transport:keep-running) - ;; if none running or if > 20 seconds since - ;; server last used then start shutdown - ;; This thread waits for the server to come alive - (let* ((server-info (let loop () - (let ((sdat #f)) - (mutex-lock! *heartbeat-mutex*) - (set! sdat *runremote*) - (mutex-unlock! *heartbeat-mutex*) - (if sdat sdat - (begin - (sleep 4) - (loop)))))) - (iface (car server-info)) - (port (cadr server-info)) - (last-access 0) - (tdb (tasks:open-db)) - (spid (tasks:server-get-server-id tdb #f iface port #f))) - (print "Keep-running got server pid " spid ", using iface " iface " and port " port) - (let loop ((count 0)) - (thread-sleep! 4) ;; no need to do this very often - ;; NB// sync currently does NOT return queue-length - (let () ;; (queue-len (cdb:client-call server-info 'sync #t 1))) - ;; (print "Server running, count is " count) - (if (< count 1) ;; 3x3 = 9 secs aprox - (loop (+ count 1))) - - ;; NOTE: Get rid of this mechanism! It really is not needed... - (tasks:server-update-heartbeat tdb spid) - - ;; (if ;; (or (> numrunning 0) ;; stay alive for two days after last access - (mutex-lock! *heartbeat-mutex*) - (set! last-access *last-db-access*) - (mutex-unlock! *heartbeat-mutex*) - (if (> (+ last-access - ;; (* 50 60 60) ;; 48 hrs - ;; 60 ;; one minute - ;; (* 60 60) ;; one hour - (* 45 60) ;; 45 minutes, until the db deletion bug is fixed. - ) - (current-seconds)) - (begin - (debug:print-info 2 "Server continuing, seconds since last db access: " (- (current-seconds) last-access)) - (loop 0)) - (begin - (debug:print-info 0 "Starting to shutdown the server.") - ;; need to delete only *my* server entry (future use) - (set! *time-to-exit* #t) - (tasks:server-deregister-self tdb (get-host-name)) - (thread-sleep! 1) - (debug:print-info 0 "Max cached queries was " *max-cache-size*) - (debug:print-info 0 "Server shutdown complete. Exiting") - (exit))))))) - -;; all routes though here end in exit ... -(define (zmq-transport:launch) - (if (not *toppath*) - (if (not (setup-for-run)) - (begin - (debug:print 0 "ERROR: cannot find megatest.config, exiting") - (exit)))) - (debug:print-info 2 "Starting zmq server") - (if *toppath* - (let* (;; (th1 (make-thread (lambda () - ;; (let ((server-info #f)) - ;; ;; wait for the server to be online and available - ;; (let loop () - ;; (debug:print-info 2 "Waiting for the server to come online before starting heartbeat") - ;; (thread-sleep! 2) - ;; (mutex-lock! *heartbeat-mutex*) - ;; (set! server-info *server-info* ) - ;; (mutex-unlock! *heartbeat-mutex*) - ;; (if (not server-info)(loop))) - ;; (debug:print 2 "Server alive, starting self-ping") - ;; (zmq-transport:self-ping server-info) - ;; )) - ;; "Self ping")) - (th2 (make-thread (lambda () - (zmq-transport:run - (if (args:get-arg "-server") - (args:get-arg "-server") - "-"))) "Server run")) - ;; (th3 (make-thread (lambda ()(zmq-transport:keep-running)) "Keep running")) - ) - (set! *client-non-blocking-mode* #t) - ;; (thread-start! th1) - (thread-start! th2) - ;; (thread-start! th3) - (set! *didsomething* #t) - ;; (thread-join! th3) - (thread-join! th2) - ) - (debug:print 0 "ERROR: Failed to setup for megatest"))) - -(define (zmq-transport:client-signal-handler signum) - (handle-exceptions - exn - (debug:print " ... exiting ...") - (let ((th1 (make-thread (lambda () - (if (not *received-response*) - (receive-message* *runremote*))) ;; flush out last call if applicable - "eat response")) - (th2 (make-thread (lambda () - (debug:print 0 "ERROR: Received ^C, attempting clean exit. Please be patient and wait a few seconds before hitting ^C again.") - (thread-sleep! 3) ;; give the flush three seconds to do it's stuff - (debug:print 0 " Done.") - (exit 4)) - "exit on ^C timer"))) - (thread-start! th2) - (thread-start! th1) - (thread-join! th2)))) - -(define (zmq-transport:client-launch) - (set-signal-handler! signal/int zmq-transport:client-signal-handler) - (if (zmq-transport:client-setup) - (debug:print-info 2 "connected as client") - (begin - (debug:print 0 "ERROR: Failed to connect as client") - (exit)))) - -;;====================================================================== -;; Defunct functions -;;====================================================================== - -;; ping a server and return number of clients or #f (if no response) -;; NOT IN USE! -(define (zmq-transport:ping host port #!key (secs 10)(return-socket #f)) - (cdb:use-non-blocking-mode - (lambda () - (let* ((res #f) - (th1 (make-thread - (lambda () - (let* ((zmq-context (make-context 1)) - (zmq-socket (zmq-transport:client-connect host port context: zmq-context))) - (if zmq-socket - (if (zmq-transport:client-login zmq-socket) - (let ((numclients (cdb:num-clients zmq-socket))) - (if (not return-socket) - (begin - (zmq-transport:client-logout zmq-socket) - (close-socket zmq-socket))) - (set! res (list #t numclients (if return-socket zmq-socket #f)))) - (begin - ;; (close-socket zmq-socket) - (set! res (list #f "CAN'T LOGIN" #f)))) - (set! res (list #f "CAN'T CONNECT" #f))))) - "Ping: th1")) - (th2 (make-thread - (lambda () - (let loop ((count 1)) - (debug:print-info 1 "Ping " count " server on " host " at port " port) - (thread-sleep! 2) - (if (< count (/ secs 2)) - (loop (+ count 1)))) - ;; (thread-terminate! th1) - (set! res (list #f "TIMED OUT" #f))) - "Ping: th2"))) - (thread-start! th2) - (thread-start! th1) - (handle-exceptions - exn - (set! res (list #f "TIMED OUT" #f)) - (thread-join! th1 secs)) - res)))) - -;; (define (zmq-transport:self-ping server-info) -;; ;; server-info: server-id interface pullport pubport -;; (let ((iface (list-ref server-info 1)) -;; (pullport (list-ref server-info 2)) -;; (pubport (list-ref server-info 3))) -;; (zmq-transport:client-connect iface pullport pubport) -;; (let loop () -;; (thread-sleep! 2) -;; (cdb:client-call *runremote* 'ping #t) -;; (debug:print 4 "zmq-transport:self-ping - I'm alive on " iface ":" pullport "/" pubport "!") -;; (mutex-lock! *heartbeat-mutex*) -;; (set! *server-loop-heart-beat* (current-seconds)) -;; (mutex-unlock! *heartbeat-mutex*) -;; (loop)))) - -(define (zmq-transport:reply pubsock target query-sig success/fail result) - (debug:print-info 11 "zmq-transport:reply target=" target ", result=" result) - (send-message pubsock target send-more: #t) - (send-message pubsock (db:obj->string (vector success/fail query-sig result)))) -

State stats