Index: Makefile ================================================================== --- Makefile +++ Makefile @@ -1,6 +1,8 @@ # make install CSCOPTS='-accumulate-profile -profile-name $(PWD)/profile-ww$(shell date +%V.%u)' +# rm .o ; make install CSCOPTS='-profile' ; ... ; chicken-profile | less + PREFIX=$(PWD) CSCOPTS= INSTALL=install SRCFILES = common.scm items.scm launch.scm \ ods.scm runconfig.scm server.scm configf.scm \ ADDED Makefile.deploy Index: Makefile.deploy ================================================================== --- /dev/null +++ Makefile.deploy @@ -0,0 +1,341 @@ +# make install CSCOPTS='-accumulate-profile -profile-name $(PWD)/profile-ww$(shell date +%V.%u)' +PREFIX=$(PWD) +CSCOPTS= -deploy +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 \ + http-transport.scm filedb.scm \ + client.scm synchash.scm daemon.scm mt.scm \ + ezsteps.scm lock-queue.scm sdb.scm \ + rmt.scm api.scm tdb.scm rpc-transport.scm \ + portlogger.scm archive.scm env.scm + +# Eggs to install (straightforward ones) +EGGS=crypt 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 gutils.scm dcommon.scm tree.scm vg.scm + +OFILES = $(SRCFILES:%.scm=%.o) +GOFILES = $(GUISRCF:%.scm=%.o) + +ADTLSCR=mt_laststep mt_runstep mt_ezstep +HELPERS=$(addprefix $(PREFIX)/bin/,$(ADTLSCR)) +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") + +PNGFILES = $(shell cd docs/manual;ls *png) + +ARCHSIZE=64_ +IMVER=3.11 +IUPVER=3.17 +KTYPE=26g4 +CDVER=5.10 + +all : $(PREFIX)/bin/.$(ARCHSTR) mtest dboard eggs sqlite matt iup + +mtest: $(OFILES) readline-fix.scm megatest.o + mkdir -p $(PREFIX)/deploy + csc $(CSCOPTS) $(OFILES) megatest.o -o $(PREFIX)/deploy/mtest + +eggs: $(PREFIX)/deploy/mtest/fmt.so + +$(PREFIX)/deploy/mtest/fmt.so: + chicken-install -deploy -p $(PREFIX)/deploy/mtest base64 format regex-case simple-exceptions typed-records apropos directory-utils md5 spiffy http-client spiffy-request-vars spiffy-directory-listing posix-extras call-with-environment-variables csv typed-records pathname-expand json crypt dot-locking csv-xml z3 sql-de-lite hostinfo rpc directory-utils md5 spiffy http-client spiffy-request-vars spiffy-directory-listing posix-extras call-with-environment-variables rpc fmt + +sqlite: $(PREFIX)/deploy/mtest/sqlite3.so + +$(PREFIX)/deploy/mtest/sqlite3.so: + wget http://www.sqlite.org/2015/sqlite-autoconf-3090200.tar.gz + tar xfz sqlite-autoconf-3090200.tar.gz + cd sqlite-autoconf-3090200 + cd sqlite-autoconf-3090200 && ./configure --prefix=`realpath $(PREFIX)/deploy/mtest` + cd sqlite-autoconf-3090200 && make + cd sqlite-autoconf-3090200 && make install + CSC_OPTIONS='-I$(PREFIX)/deploy/mtest/include -L$(PREFIX)/deploy/mtest/' chicken-install -deploy -p $(PREFIX)/deploy/mtest sqlite3 + +matt: $(PREFIX)/deploy/mtest/stml.so + +$(PREFIX)/deploy/mtest/stml.so: + wget -c -O stml.tar.gz 'http://www.kiatoa.com/fossils/stml/tarball?name=stml&uuid=trunk' + tar -xzf stml.tar.gz + cd stml && cp install.cfg.template install.cfg + cd stml && echo "TARGDIR=`realpath $(PREFIX)/deploy/mtest`" > install.cfg + cd stml && echo "LOGDIR=/tmp/stmlrun" >> install.cfg + cd stml && echo "SQLITE3=$PREFIX/bin/sqlite3" >> install.cfg + cd stml && cp requirements.scm.template requirements.scm + cd stml && make clean + -cd stml && CSCOPTS="-C -fPIC" make + cd stml && chicken-install -deploy -p $(PREFIX)/deploy/mtest + wget -c -O opensrc.tar.gz 'http://www.kiatoa.com/fossils/opensrc/tarball?name=opensrc&uuid=trunk' + tar -xzf opensrc.tar.gz + cd opensrc/mutils && chicken-install -deploy -p $(PREFIX)/deploy/mtest + cd opensrc/dbi && chicken-install -deploy -p $(PREFIX)/deploy/mtest + cd opensrc/margs && chicken-install -deploy -p $(PREFIX)/deploy/mtest + +iup: $(PREFIX)/deploy/mtest/iup.so + +$(PREFIX)/deploy/mtest/iup.so: + wget -c http://www.kiatoa.com/matt/chicken-build/cd/cd-${CDVER}_Linux${KTYPE}_${ARCHSIZE}lib.tar.gz + wget -c http://www.kiatoa.com/matt/chicken-build/im/im-${IMVER}_Linux${KTYPE}_${ARCHSIZE}lib.tar.gz + wget -c http://www.kiatoa.com/matt/chicken-build/iup/iup-${IUPVER}_Linux${KTYPE}_${ARCHSIZE}lib.tar.gz + tar -xzvf cd-${CDVER}_Linux${KTYPE}_${ARCHSIZE}lib.tar.gz -C $(PREFIX)/deploy/mtest/ + tar -xzvf im-${IMVER}_Linux${KTYPE}_${ARCHSIZE}lib.tar.gz -C $(PREFIX)/deploy/mtest/ + tar -xzvf iup-${IUPVER}_Linux${KTYPE}_${ARCHSIZE}lib.tar.gz -C $(PREFIX)/deploy/mtest/ + cp $(PREFIX)/deploy/mtest/ftgl/lib/*/* $(PREFIX)/deploy/mtest/ + wget -c -O ffcall.tar.gz 'http://www.kiatoa.com/fossils/ffcall/tarball?name=ffcall&uuid=trunk' + tar -xzf ffcall.tar.gz + cd ffcall && ./configure --prefix=`realpath $(PREFIX)/deploy/mtest/` --enable-shared + cd ffcall && make CC="gcc -fPIC" + cd ffcall && make install + CSC_OPTIONS="-I$(PREFIX)/deploy/mtest/include -L$(PREFIX)/deploy/mtest" chicken-install -deploy -p $(PREFIX)/deploy/mtest -D no-library-checks -feature disable-iup-web iup + CSC_OPTIONS="-I$(PREFIX)/deploy/mtest/include -L$(PREFIX)/deploy/mtest" chicken-install -deploy -p $(PREFIX)/deploy/mtest -D no-library-checks canvas-draw + +dboard: $(OFILES) $(GOFILES) dashboard.scm + csc $(CSCOPTS) $(OFILES) dashboard.scm $(GOFILES) -o $(PREFIX)/deploy/mtest/dboard2 + cp $(PREFIX)/deploy/mtest/dboard2/dboard2 $(PREFIX)/deploy/mtest/dboard + +ndboard : newdashboard.scm $(OFILES) $(GOFILES) + csc $(CSCOPTS) $(OFILES) $(GOFILES) newdashboard.scm -o $(PREFIX)/deploy/mtest/newdboard + +# install documentation to $(PREFIX)/docs +# DOES NOT REBUILD DOCS +# +$(PREFIX)/share/docs/megatest_manual.html : docs/manual/megatest_manual.html + mkdir -p $(PREFIX)/share/docs + $(INSTALL) docs/manual/megatest_manual.html $(PREFIX)/share/docs/megatest_manual.html + for png in $(PNGFILES);do $(INSTALL) docs/manual/$$png $(PREFIX)/share/docs/$$png;done + +#multi-dboard : multi-dboard.scm $(OFILES) $(GOFILES) +# csc $(CSCOPTS) $(OFILES) $(GOFILES) multi-dboard.scm -o multi-dboard + +# +# $(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 \ +archive.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 : common_records.scm rpc-transport.scm +common_records.scm : altdb.scm +vg.o dashboard.o : vg_records.scm +dcommon.o : run_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 + echo "(define megatest-fossil-hash \"$(MTESTHASH)\")" > megatest-fossil-hash.new + if ! diff -q megatest-fossil-hash.new megatest-fossil-hash.scm ; then echo copying .new to .scm;cp -f megatest-fossil-hash.new megatest-fossil-hash.scm;fi + +$(OFILES) $(GOFILES) : common_records.scm + +%.o : %.scm + csc $(CSCOPTS) -c $< + +$(PREFIX)/bin/.$(ARCHSTR)/mtest : mtest utils/mk_wrapper + @echo Installing to PREFIX=$(PREFIX) + $(INSTALL) mtest $(PREFIX)/bin/.$(ARCHSTR)/mtest + utils/mk_wrapper $(PREFIX) mtest $(PREFIX)/bin/megatest + chmod a+x $(PREFIX)/bin/megatest + +$(PREFIX)/bin/.$(ARCHSTR)/ndboard : ndboard + $(INSTALL) ndboard $(PREFIX)/bin/.$(ARCHSTR)/ndboard + +$(PREFIX)/bin/newdashboard : $(PREFIX)/bin/.$(ARCHSTR)/ndboard utils/mk_wrapper + utils/mk_wrapper $(PREFIX) ndboard $(PREFIX)/bin/newdashboard + chmod a+x $(PREFIX)/bin/newdashboard + +#$(PREFIX)/bin/.$(ARCHSTR)/mdboard : multi-dboard +# $(INSTALL) multi-dboard $(PREFIX)/bin/.$(ARCHSTR)/mdboard + +# $(PREFIX)/bin/mdboard : $(PREFIX)/bin/.$(ARCHSTR)/mdboard utils/mk_wrapper +# utils/mk_wrapper $(PREFIX) mdboard $(PREFIX)/bin/mdboard +# chmod a+x $(PREFIX)/bin/mdboard + +# $(HELPERS) : utils/% +# $(INSTALL) $< $@ +# chmod a+x $@ + +$(PREFIX)/bin/mt_laststep : utils/mt_laststep + $(INSTALL) $< $@ + chmod a+x $@ + +$(PREFIX)/bin/mt_runstep : utils/mt_runstep + $(INSTALL) $< $@ + chmod a+x $@ + +$(PREFIX)/bin/mt_ezstep : utils/mt_ezstep + $(INSTALL) $< $@ + chmod a+x $@ + +$(PREFIX)/bin/mt_xterm : utils/mt_xterm + $(INSTALL) $< $@ + chmod a+x $@ + +$(PREFIX)/bin/nbfake : utils/nbfake + $(INSTALL) $< $@ + chmod a+x $@ + +$(PREFIX)/bin/viewscreen : utils/viewscreen + $(INSTALL) $< $@ + 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 $@ + +deploytarg/nbfake : utils/nbfake + $(INSTALL) $< $@ + chmod a+x $@ + +deploytarg/viewscreen : utils/viewscreen + $(INSTALL) $< $@ + chmod a+x $@ + +deploytarg/nbfind : utils/nbfind + $(INSTALL) $< $@ + chmod a+x $@ + +# install dashboard as dboard so wrapper script can be called dashboard +$(PREFIX)/bin/.$(ARCHSTR)/dboard : dboard $(FILES) utils/mk_wrapper + utils/mk_wrapper $(PREFIX) dboard $(PREFIX)/bin/dashboard + chmod a+x $(PREFIX)/bin/dashboard + $(INSTALL) dboard $(PREFIX)/bin/.$(ARCHSTR)/dboard + +install : $(PREFIX)/bin/.$(ARCHSTR) $(PREFIX)/bin/.$(ARCHSTR)/mtest $(PREFIX)/bin/megatest \ + $(PREFIX)/bin/.$(ARCHSTR)/dboard $(PREFIX)/bin/dashboard $(HELPERS) $(PREFIX)/bin/nbfake \ + $(PREFIX)/bin/nbfind $(PREFIX)/bin/loadrunner $(PREFIX)/bin/viewscreen $(PREFIX)/bin/mt_xterm \ + $(PREFIX)/share/docs/megatest_manual.html + +$(PREFIX)/bin/.$(ARCHSTR) : + mkdir -p $(PREFIX)/bin/.$(ARCHSTR) + +test: tests/tests.scm + cd tests;csi -I .. -b -n tests.scm + +ext-tests/.fslckout : $(MTQA_FOSSIL) + mkdir -p ext-tests + cd ext-tests;fossil open --nested $(MTQA_FOSSIL) + +$(MTQA_FOSSIL) : + fossil clone https://www.kiatoa.com/fossils/megatest_qa $(MTQA_FOSSIL) + +clean : + rm -f $(OFILES) $(GOFILES) megatest dboard dboard.o megatest.o dashboard.o megatest-fossil-hash.* altdb.scm + +#====================================================================== +# Make the records files +#====================================================================== + +# vg_records.scm : records.sh +# ./records.sh + +#====================================================================== +# Deploy section (not complete yet) +#====================================================================== + +$(DEPLOYHELPERS) : utils/mt_* + $(INSTALL) $< $@ + chmod a+X $@ + +deploytarg/apropos.so : Makefile + chicken-install -p deploytarg -deploy -keep-installed $(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/viewsceen 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 $(CSCOPTS) datashare.scm $(OFILES) -o datashare-testing/sd + +datashare-testing/sdat: sharedat.scm $(OFILES) + csc $(CSCOPTS) sharedat.scm $(OFILES) -o datashare-testing/sdat + +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 &) + +datashare-testing/spublish : spublish.scm $(OFILES) + csc $(CSCOPTS) spublish.scm $(OFILES) -o datashare-testing/spublish + +datashare-testing/sretrieve : sretrieve.scm megatest-version.o margs.o configf.o process.o + csc $(CSCOPTS) sretrieve.scm megatest-version.o margs.o configf.o process.o -o datashare-testing/sretrieve + +sretrieve/sretrieve : datashare-testing/sretrieve + csc $(CSCOPTS) -deploy -deployed sretrieve.scm megatest-version.o margs.o configf.o process.o + chicken-install -keep-installed $(PROXY) -deploy -prefix sretrieve defstruct srfi-18 format sql-de-lite \ + srfi-1 posix regex regex-case srfi-69 + +# base64 dot-locking \ +# csv-xml z3 + +# "(define (toplevel-command . a) #f)" +# if egrep 'version.*3.0' $(shell dirname $(shell dirname $(shell which csi)))/lib/chicken/7/readline.setup-info;then \ + +readline-fix.scm : + if [[ $(shell chicken-status | grep readline | awk '{print $4}' | cut -d. -f1) -gt 3 ]];then \ + echo "(define *use-new-readline* #f)" > readline-fix.scm; \ + else \ + echo "(define *use-new-readline* #t)" > readline-fix.scm;\ + fi + +altdb.scm : + echo ";; optional alternate db setup" > altdb.scm + echo "(define *available-db* (make-hash-table))" >> altdb.scm + if csi -ne '(use mysql-client)';then \ + echo "(use mysql-client)(hash-table-set! *available-db* 'mysql #t)" >> altdb.scm; \ + fi + if csi -ne '(use postgresql)';then \ + echo "(use postgresql)(hash-table-set! *available-db* 'postgresql #t)" >> altdb.scm;\ + fi + +portlogger-example : portlogger-example.scm api.o archive.o client.o common.o configf.o daemon.o dashboard-tests.o db.o dcommon.o ezsteps.o filedb.o genexample.o gutils.o http-transport.o items.o keys.o launch.o lock-queue.o margs.o megatest-version.o mt.o ods.o portlogger.o process.o rmt.o rpc-transport.o runconfig.o runs.o sdb.o server.o synchash.o tasks.o tdb.o tests.o tree.o + csc $(CSCOPTS) portlogger-example.scm api.o archive.o client.o common.o configf.o daemon.o dashboard-tests.o db.o dcommon.o ezsteps.o filedb.o genexample.o gutils.o http-transport.o items.o keys.o launch.o lock-queue.o margs.o megatest-version.o mt.o ods.o portlogger.o process.o rmt.o rpc-transport.o runconfig.o runs.o sdb.o server.o synchash.o tasks.o tdb.o tests.o tree.o Index: api.scm ================================================================== --- api.scm +++ api.scm @@ -107,11 +107,11 @@ (define (api:execute-requests dbstruct dat) (handle-exceptions exn (let ((call-chain (get-call-chain))) (print-call-chain (current-error-port)) - (debug:print 0 *default-log-port* " message: " ((condition-property-accessor 'exn 'message) exn)) + (debug:print 0 *default-log-port* " message: " ((condition-property-accessor 'exn 'message) exn)) (vector #f (vector exn call-chain dat))) ;; return some stuff for debug if an exception happens (if (not (vector? dat)) ;; it is an error to not receive a vector (vector #f #f "remote must be called with a vector") (vector ;; return a vector + the returned data structure #t Index: client.scm ================================================================== --- client.scm +++ client.scm @@ -12,14 +12,14 @@ ;; C L I E N T S ;;====================================================================== (require-extension (srfi 18) extras tcp s11n) -(use sqlite3 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) ;; (use zmq) -(import (prefix sqlite3 sqlite3:)) +(use (prefix sqlite3 sqlite3:)) (use spiffy uri-common intarweb http-client spiffy-request-vars uri-common intarweb directory-utils) (declare (unit client)) @@ -50,13 +50,13 @@ ((zmq) (zmq:client-connect iface port)) (else (rpc:client-connect iface port)))) (define (client:setup run-id #!key (remaining-tries 10) (failed-connects 0)) (case (server:get-transport) - ((rpc) (rpc-transport:client-setup run-id)) ;;(client:setup-rpc run-id)) - ((http)(client:setup-http run-id)) - (else (rpc-transport:client-setup run-id)))) ;; (client:setup-rpc run-id)))) + ((rpc) (rpc-transport:client-setup run-id remaining-tries: remaining-tries failed-connects: failed-connects)) ;;(client:setup-rpc run-id)) + ((http)(client:setup-http run-id remaining-tries: remaining-tries failed-connects: failed-connects)) + (else (rpc-transport:client-setup run-id remaining-tries: remaining-tries failed-connects: failed-connects)))) ;; (client:setup-rpc run-id)))) ;; (define (client:login-no-auto-setup server-info run-id) ;; (case (server:get-transport) ;; ((rpc) (rpc:login-no-auto-client-setup server-info run-id)) ;; ((http) (rmt:login-no-auto-client-setup server-info run-id)) 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 srfi-1 posix regex-case base64 format dot-locking csv-xml z3 sql-de-lite hostinfo) +(use srfi-1 posix regex-case base64 format dot-locking csv-xml z3 sql-de-lite hostinfo typed-records) (require-extension regex posix) (require-extension (srfi 18) extras tcp rpc) (import (prefix sqlite3 sqlite3:)) @@ -42,10 +42,32 @@ (define home (getenv "HOME")) (define user (getenv "USER")) ;; GLOBAL GLETCHES + +(define *contexts* (make-hash-table)) + +;; Common data structure for +(defstruct cxt + (taskdb #f) + (cmutex (make-mutex))) + +;; safe method for accessing a context given a toppath +;; +(define (common:with-cxt toppath proc) + (mutex-lock! *context-mutex*) + (let ((cxt (hash-table-ref/default *contexts* toppath #f))) + (if (not cxt) + (set! cxt (let ((x (make-cxt)))(hash-table-set! *contexts* toppath x) x))) + (let ((cxt-mutex (cxt-mutex cxt))) + (mutex-unlock! *context-mutex*) + (mutex-lock! cxt-mutex) + (let ((res (proc cxt))) + (mutex-unlock! cxt-mutex) + res)))) + (define *db-keys* #f) (define *configinfo* #f) ;; raw results from setup, includes toppath and table from megatest.config (define *runconfigdat* #f) ;; run configs data (define *configdat* #f) ;; megatest.config data @@ -114,10 +136,14 @@ ;; This is a cache of pre-reqs met, don't re-calc in cases where called with same params less than ;; five seconds ago (define *pre-reqs-met-cache* (make-hash-table)) +;; cache of verbosity given string +;; +(define *verbosity-cache* (make-hash-table)) + (define (common:clear-caches) (set! *target* (make-hash-table)) (set! *keys* (make-hash-table)) (set! *keyvals* (make-hash-table)) (set! *toptest-paths* (make-hash-table)) @@ -130,10 +156,12 @@ ;; Generic string database (define sdb:qry #f) ;; (make-sdb:qry)) ;; 'init #f) ;; Generic path database (define *fdb* #f) + +(define *last-launch* (current-seconds)) ;; use for throttling the launch rate. Would be better to use the db and last time of a test in LAUNCHED state. ;;====================================================================== ;; V E R S I O N ;;====================================================================== @@ -370,10 +398,11 @@ ;; E X I T H A N D L I N G ;;====================================================================== (define (common:legacy-sync-recommended) (or (args:get-arg "-runtests") + (args:get-arg "-run") (args:get-arg "-server") ;; (args:get-arg "-set-run-status") (args:get-arg "-remove-runs") ;; (args:get-arg "-get-run-status") )) @@ -1180,10 +1209,18 @@ ;; ((RUNNING) "9 131 232") ;; ((KILLREQ) "39 82 206") ;; ((KILLED) "234 101 17") ;; ((NOT_STARTED) "240 240 240") ;; (else "192 192 192"))) + +(define (common:iup-color->rgb-hex instr) + (string-intersperse + (map (lambda (x) + (number->string x 16)) + (map string->number + (string-split instr))) + "/")) (define (common:get-color-from-status status) (cond ((equal? status "PASS") "green") ((equal? status "FAIL") "red") Index: common_records.scm ================================================================== --- common_records.scm +++ common_records.scm @@ -44,23 +44,30 @@ (print ((condition-property-accessor 'exn 'message) exn)) (print "Callback error in " procname) (print "Full condition info:\n" (condition->list exn))))) (proc))) +;; this was cached based on results from profiling but it turned out the profiling +;; somehow went wrong - perhaps too many processes writing to it. Leaving the caching +;; in for now but can probably take it out later. +;; (define (debug:calc-verbosity vstr) - (cond - ((number? vstr) vstr) - ((not (string? vstr)) 1) - ;; ((string-match "^\\s*$" vstr) 1) - (vstr (let ((debugvals (filter number? (map string->number (string-split vstr ","))))) - (cond - ((> (length debugvals) 1) debugvals) - ((> (length debugvals) 0)(car debugvals)) - (else 1)))) - ((args:get-arg "-v") 2) - ((args:get-arg "-q") 0) - (else 1))) + (or (hash-table-ref/default *verbosity-cache* vstr #f) + (let ((res (cond + ((number? vstr) vstr) + ((not (string? vstr)) 1) + ;; ((string-match "^\\s*$" vstr) 1) + (vstr (let ((debugvals (filter number? (map string->number (string-split vstr ","))))) + (cond + ((> (length debugvals) 1) debugvals) + ((> (length debugvals) 0)(car debugvals)) + (else 1)))) + ((args:get-arg "-v") 2) + ((args:get-arg "-q") 0) + (else 1)))) + (hash-table-set! *verbosity-cache* vstr res) + res))) ;; check verbosity, #t is ok (define (debug:check-verbosity verbosity vstr) (if (not (or (number? verbosity) (list? verbosity))) Index: dashboard-tests.scm ================================================================== --- dashboard-tests.scm +++ dashboard-tests.scm @@ -628,15 +628,13 @@ " -run -preclean -testpatt " (conc testname "/" (if (equal? item-path "") "%" item-path)) " -clean-cache" ))) - (common:without-vars - (conc (dtests:get-pre-command) - cmd - (dtests:get-post-command)) - "MT_.*")))) + (thread-start! (make-thread (lambda () + (common:run-a-command cmd)) + "clean-run-execute"))))) (remove-test (lambda (x) (iup:attribute-set! command-text-box "VALUE" (conc "megatest -remove-runs -target " keystring " -runname " runname " -testpatt " (conc testname "/" (if (equal? item-path "") Index: dashboard.scm ================================================================== --- dashboard.scm +++ dashboard.scm @@ -86,10 +86,15 @@ "-use-local" "-skip-version-check" ) args:arg-hash 0)) + +(if (not (null? remargs)) + (begin + (print "Unrecognised arguments: " (string-intersperse remargs " ")) + (exit))) (if (args:get-arg "-h") (begin (print help) (exit))) @@ -256,14 +261,15 @@ ((num-tests 10) : number) ;; total number of tests to show (used in the old runs display) ;; runs tree ((path-run-ids (make-hash-table)) : hash-table) ;; path (target / runname) => id (runs-tree #f) + ((runs-tree-ht (make-hash-table)) : hash-table) ;; track which targests added to tree (merge functionality with path-run-ids?) ;; tab data ((view-changed #t) : boolean) - ((rebuild-dwg #t) : boolean) + ((rebuild-dwg #f) : boolean) ((xadj 0) : number) ;; x slider number (if using canvas) ((yadj 0) : number) ;; y slider number (if using canvas) ;; runs-summary tab state ((runs-summary-modes '((one-run . "Show One Run") (xor-two-runs . "XOR Two Runs") (xor-two-runs-hide-clean . "XOR; Hide Clean")) ) : list) ((runs-summary-mode-buttons '()) : list) @@ -1174,10 +1180,11 @@ ;; (define (dashboard:update-tree-selector tabdat #!key (action-proc #f)) (let* ((tb (dboard:tabdat-runs-tree tabdat)) (runconf-targs (common:get-runconfig-targets)) (db-target-dat (rmt:get-targets)) + (runs-tree-ht (dboard:tabdat-runs-tree-ht tabdat)) (header (vector-ref db-target-dat 0)) (db-targets (vector-ref db-target-dat 1)) (munge-target (lambda (x) ;; create a target vector from a string. Pad with na if needed. (take (append (string-split x "/") (make-list (length header) "na")) @@ -1189,11 +1196,16 @@ (map munge-target runconf-targs) ))) (for-each (lambda (target) - (tree:add-node tb "Runs" target)) ;; (append key-vals (list run-name)) + (if (not (hash-table-ref/default runs-tree-ht target #f)) + ;; (let ((existing (tree:find-node tb target))) + ;; (if (not existing) + (begin + (tree:add-node tb "Runs" target) ;; (append key-vals (list run-name)) + (hash-table-set! runs-tree-ht target #t)))) all-targets))) ;; Run controls panel ;; (define (dashboard:run-controls commondat tabdat #!key (tab-num #f)) @@ -1514,24 +1526,25 @@ (let* ((run-record (hash-table-ref/default runs-hash run-id #f)) (key-vals (map (lambda (key)(db:get-value-by-header run-record runs-header key)) (dboard:tabdat-keys tabdat))) (run-name (db:get-value-by-header run-record runs-header "runname")) (col-name (conc (string-intersperse key-vals "\n") "\n" run-name)) - (run-path (append key-vals (list run-name))) - (existing (tree:find-node tb run-path))) + (run-path (append key-vals (list run-name)))) (if (not (hash-table-ref/default (dboard:tabdat-path-run-ids tabdat) run-path #f)) - (begin - (hash-table-set! (dboard:tabdat-run-keys tabdat) run-id run-path) - ;; (iup:attribute-set! (dboard:tabdat-runs-matrix tabdat) - ;; (conc rownum ":" colnum) col-name) - ;; (hash-table-set! runid-to-col run-id (list colnum run-record)) - ;; Here we update the tests treebox and tree keys - (tree:add-node tb "Runs" run-path ;; (append key-vals (list run-name)) - userdata: (conc "run-id: " run-id)) - (hash-table-set! (dboard:tabdat-path-run-ids tabdat) run-path run-id) - ;; (set! colnum (+ colnum 1)) - )))) + ;; (let ((existing (tree:find-node tb run-path))) + ;; (if (not existing) + (begin + (hash-table-set! (dboard:tabdat-run-keys tabdat) run-id run-path) + ;; (iup:attribute-set! (dboard:tabdat-runs-matrix tabdat) + ;; (conc rownum ":" colnum) col-name) + ;; (hash-table-set! runid-to-col run-id (list colnum run-record)) + ;; Here we update the tests treebox and tree keys + (tree:add-node tb "Runs" run-path) ;; (append key-vals (list run-name)) + ;; userdata: (conc "run-id: " run-id)))) + (hash-table-set! (dboard:tabdat-path-run-ids tabdat) run-path run-id) + ;; (set! colnum (+ colnum 1)) + )))) run-ids))) (define (dashboard:tests-ht->tests-dat tests-ht) (reverse (sort @@ -2732,18 +2745,18 @@ (let* ((run-record (hash-table-ref/default runs-hash run-id #f)) (key-vals (map (lambda (key)(db:get-value-by-header run-record runs-header key)) (dboard:tabdat-keys tabdat))) (run-name (db:get-value-by-header run-record runs-header "runname")) (col-name (conc (string-intersperse key-vals "\n") "\n" run-name)) - (run-path (append key-vals (list run-name))) - (existing (tree:find-node tb run-path))) + (run-path (append key-vals (list run-name)))) + ;; (existing (tree:find-node tb run-path))) (if (not (hash-table-ref/default (dboard:tabdat-path-run-ids tabdat) run-path #f)) (begin (hash-table-set! (dboard:tabdat-run-keys tabdat) run-id run-path) ;; Here we update the tests treebox and tree keys - (tree:add-node tb "Runs" run-path ;; (append key-vals (list run-name)) - userdata: (conc "run-id: " run-id)) + (tree:add-node tb "Runs" run-path) ;; (append key-vals (list run-name)) + ;; userdata: (conc "run-id: " run-id)) (hash-table-set! (dboard:tabdat-path-run-ids tabdat) run-path run-id) ;; (set! colnum (+ colnum 1)) )))) run-ids)) ;; (print "Updating rundat") @@ -2763,11 +2776,10 @@ (last (dboard:tabdat-target tabdat)) "%")) (testpatt (or (dboard:tabdat-test-patts tabdat) "%")) (filtrstr (conc targpatt "/" runpatt "/" testpatt))) ;; (print "targpatt: " targpatt " runpatt: " runpatt " testpatt: " testpatt) - (print "RA => dboard:tabdat-last-filter-str " dboard:tabdat-last-filter-str "filtrstr" filtrstr "dboard:tabdat-view-changed" (dboard:tabdat-view-changed tabdat)) (if (or (not (equal? (dboard:tabdat-last-filter-str tabdat) filtrstr)) (dboard:tabdat-rebuild-dwg tabdat)) (let ((dwg (dboard:tabdat-drawing tabdat))) (print "resetting drawing") @@ -2777,11 +2789,11 @@ (vg:drawing-cache-set! dwg '()) (dboard:tabdat-allruns-by-id-set! tabdat (make-hash-table)) ;; (dboard:tabdat-allruns-set! tabdat '()) (dboard:tabdat-max-row-set! tabdat 0) (dboard:tabdat-last-filter-str-set! tabdat filtrstr) - ;; (dboard:tabdat-rebuild-dwg-set! tabdat #f) + (dboard:tabdat-rebuild-dwg-set! tabdat #f) )) (update-rundat tabdat runpatt ;; (hash-table-ref/default (dboard:tabdat-searchpatts tabdat) "runname" "%") (dboard:tabdat-numruns tabdat) @@ -2816,11 +2828,10 @@ (mutex-lock! mtx) (canvas-clear! cnv) (vg:draw dwg tabdat) ;; RA => (dashboard:run-times-tab-run-data-updater commondat tabdat tab-num) (mutex-unlock! mtx) - (print "RA => View changed found to be set" ) (dboard:tabdat-view-changed-set! tabdat #f))))) ;; doesn't work. ;; ;;(define (gotoescape tabdat escape) Index: db.scm ================================================================== --- db.scm +++ db.scm @@ -215,11 +215,16 @@ (if file-write ;; dir-writable (let (;; (lock (obtain-dot-lock fname 1 5 10)) (db (sqlite3:open-database fname))) (sqlite3:set-busy-handler! db (make-busy-timeout 136000)) (db:set-sync db) ;; (sqlite3:execute db "PRAGMA synchronous = 0;") - (if (not file-exists)(initproc db)) + (if (not file-exists) + (begin + (if (string-match "^/tmp/.*" fname) ;; this is a file in /tmp + (sqlite3:execute db "PRAGMA journal_mode=WAL;") + (print "Creating " fname " in NON-WAL mode.")) + (initproc db))) ;; (release-dot-lock fname) db) (begin (debug:print 2 *default-log-port* "WARNING: opening db in non-writable dir " fname) (sqlite3:open-database fname))))) ;; ) @@ -315,15 +320,25 @@ (db:multi-db-sync #f 'old2new)) ;; migrate data from megatest.db automatically dbdat))))) ;; Make the dbstruct, setup up auxillary db's and call for main db at least once ;; +;; called in http-transport and replicated in rmt.scm for *local* access. +;; (define (db:setup run-id #!key (local #f)) (let* ((dbdir (db:dbfile-path #f)) ;; (conc (configf:lookup *configdat* "setup" "linktree") "/.db")) (dbstruct (make-dbr:dbstruct path: dbdir local: local))) dbstruct)) +;; open the local db for direct access (no server) +;; +(define (db:open-local-db-handle) + (or *dbstruct-db* + (let ((dbstruct (db:setup #f local: #t))) + (set! *dbstruct-db* dbstruct) + dbstruct))) + ;; Open the classic megatest.db file in toppath ;; (define (db:open-megatest-db) (let* ((dbpath (conc *toppath* "/megatest.db")) (dbexists (file-exists? dbpath)) @@ -1389,10 +1404,15 @@ (if (and (null? incompleted) (null? oldlaunched) (null? toplevels)) #f #t))) + +;; given a launch delay (minimum time from last launch) return amount of time to wait +;; +;; (define (db:launch-delay-left dbstruct run-id launch-delay) + ;; select end_time-now from ;; (select testname,item_path,event_time+run_duration as ;; end_time,strftime('%s','now') as now from tests where state in ;; ('RUNNING','REMOTEHOSTSTART','LAUNCED')); @@ -3053,14 +3073,14 @@ (string-substitute (regexp "=") "_" (base64:base64-encode (z3:encode-buffer (with-output-to-string - (lambda ()(serialize obj))))) + (lambda ()(serialize obj))))) ;; BB: serialize - this is what causes problems between different builds of megatest communicating. serialize is sensitive to binary image of mtest. #t)) ((zmq nmsg)(with-output-to-string (lambda ()(serialize obj)))) - (else obj))) + (else obj))) ;; rpc (define (db:string->obj msg #!key (transport 'http)) (case transport ;; ((fs) msg) ((http fs) @@ -3073,11 +3093,11 @@ (lambda ()(deserialize))) (begin (debug:print-error 0 *default-log-port* "reception failed. Received " msg " but cannot translate it.") msg))) ;; crude reply for when things go awry ((zmq nmsg)(with-input-from-string msg (lambda ()(deserialize)))) - (else msg))) + (else msg))) ;; rpc (define (db:test-set-status-state dbstruct run-id test-id status state msg) (let ((dbdat (db:get-db dbstruct run-id))) (if (member state '("LAUNCHED" "REMOTEHOSTSTART")) (db:general-call dbdat 'set-test-start-time (list test-id))) Index: launch.scm ================================================================== --- launch.scm +++ launch.scm @@ -553,11 +553,11 @@ (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")) - (list "MT_TESTSUITENAME" (common:get-testsuite-name)))) + (list "MT_TESTSUITE_NAME" (common:get-testsuite-name)))) (if mt-bindir-path (setenv "PATH" (conc (getenv "PATH") ":" mt-bindir-path))) ;; (change-directory top-path) ;; Can setup as client for server mode now ;; (client:setup) @@ -711,11 +711,16 @@ (sections (if target (list "default" target) #f)) ;; for runconfigs (mtconfig (or (args:get-arg "-config") "megatest.config")) ;; allow overriding megatest.config (rundir (if (and runname target linktree)(conc linktree "/" target "/" runname) #f)) (mtcachef (and rundir (conc rundir "/" ".megatest.cfg-" megatest-version "-" megatest-fossil-hash))) (rccachef (and rundir (conc rundir "/" ".runconfigs.cfg-" megatest-version "-" megatest-fossil-hash))) - (cancreate (and rundir (file-exists? rundir)(file-write-access? rundir)))) + (cancreate (and rundir (file-exists? rundir)(file-write-access? rundir))) + (cxt (hash-table-ref/default *contexts* toppath #f))) + + ;; create our cxt for this area if it doesn't already exist + (if (not cxt)(hash-table-set! *contexts* toppath (make-cxt))) + ;; (print "runname: " runname " target: " target " mtcachef: " mtcachef " rccachef: " rccachef) (set! *toppath* toppath) ;; This is needed when we are running as a test using CMDINFO as a datasource (cond ;; data was read and cached and available in *configstatus*, toppath has already been set ((eq? *configstatus* 'fulldata) @@ -824,11 +829,13 @@ (begin (debug:print-error 0 *default-log-port* "linktree not defined in [setup] section of megatest.config") ))) (if (and *toppath* (directory-exists? *toppath*)) - (setenv "MT_RUN_AREA_HOME" *toppath*) + (begin + (setenv "MT_RUN_AREA_HOME" *toppath*) + (setenv "MT_TESTSUITE_NAME" (common:get-testsuite-name))) (begin (debug:print-error 0 *default-log-port* "failed to find the top path to your Megatest area."))) *toppath*)) (define (get-best-disk confdat testconfig) @@ -1033,10 +1040,18 @@ ;; 4. remotely run the test on allocated host ;; - could be ssh to host from hosts table (update regularly with load) ;; - could be netbatch ;; (launch-test db (cadr status) test-conf)) (define (launch-test test-id run-id run-info keyvals runname test-conf test-name test-path itemdat params) + (let loop ((delta (- (current-seconds) *last-launch*)) + (launch-delay (string->number (or (configf:lookup *configdat* "setup" "launch-delay") "5")))) + (if (> launch-delay delta) + (begin + (debug:print-info 0 *default-log-port* "Delaying launch of " test-name " for " (- launch-delay delta) " seconds") + (thread-sleep! (- launch-delay delta)) + (loop (- (current-seconds) *last-launch*) launch-delay)))) + (set! *last-launch* (current-seconds)) (change-directory *toppath*) (alist->env-vars ;; consolidate this code with the code in megatest.scm for "-execute" (list ;; (list "MT_TEST_RUN_DIR" work-area) (list "MT_RUN_AREA_HOME" *toppath*) (list "MT_TEST_NAME" test-name) Index: megatest-version.scm ================================================================== --- megatest-version.scm +++ megatest-version.scm @@ -1,7 +1,7 @@ ;; 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.6205) +(define megatest-version 1.6208) Index: megatest.scm ================================================================== --- megatest.scm +++ megatest.scm @@ -11,11 +11,11 @@ ;; (include "megatest-version.scm") ;; fake out readline usage of toplevel-command (define (toplevel-command . a) #f) -(use sqlite3 srfi-1 posix regex regex-case srfi-69 base64 readline apropos json http-client directory-utils rpc ;; (srfi 18) extras) +(use sqlite3 srfi-1 posix regex regex-case srfi-69 base64 readline apropos json http-client directory-utils rpc typed-records;; (srfi 18) extras) http-client srfi-18 extras format) ;; zmq extras) ;; Added for csv stuff - will be removed ;; (use sparse-vectors) @@ -146,11 +146,11 @@ -update-meta : update the tests metadata for all tests -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|zmq : use http or zmq for transport (default is http) + -transport http|rpc : use http or rpc 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 @@ -393,11 +393,10 @@ (if (common:low-noise-print 30) (debug:print-info 0 *default-log-port* "Exiting watchdog timer, *time-to-exit* = " *time-to-exit*))))) "Watchdog thread"))) (thread-start! *watchdog*) - (if (args:get-arg "-log") (let ((oup (open-output-file (args:get-arg "-log")))) (debug:print-info 0 *default-log-port* "Sending log output to " (args:get-arg "-log")) (set! *default-log-port* oup))) @@ -738,14 +737,15 @@ ;; Server? Start up here. ;; (let ((tl (launch:setup)) (run-id (and (args:get-arg "-run-id") - (string->number (args:get-arg "-run-id"))))) + (string->number (args:get-arg "-run-id")))) + (transport-type (string->symbol (or (args:get-arg "-transport") "http")))) (if run-id (begin - (server:launch run-id) + (server:launch run-id transport-type) (set! *didsomething* #t)) (debug:print-error 0 *default-log-port* "server requires run-id be specified with -run-id"))) ;; Not a server? This section will decide how to communicate ;; @@ -753,10 +753,11 @@ (if (null? (lset-intersection equal? (hash-table-keys args:arg-hash) '("-list-servers" "-stop-server" + "-kill-server" "-show-cmdinfo" "-list-runs" "-ping"))) (if (launch:setup) (let ((run-id (and (args:get-arg "-run-id") @@ -775,18 +776,20 @@ ;; 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")) + (args:get-arg "-stop-server") + (args:get-arg "-kill-server")) (let ((tl (launch:setup))) (if tl (let* ((tdbdat (tasks:open-db)) (servers (tasks:get-all-servers (db:delay-if-busy tdbdat))) (fmtstr "~5a~12a~8a~20a~24a~10a~10a~10a~10a\n") (servers-to-kill '()) - (killinfo (args:get-arg "-stop-server")) + (kill-switch (if (args:get-arg "-kill-server") "-9" "")) + (killinfo (or (args:get-arg "-stop-server") (args:get-arg "-kill-server") )) (khost-port (if killinfo (if (substring-index ":" killinfo)(string-split ":") #f) #f)) (sid (if killinfo (if (substring-index ":" killinfo) #f (string->number killinfo)) #f))) (format #t fmtstr "Id" "MTver" "Pid" "Host" "Interface:OutPort" "InPort" "LastBeat" "State" "Transport") (format #t fmtstr "==" "=====" "===" "====" "=================" "======" "========" "=====" "=========") (for-each @@ -816,12 +819,12 @@ (format #t fmtstr id mt-ver pid hostname (conc interface ":" pullport) pubport last-update (if status "alive" "dead") transport) (if (or (equal? id sid) (equal? sid 0)) ;; kill all/any (begin - (debug:print-info 0 *default-log-port* "Attempting to stop server with pid " pid) - (tasks:kill-server status hostname pullport pid transport))))) + (debug:print-info 0 *default-log-port* "Attempting to kill "kill-switch" server with pid " pid) + (tasks:kill-server hostname pid kill-switch: kill-switch))))) servers) (debug:print-info 1 *default-log-port* "Done with listservers") (set! *didsomething* #t) (exit)) ;; must do, would have to add checks to many/all calls below (exit)))) @@ -997,11 +1000,11 @@ "-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 #f)) + #f #f #f #f)) (header (vector-ref runsdat 0)) (rows (vector-ref runsdat 1))) (if (null? rows) (begin (debug:print-info 0 *default-log-port* "No matching run found.") ADDED remotediff-nmsg.scm Index: remotediff-nmsg.scm ================================================================== --- /dev/null +++ remotediff-nmsg.scm @@ -0,0 +1,182 @@ +(use posix) +(use regex) +(use directory-utils) +(use srfi-18 srfi-69 nanomsg) + +(define (client-send-receive soc msg) + (nn-send soc msg) + (nn-recv soc)) + +;;do as calling user +(define (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)) + (proc) + (if (not (eq? eid cid)) + (set! (current-effective-user-id) eid)))) + +;; use mutex to not open/close files at same time +;; +(define (checksum mtx file #!key (cmd "shasum")) + (mutex-lock! mtx) + (let-values (((inp oup pid) + (process cmd (list file)))) + (mutex-unlock! mtx) + (let ((result (read-line inp))) + ;; now flush out remaining output + (let loop ((inl (read-line inp))) + (if (eof-object? inl) + (if (string? result) + (begin + (mutex-lock! mtx) + (close-input-port inp) + (close-output-port oup) + (mutex-unlock! mtx) + (car (string-split result))) + #f) + (loop (read-line inp))))))) + +(define *max-running* 40) + +(define (gather-dir-info path) + (let ((mtx1 (make-mutex)) + (threads (make-hash-table)) + (last-num 0) + (req (nn-socket 'req))) + (print "starting client with pid " (current-process-id)) + (nn-connect req + ;; "tcp://localhost:5559") + "ipc:///tmp/test-ipc") + (find-files + path + ;; test: #t + action: (lambda (p res) + (let ((info (cond + ((not (file-read-access? p)) '(cant-read)) + ((directory? p) '(dir)) + ((symbolic-link? p) (list 'symlink (read-symbolic-link p))) + (else '(data))))) + (if (eq? (car info) 'data) + (let loop ((start-time (current-seconds))) + (mutex-lock! mtx1) + (let* ((num-threads (hash-table-size threads)) + (ok-to-run (> *max-running* num-threads))) + ;; (if (> (abs (- num-threads last-num)) 2) + ;; (begin + ;; ;; (print "num-threads:" num-threads) + ;; (set! last-num num-threads))) + (mutex-unlock! mtx1) + (if ok-to-run + (let ((run-time-start (current-seconds))) + ;; (print "num threads: " num-threads) + (let ((th1 (make-thread + (lambda () + (let ((cksum (checksum mtx1 p cmd: "md5sum")) + (run-time (- (current-seconds) run-time-start))) + (mutex-lock! mtx1) + (client-send-receive req (conc p " " cksum)) + (mutex-unlock! mtx1)) + (let loop2 () + (mutex-lock! mtx1) + (let ((registered (hash-table-exists? threads p))) + (if registered + (begin + ;; (print "deleting thread reference for " p) + (hash-table-delete! threads p))) ;; delete myself + (mutex-unlock! mtx1) + (if (not registered) + (begin + (thread-sleep! 0.5) + (loop2)))))) + p))) + (thread-start! th1) + ;; (thread-sleep! 0.05) ;; give things a little time to get going + ;; (thread-join! th1) ;; + (mutex-lock! mtx1) + (hash-table-set! threads p th1) + (mutex-unlock! mtx1) + )) ;; thread is launched + (let ((run-time (- (current-seconds) start-time))) ;; couldn't launch yet + (cond + ((< run-time 5)) ;; blast on through + ((< run-time 30)(thread-sleep! 0.1)) + ((< run-time 60)(thread-sleep! 2)) + ((< run-time 120)(thread-sleep! 3)) + (else (thread-sleep! 3))) + (loop start-time))))))))) + (map thread-join! (hash-table-values threads)) + (client-send-receive req "quit") + (nn-close req) + (exit))) + +;; recieve and store the file data, note: this is effectively a *server*, not a client. +;; +(define (compare-directories path1 path2) + (let ((p1dat (make-hash-table)) + (p2dat (make-hash-table)) + (numdone 0) ;; increment when recieved a quit. exit when > 2 + (rep (nn-socket 'rep)) + (p1len (string-length path1)) + (p2len (string-length path2)) + (both-seen (make-hash-table))) + (nn-bind rep + ;; "tcp://*:5559") + "ipc:///tmp/test-ipc") + ;; start clients + (thread-sleep! 0.1) + (system (conc "./remotediff-nmsg " path1 " &")) + (system (conc "./remotediff-nmsg " path2 " &")) + (let loop ((msg-in (nn-recv rep)) + (last-print 0)) + (if (equal? msg-in "quit") + (set! numdone (+ numdone 1))) + (if (and (not (equal? msg-in "quit")) + (< numdone 2)) + (let* ((parts (string-split msg-in)) + (filen (car parts)) + (finfo (cadr parts)) + (isp1 (substring-index path1 filen 0)) ;; is this a path1? + (isp2 (substring-index path2 filen 0)) ;; is this a path2? + (tpth (substring filen (if isp1 p1len p2len) (string-length filen)))) + (hash-table-set! (if isp1 p1dat p2dat) + tpth + finfo) + (if (and (hash-table-exists? p1dat tpth) + (hash-table-exists? p2dat tpth)) + (begin + (if (not (equal? (hash-table-ref p1dat tpth) + (hash-table-ref p2dat tpth))) + (print "DIFF: " tpth)) + (hash-table-set! both-seen tpth finfo))) + (nn-send rep "done") + (loop (nn-recv rep) + (if (> (- (current-seconds) last-print) 15) + (begin + (print "Processed " (hash-table-size p1dat) ", " (hash-table-size p2dat)) + (current-seconds)) + last-print))))) + (print "p1: " (hash-table-size p1dat) " p2: " (hash-table-size p2dat)) + (hash-table-for-each + p1dat + (lambda (k v) + (if (not (hash-table-exists? p2dat k)) + (print "REMOVED: " k)))) + (hash-table-for-each + p2dat + (lambda (k v) + (if (not (hash-table-exists? p1dat k)) + (print "ADDED: " k)))) + (list p1dat p2dat))) + +(if (< (length (argv)) 2) + (begin + (print "Usage: remotediff-nmsg file1 file2") + (exit))) + +(if (eq? (length (argv)) 2) ;; given a single path + (gather-dir-info (cadr (argv))) + (compare-directories (cadr (argv))(caddr (argv)))) + +(print "Done") Index: rmt.scm ================================================================== --- rmt.scm +++ rmt.scm @@ -225,18 +225,13 @@ (cons newmax-cmd currmax) (cons 'none 0)) (loop (car tal)(cdr tal) newmax-cmd currmax))))))) (mutex-unlock! *db-stats-mutex*) res)) - + (define (rmt:open-qry-close-locally cmd run-id params #!key (remretries 5)) - (let* ((dbstruct-local (if *dbstruct-db* - *dbstruct-db* - (let* ((dbdir (db:dbfile-path #f)) ;; (conc (configf:lookup *configdat* "setup" "linktree") "/.db")) - (db (make-dbr:dbstruct path: dbdir local: #t))) - (set! *dbstruct-db* db) - db))) + (let* ((dbstruct-local (db:open-local-db-handle)) (db-file-path (db:dbfile-path 0)) ;; (read-only (not (file-read-access? db-file-path))) (start (current-milliseconds)) (resdat (api:execute-requests dbstruct-local (vector (symbol->string cmd) params))) (success (vector-ref resdat 0)) @@ -347,14 +342,23 @@ ;; (define (rmt:get-key-val-pairs run-id) (rmt:send-receive 'get-key-val-pairs run-id (list run-id))) (define (rmt:get-keys) - (rmt:send-receive 'get-keys #f '())) + (if *db-keys* *db-keys* + (let ((res (rmt:send-receive 'get-keys #f '()))) + (set! *db-keys* res) + res))) +;; we don't reuse run-id's (except possibly *after* a db cleanup) so it is safe +;; to cache the resuls in a hash +;; (define (rmt:get-key-vals run-id) - (rmt:send-receive 'get-key-vals #f (list run-id))) + (or (hash-table-ref/default *keyvals* run-id #f) + (let ((res (rmt:send-receive 'get-key-vals #f (list run-id)))) + (hash-table-set! *keyvals* run-id res) + res))) (define (rmt:get-targets) (rmt:send-receive 'get-targets #f '())) (define (rmt:get-target run-id) Index: rpc-transport.scm ================================================================== --- rpc-transport.scm +++ rpc-transport.scm @@ -38,32 +38,34 @@ ;; all routes though here end in exit ... ;; ;; start_server? ;; (define (rpc-transport:launch run-id) - (set! *run-id* run-id) - (if (args:get-arg "-daemonize") - (daemon:ize)) - (if (server:check-if-running run-id) - (begin - (debug:print 0 *default-log-port* "INFO: Server for run-id " run-id " already running") - (exit 0))) - (let loop ((server-id (open-run-close tasks:server-lock-slot tasks:open-db run-id)) - (remtries 4)) - (if (not server-id) - (if (> remtries 0) - (begin - (thread-sleep! 2) - (loop (open-run-close tasks:server-lock-slot tasks:open-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 *default-log-port* "INFO: server pid=" (current-process-id) ", hostname=" (get-host-name) " not starting due to other candidates ahead in start queue") - (open-run-close tasks:server-delete-records-for-this-pid tasks:open-db " rpc-transport:launch"))) - (begin - (rpc-transport:run (if (args:get-arg "-server")(args:get-arg "-server") "-") run-id server-id) - (exit))))) + (let* ((tdbdat (tasks:open-db))) + (BB> "rpc-transport:launch fired for run-id="run-id) + (set! *run-id* run-id) + (if (args:get-arg "-daemonize") + (daemon:ize)) + (if (server:check-if-running run-id) + (begin + (debug:print 0 *default-log-port* "INFO: Server for run-id " run-id " already running") + (exit 0))) + (let loop ((server-id (tasks:server-lock-slot (db:delay-if-busy tdbdat) run-id)) + (remtries 4)) + (if (not server-id) + (if (> remtries 0) + (begin + (thread-sleep! 2) + (loop (tasks:server-lock-slot (db:delay-if-busy tdbdat) run-id) + (- remtries 1))) + (begin + ;; since we didn't get the server lock we are going to clean up and bail out + (debug:print-info 2 *default-log-port* "INFO: server pid=" (current-process-id) ", hostname=" (get-host-name) " not starting due to other candidates ahead in start queue") + (tasks:server-delete-records-for-this-pid (db:delay-if-busy tdbdat) " rpc-transport:launch"))) + (begin + (rpc-transport:run (if (args:get-arg "-server")(args:get-arg "-server") "-") run-id server-id) + (exit)))))) (define (rpc-transport:run hostn run-id server-id) (debug:print 2 *default-log-port* "Attempting to start the rpc server ...") ;; (trace rpc:publish-procedure!) Index: runs.scm ================================================================== --- runs.scm +++ runs.scm @@ -1324,11 +1324,11 @@ ;; 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) (thread-sleep! 5) ;; I think there is a race condition here. Let states/statuses settle (let wait-loop ((num-running (rmt:get-count-tests-running-for-run-id run-id)) (prev-num-running 0)) - ;; (debug:print 0 *default-log-port* "num-running=" num-running ", prev-num-running=" prev-num-running) + ;; (BB> "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 Index: server.scm ================================================================== --- server.scm +++ server.scm @@ -47,16 +47,17 @@ ;; all routes though here end in exit ... ;; ;; start_server ;; -(define (server:launch run-id) - (case *transport-type* +(define (server:launch run-id transport-type) + (BB> "server:launch fired for run-id="run-id" transport-type="transport-type) + (case transport-type ((http)(http-transport:launch run-id)) ;;((nmsg)(nmsg-transport:launch run-id)) ((rpc) (rpc-transport:launch run-id)) - (else (debug:print-error 0 *default-log-port* "unknown server type " *transport-type*)))) + (else (debug:print-error 0 *default-log-port* "unknown server type " transport-type)))) ;; (else (debug:print-error 0 *default-log-port* "No known transport set, transport=" transport ", using rpc") ;; (rpc-transport:launch run-id))))) ;;====================================================================== ;; S E R V E R U T I L I T I E S @@ -101,10 +102,11 @@ result))) ;; Given a run id start a server process ### NOTE ### > file 2>&1 ;; if the run-id is zero and the target-host is set ;; try running on that host +;; incidental: rotate logs in logs/ dir. ;; (define (server:run run-id) (let* ((curr-host (get-host-name)) (curr-ip (server:get-best-guess-address curr-host)) (target-host (configf:lookup *configdat* "server" "homehost" )) @@ -116,12 +118,15 @@ "") " -m testsuite:" testsuite))) ;; (conc " >> " logfile " 2>&1 &"))))) (debug:print 0 *default-log-port* "INFO: Starting server (" cmdln ") as none running ...") (push-directory *toppath*) (if (not (directory-exists? "logs"))(create-directory "logs")) + ;; Rotate logs, logic: - ;; if > 500k and older than 1 week, remove previous compressed log and compress this log + ;; if > 500k and older than 1 week: + ;; remove previous compressed log and compress this log + ;; (directory-fold (lambda (file rem) (if (and (string-match "^.*.log" file) (> (file-size (conc "logs/" file)) 200000)) (let ((gzfile (conc "logs/" file ".gz"))) @@ -141,19 +146,20 @@ (not (string-match (conc "("curr-host "|" curr-host"\\..*)") target-host)) (not (equal? curr-ip target-host))) (begin (debug:print-info 0 *default-log-port* "Starting server on " target-host ", logfile is " logfile) (setenv "TARGETHOST" target-host))) + (setenv "TARGETHOST_LOGF" logfile) (common:wait-for-normalized-load 4 " delaying server start due to load" remote-host: (get-environment-variable "TARGETHOST")) ;; do not try starting servers on an already overloaded machine, just wait forever (system (conc "nbfake " cmdln)) (unsetenv "TARGETHOST_LOGF") (if (get-environment-variable "TARGETHOST")(unsetenv "TARGETHOST")) ;; (system cmdln) (pop-directory))) -(define (server:get-client-signature) +(define (server:get-client-signature) ;; BB> why is this proc named "get-"? it returns nothing -- set! has not return value. (if *my-client-signature* *my-client-signature* (let ((sig (server:mk-signature))) (set! *my-client-signature* sig) *my-client-signature*))) Index: tasks.scm ================================================================== --- tasks.scm +++ tasks.scm @@ -229,10 +229,18 @@ (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)) + +;; BB> adding missing func for --list-servers +(define (tasks:server-deregister mdb hostname #!key (pullport #f) (pid #f) (action #f)) ;;pullport pid: pid action: 'delete)) + (if (eq? action 'delete) + (sqlite3:execute mdb "DELETE FROM servers WHERE pid=? AND port=? AND hostname=?;" pid pullport hostname) + (sqlite3:execute mdb "UPDATE servers SET state='defunct', heartbeat=strftime('%s','now') WHERE hostname=? AND pid=?;" + hostname pid))) + (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) @@ -423,15 +431,15 @@ run-id) (reverse res))) ;; no elegance here ... ;; -(define (tasks:kill-server hostname pid) +(define (tasks:kill-server hostname pid #!key (kill-switch "")) (debug:print-info 0 *default-log-port* "Attempting to kill server process " pid " on host " hostname) (setenv "TARGETHOST" hostname) (setenv "TARGETHOST_LOGF" "server-kills.log") - (system (conc "nbfake kill " pid)) + (system (conc "nbfake kill "kill-switch" "pid)) (unsetenv "TARGETHOST_LOGF") (unsetenv "TARGETHOST")) ;; look up a server by run-id and send it a kill, also delete the record for that server ;; Index: tests/Makefile ================================================================== --- tests/Makefile +++ tests/Makefile @@ -48,34 +48,34 @@ cd simplerun ; $(MEGATEST) -server - -debug $(DEBUG) test1 : cleanprep test2 : fullprep - 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) + 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) -preclean -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) -preclean -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) -run-wait -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 -run -testpatt % -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) + cd fullrun;time $(MEGATEST) -debug $(DEBUG) -preclean -run -testpatt 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 rm -f fullrun/a*.log fullrun/logs/* @echo "WARNING: No longer running fullprep, test converage may be lessened" Index: tests/fullrun/megatest.config ================================================================== --- tests/fullrun/megatest.config +++ tests/fullrun/megatest.config @@ -32,11 +32,13 @@ # and set the dbdir to /var/tmp/$USER/mt_db to enable keeping # the raw db in /var/tmp/$USER # faststart no monitordir #{getenv MT_RUN_AREA_HOME}/db -dbdir #{getenv MT_RUN_AREA_HOME}/db +dbdirdefn /tmp/#{getenv USER}/#{getenv MT_TESTSUITE_NAME}/db +dbdirmkdir #{scheme (create-directory "#{get setup dbdirdefn}" #t)} +dbdir #{get setup dbdirdefn} # sync more aggressively to megatest-db megatest-db yes # Set launchwait to no to use the more agressive code that does not wait for the launch to complete before proceeding Index: utils/viewscreen ================================================================== --- utils/viewscreen +++ utils/viewscreen @@ -14,6 +14,6 @@ screen -X hardstatus alwayslastline screen -X hardstatus string '%{= kG}[ %{G}%H %{g}][%= %{= kw}%?%-Lw%?%{r}(%{W}%n*%f%t%?(%u)%?%{r})%{w}%?%+Lw%?%?%= %{g}][%{B} %m-%d %{W} %c %{g}]' fi cmd="cd $PWD;$*" -screen -X screen bash -c "$cmd;echo \"Press any key to continue, ctrl-f to see other windows\";bash -c 'read -n 1 -s'" +screen -X screen bash -c "$cmd;echo \"Press any key to continue, ctrl-f to see other windows\";bash -c 'read -n 1 -s'" &