Index: Makefile ================================================================== --- Makefile +++ Makefile @@ -15,24 +15,58 @@ # You should have received a copy of the GNU General Public License # along with Megatest. If not, see . # make install CSCOPTS='-accumulate-profile -profile-name $(PWD)/profile-ww$(shell date +%V.%u)' # rm .o ; make install CSCOPTS='-profile' ; ... ; chicken-profile | less + +all : $(PREFIX)/bin/.$(ARCHSTR) mtest dboard mtut + +recent-commits.csv : .fslckout + fossil timeline -n 350 -t ci -F "%h,%a,%b,%t,\"%c\"" > recent-commits.csv + + SHELL=/bin/bash PREFIX=$(PWD) +# CSCOPTS=-lfa2 -specialize -inline-global CSCOPTS= INSTALL=install SRCFILES = common.scm items.scm launch.scm ods.scm runconfig.scm \ - server.scm configf.scm db.scm keys.scm margs.scm \ + server.scm configf.scm db.scm keys.scm \ process.scm runs.scm tasks.scm tests.scm genexample.scm \ - http-transport.scm filedb.scm tdb.scm client.scm mt.scm \ - ezsteps.scm lock-queue.scm sdb.scm rmt.scm api.scm \ - subrun.scm portlogger.scm archive.scm env.scm \ + tdb.scm mt.scm \ + ezsteps.scm rmt.scm api.scm \ + subrun.scm archive.scm env.scm \ diff-report.scm cgisetup/models/pgdb.scm # module source files -MSRCFILES = adjutant.scm mutils.scm mttop.scm +MSRCFILES = dbfile.scm debugprint.scm mtargs.scm commonmod.scm dbmod.scm adjutant.scm mutils.scm mttop.scm tcp-transportmod.scm rmtmod.scm portlogger.scm + +transport-mode.scm : transport-mode.scm.template + cp transport-mode.scm.template transport-mode.scm + +dashboard-transport-mode.scm : dashboard-transport-mode.scm.template + cp dashboard-transport-mode.scm.template dashboard-transport-mode.scm + +mtest : transport-mode.scm +dboard : dashboard-transport-mode.scm + +# dbmod.import.o is just a hack here +mofiles/portlogger.o : mofiles/dbmod.o + +mofiles/dbfile.o : \ + mofiles/debugprint.o mofiles/commonmod.o + +mofiles/dbmod.o : mofiles/dbfile.o + +mofiles/commonmod.o : mofiles/debugprint.o +configf.o : commonmod.import.o +mofiles/dbfile.o : mofiles/debugprint.o +mofiles/rmtmod.o mofiles/dbmod.o : mofiles/dbfile.o mofiles/commonmod.o mofiles/debugprint.o +db.o : mofiles/dbmod.o mofiles/dbfile.o +mofiles/debugprint.o : mofiles/mtargs.o +mofiles/tcp-transportmod.o : mofiles/portlogger.o + # ftail.scm rmtmod.scm commonmod.scm removed # MSRCFILES = ducttape-lib.scm pkts.scm stml2.scm cookie.scm mutils.scm \ # mtargs.scm commonmod.scm dbmod.scm adjutant.scm ulex.scm \ # rmtmod.scm apimod.scm @@ -55,18 +89,19 @@ # @[ -e mofiles ] || mkdir -p mofiles # csc $(CSCOPTS) -I mofiles -I $* -J -c $< -o $*.o # cp $*.o mofiles/$*.o # @touch $*.import.scm # ensure it is touched after the .o is made -mofiles/%.o : %.scm - mkdir -p mofiles +%.import.scm mofiles/%.o : %.scm + @mkdir -p mofiles csc $(CSCOPTS) -J -c $< -o mofiles/$*.o + @if [[ -e $*.import.scm ]];then touch $*.import.scm;fi # ensure it is touched after the .o is made 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}') +MTESTHASH=$(shell if [[ -e .fslckout ]];then fossil info|grep checkout:| awk '{print $$2}';else echo "na";fi) ifeq ($(MTESTHASH),) $(error MTESTHASH is broken!) endif @@ -78,62 +113,55 @@ ARCHSTR=$(shell if [[ -e /usr/bin/sw_vers ]]; then /usr/bin/sw_vers -productVersion; else lsb_release -sr; fi) # ARCHSTR=$(shell bash -c "echo \$$MACHTYPE") PNGFILES = $(shell cd docs/manual;ls *png) -# all : $(PREFIX)/bin/.$(ARCHSTR) mtest dboard mtut ndboard -all : $(PREFIX)/bin/.$(ARCHSTR) mtest dboard mtut tcmt -mtest: $(OFILES) readline-fix.scm megatest.o $(MOFILES) $(MOIMPFILES) megatest-version.scm +mtest: $(OFILES) readline-fix.scm $(MOFILES) $(MOIMPFILES) megatest.o megatest-version.scm csc $(CSCOPTS) $(OFILES) $(MOFILES) $(MOIMPFILES) megatest.o -o mtest showmtesthash: @echo $(MTESTHASH) dboard : $(OFILES) $(GOFILES) dashboard.scm $(MOFILES) $(MOIMPFILES) megatest-version.scm megatest-fossil-hash.scm csc $(CSCOPTS) $(OFILES) dashboard.scm $(GOFILES) $(MOFILES) $(MOIMPFILES) -o dboard -mtut: $(OFILES) $(MOFILES) megatest-fossil-hash.scm mtut.scm megatest-version.scm - csc $(CSCOPTS) $(OFILES) $(MOFILES) mtut.scm -o mtut - -include makefile.inc -include chicken.makefile - -TCMTOBJS = \ - api.o \ - archive.o \ - cgisetup/models/pgdb.o \ - client.o \ - common.o \ - configf.o \ - db.o \ - env.o \ - http-transport.o \ - items.o \ - keys.o \ - launch.o \ - lock-queue.o \ - margs.o \ - mt.o \ - ods.o \ - portlogger.o \ - process.o \ - rmt.o \ - runconfig.o \ - runs.o \ - server.o \ - tasks.o \ - tdb.o \ - tests.o \ - subrun.o \ - ezsteps.o - -# mofiles/rmtmod.o \ -# mofiles/commonmod.o \ - -tcmt : $(TCMTOBJS) tcmt.scm megatest-version.scm - csc $(CSCOPTS) $(TCMTOBJS) $(MOFILES) $(MOIMPFILES) tcmt.scm -o tcmt +mtut: $(OFILES) $(MOFILES) $(MOIMPFILES) megatest-fossil-hash.scm mtut.scm megatest-version.scm + csc $(CSCOPTS) $(OFILES) $(MOFILES) $(MOIMPFILES) mtut.scm -o mtut + +# include makefile.inc + +# TCMTOBJS = \ +# api.o \ +# archive.o \ +# cgisetup/models/pgdb.o \ +# common.o \ +# configf.o \ +# db.o \ +# env.o \ +# items.o \ +# keys.o \ +# launch.o \ +# margs.o \ +# mt.o \ +# ods.o \ +# process.o \ +# rmt.o \ +# runconfig.o \ +# runs.o \ +# server.o \ +# tasks.o \ +# tdb.o \ +# tests.o \ +# subrun.o \ +# ezsteps.o +# +# # mofiles/rmtmod.o \ +# # mofiles/commonmod.o \ +# +# tcmt : $(TCMTOBJS) tcmt.scm megatest-version.scm $(MOFILES) $(MOIMPFILES) +# csc $(CSCOPTS) $(TCMTOBJS) $(MOFILES) $(MOIMPFILES) tcmt.scm -o tcmt # install documentation to $(PREFIX)/docs # DOES NOT REBUILD DOCS # $(PREFIX)/share/docs/megatest_manual.html : docs/manual/megatest_manual.html @@ -142,20 +170,23 @@ for png in $(PNGFILES);do $(INSTALL) docs/manual/$$png $(PREFIX)/share/docs/$$png;done # add a fake dependency so this doens't copy everytime $(PREFIX)/share/js/jquery-3.1.0.slim.min.js : # .fslckout mkdir -p $(PREFIX)/share/js - fossil wiki export java-script-lib > $(PREFIX)/share/js/jquery-3.1.0.slim.min.js + cp utils/java-script-lib $(PREFIX)/share/js/jquery-3.1.0.slim.min.js $(PREFIX)/share/db/mt-pg.sql : mt-pg.sql mkdir -p $(PREFIX)/share/db $(INSTALL) mt-pg.sql $(PREFIX)/share/db/mt-pg.sql # Special dependencies for the includes $(MOFILE) $(MOIMPFILES) : megatest-fossil-hash.scm -# common.o : mofiles/commonmod.o megatest-fossil-hash.scm +mofiles/commonmod.o : mofiles/debugprint.o megatest-fossil-hash.scm +common.o : mofiles/commonmod.o + +# mofiles/dbmod.o : mofiles/configfmod.o # commonmod.o dashboard.o megatest.o tcmt.o apimod.o : megatest-fossil-hash.scm tests.o db.o launch.o runs.o dashboard-tests.o \ dashboard-context-menu.o dashboard-guimonitor.o dashboard-main.o \ @@ -162,20 +193,27 @@ monitor.o dashboard.o archive.o megatest.o : db_records.scm megatest-fossil-hash.scm tests.o runs.o dashboard.o dashboard-tests.o dashboard-context-menu.o dashboard-main.o : run_records.scm db.o ezsteps.o keys.o launch.o megatest.o monitor.o runs-for-ref.o runs.o tests.o : key_records.scm +db.o api.o : mofiles/dbmod.o mofiles/dbfile.o mofiles/debugprint.o mofiles/commonmod.o dbmod.import.o tests.o tasks.o dashboard-tasks.o : task_records.scm runs.o : test_records.scm -megatest.o : megatest-fossil-hash.scm megatest-version.scm +# mofiles-made : $(MOFILES) +# make $(MOIMPFILES) +# touch mofiles-made -rmt.scm client.scm common.scm configf.scm dashboard-guimonitor.scm dashboard-tests.scm dashboard.scm db.scm dcommon.scm ezsteps.scm fs-transport.scm http-transport.scm index-tree.scm items.scm keys.scm launch.scm megatest.scm monitor.scm mt.scm newdashboard.scm runconfig.scm runs.scm server.scm tdb.scm tests.scm tree.scm : common_records.scm megatest-version.scm +megatest.o : megatest-fossil-hash.scm megatest-version.scm $(MOFILES) $(MOIMPFILES) + +rmt.scm common.scm configf.scm dashboard-guimonitor.scm dashboard-tests.scm dashboard.scm db.scm dcommon.scm ezsteps.scm index-tree.scm items.scm keys.scm launch.scm megatest.scm monitor.scm mt.scm newdashboard.scm runconfig.scm runs.scm server.scm tdb.scm tests.scm tree.scm : common_records.scm megatest-version.scm common_records.scm : altdb.scm + +mofiles/dbfile.o : mofiles/commonmod.o # mofiles/stml2.o : mofiles/cookie.o # configf.o : mofiles/commonmod.o vg.o dashboard.o : vg_records.scm megatest-version.scm @@ -246,16 +284,16 @@ utils/mk_wrapper $(PREFIX) mtexec $(PREFIX)/bin/mtexec chmod a+x $(PREFIX)/bin/mtexec # tcmt -$(PREFIX)/bin/.$(ARCHSTR)/tcmt : tcmt - $(INSTALL) tcmt $(PREFIX)/bin/.$(ARCHSTR)/tcmt - -$(PREFIX)/bin/tcmt : $(PREFIX)/bin/.$(ARCHSTR)/tcmt utils/mk_wrapper - utils/mk_wrapper $(PREFIX) tcmt $(PREFIX)/bin/tcmt - chmod a+x $(PREFIX)/bin/tcmt +# $(PREFIX)/bin/.$(ARCHSTR)/tcmt : tcmt +# $(INSTALL) tcmt $(PREFIX)/bin/.$(ARCHSTR)/tcmt +# +# $(PREFIX)/bin/tcmt : $(PREFIX)/bin/.$(ARCHSTR)/tcmt utils/mk_wrapper +# utils/mk_wrapper $(PREFIX) tcmt $(PREFIX)/bin/tcmt +# chmod a+x $(PREFIX)/bin/tcmt $(PREFIX)/bin/mt_laststep : utils/mt_laststep $(INSTALL) $< $@ chmod a+x $@ @@ -292,10 +330,22 @@ chmod a+x $@ $(PREFIX)/bin/mtrunner : utils/mtrunner $(INSTALL) $< $@ chmod a+x $@ + +$(PREFIX)/bin/mt-old-to-new.sh : utils/mt-old-to-new.sh + $(INSTALL) $< $@ + chmod a+x $@ + +$(PREFIX)/bin/mt-new-to-old.sh : utils/mt-new-to-old.sh + $(INSTALL) $< $@ + chmod a+x $@ + +$(PREFIX)/bin/convert-db.sh : utils/convert-db.sh + $(INSTALL) $< $@ + chmod a+x $@ deploytarg/nbfake : utils/nbfake $(INSTALL) $< $@ chmod a+x $@ @@ -316,39 +366,43 @@ $(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 -# Work around missing libraries on crappy corporate compute farm (hearafter known as CCCF) -ifeq ($(ARCHSTR),12.5) -EXTRALIBS_HACK=$(PREFIX)/bin/.$(ARCHSTR)/lib/libpangox-1.0.so $(PREFIX)/bin/.$(ARCHSTR)/lib/libpangox-1.0.so.0 $(PREFIX)/bin/.$(ARCHSTR)/lib/libxcb-xlib.so.0 -else -EXTRALIBS_HACK= -endif - $(PREFIX)/bin/.$(ARCHSTR)/lib/libpangox-1.0.so : lib/libpangox-1.0.so - mkdir -p $(PREFIX)/bin/.$(ARCHSTR)/lib - $(INSTALL) lib/libpangox-1.0.so $(PREFIX)/bin/.$(ARCHSTR)/lib/libpangox-1.0.so + if [[ $(ARCHSTR) == 12.5 ]]; then \ + mkdir -p $(PREFIX)/bin/.$(ARCHSTR)/lib; \ + $(INSTALL) lib/libpangox-1.0.so $(PREFIX)/bin/.$(ARCHSTR)/lib/libpangox-1.0.so; \ + fi $(PREFIX)/bin/.$(ARCHSTR)/lib/libpangox-1.0.so.0 : lib/libpangox-1.0.so.0 - mkdir -p $(PREFIX)/bin/.$(ARCHSTR)/lib - $(INSTALL) lib/libpangox-1.0.so.0 $(PREFIX)/bin/.$(ARCHSTR)/lib/libpangox-1.0.so.0 + if [[ $(ARCHSTR) == 12.5 ]]; then \ + mkdir -p $(PREFIX)/bin/.$(ARCHSTR)/lib; \ + $(INSTALL) lib/libpangox-1.0.so.0 $(PREFIX)/bin/.$(ARCHSTR)/lib/libpangox-1.0.so.0; \ + fi $(PREFIX)/bin/.$(ARCHSTR)/lib/libxcb-xlib.so.0 : lib/libxcb-xlib.so.0 - mkdir -p $(PREFIX)/bin/.$(ARCHSTR)/lib - $(INSTALL) lib/libxcb-xlib.so.0 $(PREFIX)/bin/.$(ARCHSTR)/lib/libxcb-xlib.so.0 + if [[ $(ARCHSTR) == 12.5 ]]; then \ + mkdir -p $(PREFIX)/bin/.$(ARCHSTR)/lib; \ + $(INSTALL) lib/libxcb-xlib.so.0 $(PREFIX)/bin/.$(ARCHSTR)/lib/libxcb-xlib.so.0; \ + fi install : $(PREFIX)/bin/.$(ARCHSTR) $(PREFIX)/bin/.$(ARCHSTR)/mtest $(PREFIX)/bin/megatest \ $(PREFIX)/bin/.$(ARCHSTR)/dboard $(PREFIX)/bin/dashboard $(HELPERS) $(PREFIX)/bin/nbfake \ - $(PREFIX)/bin/.$(ARCHSTR)/mtexec $(PREFIX)/bin/mtexec $(PREFIX)/bin/serialize-env \ $(PREFIX)/bin/nbfind $(PREFIX)/bin/mtrunner $(PREFIX)/bin/viewscreen $(PREFIX)/bin/mt_xterm \ + $(PREFIX)/bin/mt-old-to-new.sh $(PREFIX)/bin/mt-new-to-old.sh \ + $(PREFIX)/bin/convert-db.sh $(PREFIX)/bin/convert-db.sh \ $(PREFIX)/share/docs/megatest_manual.html $(PREFIX)/bin/remrun \ $(PREFIX)/share/docs/megatest_manual.html $(PREFIX)/bin/remrun $(PREFIX)/bin/mtutil \ - $(PREFIX)/bin/tcmt $(PREFIX)/share/db/mt-pg.sql \ + $(PREFIX)/share/db/mt-pg.sql \ $(PREFIX)/share/js/jquery-3.1.0.slim.min.js \ - $(EXTRALIBS_HACK) + $(PREFIX)/bin/.$(ARCHSTR)/lib/libpangox-1.0.so \ + $(PREFIX)/bin/.$(ARCHSTR)/lib/libpangox-1.0.so.0 \ + $(PREFIX)/bin/.$(ARCHSTR)/lib/libxcb-xlib.so.0 $(PREFIX)/bin/serialize-env +# $(PREFIX)/bin/.$(ARCHSTR)/ndboard $(PREFIX)/bin/tcmt +# $(PREFIX)/bin/.$(ARCHSTR)/mtexec $(PREFIX)/bin/mtexec $(PREFIX)/bin/serialize-env \ # $(PREFIX)/bin/newdashboard $(PREFIX)/bin/.$(ARCHSTR) : mkdir -p $(PREFIX)/bin/.$(ARCHSTR) mkdir -p $(PREFIX)/bin/.$(ARCHSTR)/lib @@ -445,35 +499,42 @@ 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 \ + if csi -ne '(use mysql-client)' &> /dev/null;then \ echo "(use mysql-client)(hash-table-set! *available-db* 'mysql #t)" >> altdb.scm; \ fi - if csi -ne '(use postgresql)';then \ + if csi -ne '(use postgresql)'&> /dev/null;then \ echo "(use postgresql)(hash-table-set! *available-db* 'postgresql #t)" >> altdb.scm;\ fi + if csi -ne '(import mysql-client)'&> /dev/null;then \ + echo "(import mysql-client)(hash-table-set! *available-db* 'mysql #t)" >> altdb.scm; \ + fi + if csi -ne '(import postgresql)'&> /dev/null;then \ + echo "(import postgresql)(hash-table-set! *available-db* 'postgresql #t)" >> altdb.scm;\ + fi + +# portlogger-example : portlogger-example.scm api.o archive.o common.o configf.o dashboard-tests.o dashboard-context-menu.o db.o dcommon.o ezsteps.o genexample.o gutils.o items.o keys.o launch.o lock-queue.o margs.o mt.o ods.o portlogger.o process.o rmt.o runconfig.o runs.o server.o synchash.o tasks.o tdb.o tests.o tree.o +# csc $(CSCOPTS) portlogger-example.scm api.o archive.o common.o configf.o dashboard-tests.o dashboard-context-menu.o db.o dcommon.o ezsteps.o genexample.o gutils.o items.o keys.o launch.o lock-queue.o margs.o mt.o ods.o portlogger.o process.o rmt.o runconfig.o runs.o server.o sync-hash.o tasks.o tdb.o tests.o tree.o + +unitdeps.dot : *scm ./utils/plot-uses Makefile + ./utils/plot-uses todot commonmod.import,mtargs.import,mtargs,debugprint *.scm > unitdeps.dot + +unitdeps.pdf : unitdeps.dot + dot unitdeps.dot -Tpdf -o unitdeps.pdf -portlogger-example : portlogger-example.scm api.o archive.o client.o common.o configf.o dashboard-tests.o dashboard-context-menu.o db.o dcommon.o ezsteps.o filedb.o genexample.o gutils.o http-transport.o items.o keys.o launch.o lock-queue.o margs.o mt.o ods.o portlogger.o process.o rmt.o runconfig.o runs.o sdb.o server.o synchash.o tasks.o tdb.o tests.o tree.o - csc $(CSCOPTS) portlogger-example.scm api.o archive.o client.o common.o configf.o dashboard-tests.o dashboard-context-menu.o db.o dcommon.o ezsteps.o filedb.o genexample.o gutils.o http-transport.o items.o keys.o launch.o lock-queue.o margs.o mt.o ods.o portlogger.o process.o rmt.o runconfig.o runs.o sdb.o server.o synchash.o tasks.o tdb.o tests.o tree.o +./utils/plot-uses : utils/plot-uses.scm + csc utils/plot-uses.scm # create a pdf dot graphviz diagram from notations in rmt.scm rmt.pdf : rmt.scm grep ';;DOT' rmt.scm | sed -e 's/.*;;DOT //' > rmt.dot;dot -Tpdf rmt.dot -o rmt.pdf buildmanual: cd docs/manual && make -wikipage=plan -editwiki: - cd docs/manual && ../../utils/editwiki $(wikipage) - -viewmanual: - arora docs/manual/megatest_manual.html - targets: @grep : Makefile | perl -ne '/^([A-Za-z0-9_-]+):/ && print "$$1\n"' - unit : cd tests;make unit Index: NOTES ================================================================== --- NOTES +++ NOTES @@ -12,15 +12,10 @@ # MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the # GNU General Public License for more details. # # You should have received a copy of the GNU General Public License # along with Megatest. If not, see . - -(server:writable-watchdog-bruteforce dbstruct) - -(server:writable-watchdog-deltasync dbstruct) - ===================================================================== NOTES from looking at branch v1.62-rpc ===================================================================== Index: TODO ================================================================== --- TODO +++ TODO @@ -16,16 +16,56 @@ # along with Megatest. If not, see . TODO ==== -WW38 -. Add test_rundat to no-sync ==> correction, put in /.meta/test-run.dat -. Add STATE/STATUS transitions to .meta/test-run.dat or similar -. Swizzle update-test-rundat to operate on no-sync -. Swizzle update-run-duration, -uname-host and cpuload-diskfree to no-sync -. On state/status change update tests table with duration +23WW48 +. Add calls-per-minute to db access stats +. Find out why start-server calls are taking 250ms and fix +. Allow two or three servers to run for any given db +. Update avg call count/sec every 30 sec in no-sync +. get server uses no-sync process info to decide which server to suggest +. Use process table to decide who will do sync back +. Fix metadat being synced over and over + +23WW47 +. Finding server +.. look at .servinfo for likely prime main +.. ask the .servinfo prime main for real prime main +.. save prime main (for how long, 10 seconds or 10 minutes?) + +. Starting prime main +.. get servinfo files - START +.. no files? create my servinfo file, goto START +.. have files? am I the prime main according to servinfo files? +.. no, I'm not the prime main, ping prime main +.. ping is good, prime main exists, register self as server if on same host as prime main DONE +.. no pirng response, remove the .servinfo file - goto START +.. if I am prime main according to .servinfo files, register directly in no-sync + +. Starting non-main +.. get servinfo files +.. no files? launch server for main.db +.. have files? pick out prime main +.. register self as server with prime main + +23WW46 - v1.80 branch +. Use file semaphore to kill tests, eliminate db load of the KILLREQ query +. Merge this change to revolution branch +23WW45 - the revolution branch +. Add "fast" db start option (no handshaking over NFS) +. Add server-ro to server types (just "server" is fine for read/write). +. [DONE] Create pause-server and resume-server calls +. Create rsync or cp sync to MTRAH function +. Change rmt:send-receive to divert calls to read-only server when possible +. [DONE] Change start server to call main.db server for 1..N.db servers, block until server is read for use. + +23WW21 +. Dashboard needs its own cache db in /tmp + +23WW07 +. Remove use of *dbstruct-dbs* WW15 . fill newview matrix with data, filter pipeline gui elements . improve [script], especially indent handling @@ -42,10 +82,11 @@ . break command line into sections; all, run control, queries, utilities etc. . pull in ftfplan (not integrated, just code pulled in) WW20 . ./configure => ubuntu, sles11, sles12, rh7 +. Jenkins junit XML support . Add output flushing in teamcity support . Switch to using simple runs query everywhere . Add end_time to runs and add a rollup call that sets state, status and end_time Future Index: api.scm ================================================================== --- api.scm +++ api.scm @@ -16,16 +16,31 @@ ;; You should have received a copy of the GNU General Public License ;; along with Megatest. If not, see . ;; ;;====================================================================== -(use srfi-69 posix) - (declare (unit api)) -(declare (uses rmt)) (declare (uses db)) +(declare (uses debugprint)) +(declare (uses commonmod)) +(declare (uses dbmod)) +(declare (uses dbfile)) (declare (uses tasks)) +(declare (uses tcp-transportmod)) + +(import commonmod) +(import dbmod) +(import dbfile) +(import debugprint) +(import tcp-transportmod) + +(use srfi-69 + srfi-18 + posix + matchable + s11n + typed-records) ;; allow these queries through without starting a server ;; (define api:read-only-queries '(get-key-val-pairs @@ -32,10 +47,11 @@ get-var get-keys get-key-vals test-toplevel-num-items get-test-info-by-id + get-test-state-status-by-id get-steps-info-by-id get-data-info-by-id test-get-rundir-from-test-id get-count-tests-running-for-testname get-count-tests-running @@ -52,12 +68,12 @@ get-run-info get-run-status get-run-state get-run-stats get-run-times - get-targets get-target + get-targets ;; register-run get-tests-tags get-test-times get-tests-for-run get-tests-for-run-state-status @@ -74,27 +90,29 @@ get-run-ids-matching-target get-runs-by-patt get-steps-data get-steps-for-test read-test-data - read-test-data* + read-test-data-varpatt login tasks-get-last testmeta-get-record have-incompletes? - ;; synchash-get get-changed-record-ids + get-all-runids + get-changed-record-test-ids + get-changed-record-run-ids get-run-record-ids get-not-completed-cnt)) (define api:write-queries '( get-keys-write ;; dummy "write" query to force server start ;; SERVERS - start-server - kill-server + ;; start-server + ;; kill-server ;; TESTS test-set-state-status-by-id delete-test-records delete-old-deleted-test-records @@ -119,11 +137,11 @@ ;; TEST DATA test-data-rollup csv->test-data ;; MISC - sync-inmem->db + sync-cachedb->db drop-all-triggers create-all-triggers update-tesdata-on-repilcate-db ;; TESTMETA @@ -133,275 +151,357 @@ ;; TASKS tasks-add tasks-set-state-given-param-key )) -;; These are called by the server on recipt of /api calls -;; - keep it simple, only return the actual result of the call, i.e. no meta info here -;; -;; - returns #( flag result ) -;; -(define (api:execute-requests dbstruct dat) - (handle-exceptions - exn - (let ((call-chain (get-call-chain))) - (debug:print 0 *default-log-port* "WARNING: api:execute-requests received an exception from peer, dat=" dat ", exn=" exn) - (print-call-chain (current-error-port)) - (debug:print 0 *default-log-port* " message: " ((condition-property-accessor 'exn 'message) exn)) - (vector #f (vector exn call-chain dat))) ;; return some stuff for debug if an exception happens - (cond - ((not (vector? dat)) ;; it is an error to not receive a vector - (vector #f (vector #f "remote must be called with a vector"))) - ((> *api-process-request-count* 20) ;; 20) - (debug:print 0 *default-log-port* "WARNING: api:execute-requests received an overloaded message.") - (set! *server-overloaded* #t) - (vector #f (vector #f 'overloaded))) ;; the inner vector is what gets returned. nope, don't know why. please refactor! - (else - (let* ((cmd-in (common:safe-vector-ref dat 0 'nocmd)) - (cmd (if (symbol? cmd-in) - cmd-in - (string->symbol cmd-in))) - (params (common:safe-vector-ref dat 1 '())) - (start-t (current-milliseconds)) - (readonly-mode (dbr:dbstruct-read-only dbstruct)) - (readonly-command (member cmd api:read-only-queries)) - (writecmd-in-readonly-mode (and readonly-mode (not readonly-command))) - (foo (begin - #;(common:telemetry-log (conc "api-in:"(->string cmd)) - payload: `((params . ,params))) - - #t)) - (res - (if writecmd-in-readonly-mode - (conc "attempt to run write command "cmd" on a read-only database") - (case cmd - ;;=============================================== - ;; READ/WRITE QUERIES - ;;=============================================== - - ((nocmd) '(#f "All broken!")) - - ((get-keys-write) (db:get-keys dbstruct)) ;; force a dummy "write" query to force server; for debug in -repl - - ;; SERVERS - ((start-server) (apply server:kind-run params)) - ((kill-server) (set! *server-run* #f)) - - ;; TESTS - - ;;((test-set-state-status-by-id) (apply mt:test-set-state-status-by-id dbstruct params)) - ;;BB - commented out above because it was calling below, eventually, incorrectly (dbstruct passed to mt:test-set-state-status-by-id, which previosly did more, but now only passes thru to db:set-state-status-and-roll-up-items. - ((test-set-state-status-by-id) - - ;; (define (db:set-state-status-and-roll-up-items dbstruct run-id test-name item-path state status comment) - (db:set-state-status-and-roll-up-items - dbstruct - (list-ref params 0) ; run-id - (list-ref params 1) ; test-name - #f ; item-path - (list-ref params 2) ; state - (list-ref params 3) ; status - (list-ref params 4) ; comment - )) - - ((delete-test-records) (apply db:delete-test-records dbstruct params)) - ((delete-old-deleted-test-records) (apply db:delete-old-deleted-test-records dbstruct params)) - ((test-set-state-status) (apply db:test-set-state-status dbstruct params)) - ((test-set-top-process-pid) (apply db:test-set-top-process-pid dbstruct params)) - ((set-state-status-and-roll-up-items) (apply db:set-state-status-and-roll-up-items dbstruct params)) - ((set-state-status-and-roll-up-run) (apply db:set-state-status-and-roll-up-run dbstruct params)) - ((top-test-set-per-pf-counts) (apply db:top-test-set-per-pf-counts dbstruct params)) - ((test-set-archive-block-id) (apply db:test-set-archive-block-id dbstruct params)) - - ;; RUNS - ((register-run) (apply db:register-run dbstruct params)) - ((set-tests-state-status) (apply db:set-tests-state-status dbstruct params)) - ((delete-run) (apply db:delete-run dbstruct params)) - ((lock/unlock-run) (apply db:lock/unlock-run dbstruct params)) - ((update-run-event_time) (apply db:update-run-event_time dbstruct params)) - ((update-run-stats) (apply db:update-run-stats dbstruct params)) - ((set-var) (apply db:set-var dbstruct params)) - ((inc-var) (apply db:inc-var dbstruct params)) - ((dec-var) (apply db:dec-var dbstruct params)) - ((del-var) (apply db:del-var dbstruct params)) - ((add-var) (apply db:add-var dbstruct params)) - - ;; STEPS - ((teststep-set-status!) (apply db:teststep-set-status! dbstruct params)) - ((delete-steps-for-test!) (apply db:delete-steps-for-test! dbstruct params)) - - ;; TEST DATA - ((test-data-rollup) (apply db:test-data-rollup dbstruct params)) - ((csv->test-data) (apply db:csv->test-data dbstruct params)) - - ;; MISC - ((sync-inmem->db) (let ((run-id (car params))) - (db:sync-touched dbstruct run-id force-sync: #t))) - ((mark-incomplete) (apply db:find-and-mark-incomplete dbstruct params)) - ((create-all-triggers) (db:create-all-triggers dbstruct)) - ((drop-all-triggers) (db:drop-all-triggers dbstruct)) - - ;; TESTMETA - ((testmeta-add-record) (apply db:testmeta-add-record dbstruct params)) - ((testmeta-update-field) (apply db:testmeta-update-field dbstruct params)) - ((get-tests-tags) (db:get-tests-tags dbstruct)) - - ;; TASKS - ((tasks-add) (apply tasks:add dbstruct params)) - ((tasks-set-state-given-param-key) (apply tasks:set-state-given-param-key dbstruct params)) - ((tasks-get-last) (apply tasks:get-last dbstruct params)) - - ;; NO SYNC DB - ((no-sync-set) (apply db:no-sync-set *no-sync-db* params)) - ((no-sync-get/default) (apply db:no-sync-get/default *no-sync-db* params)) - ((no-sync-del!) (apply db:no-sync-del! *no-sync-db* params)) - ((no-sync-get-lock) (apply db:no-sync-get-lock *no-sync-db* params)) - ((no-sync-add-job) (apply db:no-sync-add-job *no-sync-db* params)) - ((no-sync-take-job) (apply db:no-sync-take-job *no-sync-db* params)) - ((no-sync-job-records-clean) (apply db:no-sync-job-records-clean *no-sync-db* params)) - - ;; ARCHIVES - ;; ((archive-get-allocations) - ((archive-register-disk) (apply db:archive-register-disk dbstruct params)) - ((archive-register-block-name)(apply db:archive-register-block-name dbstruct params)) - ;; ((archive-allocate-testsuite/area-to-block)(apply db:archive-allocate-testsuite/area-to-block dbstruct block-id testsuite-name areakey)) - - ;;====================================================================== - ;; READ ONLY QUERIES - ;;====================================================================== - - ;; KEYS - ((get-key-val-pairs) (apply db:get-key-val-pairs dbstruct params)) - ((get-keys) (db:get-keys dbstruct)) - ((get-key-vals) (apply db:get-key-vals dbstruct params)) - ((get-target) (apply db:get-target dbstruct params)) - ((get-targets) (db:get-targets dbstruct)) - - ;; ARCHIVES - ((test-get-archive-block-info) (apply db:test-get-archive-block-info dbstruct params)) - - ;; TESTS - ((test-toplevel-num-items) (apply db:test-toplevel-num-items dbstruct params)) - ((get-test-info-by-id) (apply db:get-test-info-by-id dbstruct params)) - ((test-get-rundir-from-test-id) (apply db:test-get-rundir-from-test-id dbstruct params)) - ((get-count-tests-running-for-testname) (apply db:get-count-tests-running-for-testname dbstruct params)) - ((get-count-tests-running) (apply db:get-count-tests-running dbstruct params)) - ((get-count-tests-running-in-jobgroup) (apply db:get-count-tests-running-in-jobgroup dbstruct params)) - ;; ((delete-test-step-records) (apply db:delete-test-step-records dbstruct params)) - ;; ((get-previous-test-run-record) (apply db:get-previous-test-run-record dbstruct params)) - ((get-matching-previous-test-run-records)(apply db:get-matching-previous-test-run-records dbstruct params)) - ((test-get-logfile-info) (apply db:test-get-logfile-info dbstruct params)) - ((test-get-records-for-index-file) (apply db:test-get-records-for-index-file dbstruct params)) - ((get-testinfo-state-status) (apply db:get-testinfo-state-status dbstruct params)) - ((test-get-top-process-pid) (apply db:test-get-top-process-pid dbstruct params)) - ((test-get-paths-matching-keynames-target-new) (apply db:test-get-paths-matching-keynames-target-new dbstruct params)) - ((get-prereqs-not-met) (apply db:get-prereqs-not-met dbstruct params)) - ((get-count-tests-running-for-run-id) (apply db:get-count-tests-running-for-run-id dbstruct params)) - ((get-not-completed-cnt) (apply db:get-not-completed-cnt dbstruct params)) - ;; ((synchash-get) (apply synchash:server-get dbstruct params)) - ((get-raw-run-stats) (apply db:get-raw-run-stats dbstruct params)) - ((get-test-times) (apply db:get-test-times dbstruct params)) - - ;; RUNS - ((get-run-info) (apply db:get-run-info dbstruct params)) - ((get-run-status) (apply db:get-run-status dbstruct params)) - ((get-run-state) (apply db:get-run-state dbstruct params)) - ((set-run-status) (apply db:set-run-status dbstruct params)) - ((set-run-state-status) (apply db:set-run-state-status dbstruct params)) - ((update-tesdata-on-repilcate-db) (apply db:update-tesdata-on-repilcate-db dbstruct params)) - ((get-tests-for-run) (apply db:get-tests-for-run dbstruct params)) - ((get-tests-for-run-state-status) (apply db:get-tests-for-run-state-status dbstruct params)) - ((get-test-id) (apply db:get-test-id dbstruct params)) - ((get-tests-for-run-mindata) (apply db:get-tests-for-run-mindata dbstruct params)) - ;; ((get-tests-for-runs-mindata) (apply db:get-tests-for-runs-mindata dbstruct params)) - ((get-runs) (apply db:get-runs dbstruct params)) - ((simple-get-runs) (apply db:simple-get-runs dbstruct params)) - ((get-num-runs) (apply db:get-num-runs dbstruct params)) - ((get-runs-cnt-by-patt) (apply db:get-runs-cnt-by-patt dbstruct params)) - ((get-all-run-ids) (db:get-all-run-ids dbstruct)) - ((get-prev-run-ids) (apply db:get-prev-run-ids dbstruct params)) - ((get-run-ids-matching-target) (apply db:get-run-ids-matching-target dbstruct params)) - ((get-runs-by-patt) (apply db:get-runs-by-patt dbstruct params)) - ((get-run-name-from-id) (apply db:get-run-name-from-id dbstruct params)) - ((get-main-run-stats) (apply db:get-main-run-stats dbstruct params)) - ((get-var) (apply db:get-var dbstruct params)) - ((get-run-stats) (apply db:get-run-stats dbstruct params)) - ((get-run-times) (apply db:get-run-times dbstruct params)) - - ;; STEPS - ((get-steps-data) (apply db:get-steps-data dbstruct params)) - ((get-steps-for-test) (apply db:get-steps-for-test dbstruct params)) - ((get-steps-info-by-id) (apply db:get-steps-info-by-id dbstruct params)) - - ;; TEST DATA - ((read-test-data) (apply db:read-test-data dbstruct params)) - ((read-test-data*) (apply db:read-test-data* dbstruct params)) - ((get-data-info-by-id) (apply db:get-data-info-by-id dbstruct params)) - - ;; MISC - ((get-latest-host-load) (apply db:get-latest-host-load dbstruct params)) - ((have-incompletes?) (apply db:have-incompletes? dbstruct params)) - ((login) (apply db:login dbstruct params)) - ((general-call) (let ((stmtname (car params)) - (run-id (cadr params)) - (realparams (cddr params))) - (db:general-call dbstruct stmtname realparams))) - ((sdb-qry) (apply sdb:qry params)) - ((ping) (current-process-id)) - ((get-changed-record-ids) (apply db:get-changed-record-ids dbstruct params)) - ((get-run-record-ids) (apply db:get-run-record-ids dbstruct params)) - ;; TESTMETA - ((testmeta-get-record) (apply db:testmeta-get-record dbstruct params)) - - ;; TASKS - ((find-task-queue-records) (apply tasks:find-task-queue-records dbstruct params)) - (else - (debug:print 0 *default-log-port* "ERROR: bad api call " cmd) - (conc "ERROR: BAD api call " cmd)))))) - - - ;; save all stats - (let ((delta-t (- (current-milliseconds) - start-t))) - (hash-table-set! *db-api-call-time* cmd - (cons delta-t (hash-table-ref/default *db-api-call-time* cmd '())))) - (if writecmd-in-readonly-mode - (begin - #;(common:telemetry-log (conc "api-out:"(->string cmd)) - payload: `((params . ,params) - (ok-res . #t))) - (vector #f res)) - (begin - #;(common:telemetry-log (conc "api-out:"(->string cmd)) - payload: `((params . ,params) - (ok-res . #f))) - (vector #t res)))))))) - -;; http-server send-response -;; api:process-request -;; db:* -;; -;; NB// Runs on the server as part of the server loop -;; -(define (api:process-request dbstruct $) ;; the $ is the request vars proc - (set! *api-process-request-count* (+ *api-process-request-count* 1)) - (let* ((cmd ($ 'cmd)) - (paramsj ($ 'params)) - (params (db:string->obj paramsj transport: 'http)) ;; incoming data from the POST (or is it a GET?) - (resdat (api:execute-requests dbstruct (vector cmd params))) ;; process the request, resdat = #( flag result ) - (success (common:safe-vector-ref resdat 0 #f)) - (res (common:safe-vector-ref resdat 1 #f))) ;; (vector flag payload), get the payload, ignore the flag (why?) - (if (not success) - (debug:print 0 *default-log-port* "ERROR: success flag is #f for " cmd " with params " params)) - (if (> *api-process-request-count* *max-api-process-requests*) - (set! *max-api-process-requests* *api-process-request-count*)) - (set! *api-process-request-count* (- *api-process-request-count* 1)) - ;; This can be here but needs controls to ensure it doesn't run more than every 4 seconds - ;; (rmt:dat->json-str - ;; (if (or (string? res) - ;; (list? res) - ;; (number? res) - ;; (boolean? res)) - ;; res - ;; (list "ERROR, not string, list, number or boolean" 1 cmd params res))))) - (db:obj->string res transport: 'http))) +(define *db-write-mutexes* (make-hash-table)) +(define *server-signature* #f) + +(define *api-threads* '()) +(define (api:register-thread th-in command) + (set! *api-threads* (cons (list th-in (current-seconds) command) *api-threads*))) + +(define (api:get-thread-command th-in) + (let ((thread-data (assoc th-in *api-threads*))) + (if thread-data + (third thread-data) ; Assuming the command is the third element in the list + #f))) ; Return #f if the thread is not found + +(define (api:unregister-thread th-in) + (set! *api-threads* (filter (lambda (thdat) + (not (eq? th-in (car thdat)))) + *api-threads*))) + +(define (api:remove-dead-or-terminated) + (set! *api-threads* (filter (lambda (thdat) + (not (member (thread-state (car thdat)) '(terminated dead)))) + *api-threads*))) + +(define (api:get-count-threads-alive) + (length *api-threads*)) + +(define (api:get-threads) + (map (lambda (thdat) + (let ((thread (first thdat)) + (timestamp (second thdat)) + (command (third thdat))) + (format "\nThread: ~a, age: ~a, Command: ~a" thread (- (current-seconds) timestamp) command))) + *api-threads*)) + + +(define *api:last-stats-print* 0) +(define *api-print-db-stats-mutex* (make-mutex)) +(define (api:print-db-stats) + (debug:print-info 0 *default-log-port* "Started periodic db stats printer") + (let loop () + (mutex-lock! *api-print-db-stats-mutex*) + (if (> (- (current-seconds) *api:last-stats-print*) 15) + (begin + (rmt:print-db-stats) + (set! *api:last-stats-print* (current-seconds)))) + (mutex-unlock! *api-print-db-stats-mutex*) + (thread-sleep! 5) + (loop))) + + +;; indat is (cmd run-id params meta) +;; +;; WARNING: Do not print anything in the lambda of this function as it +;; reads/writes to current in/out port +;; +(define (api:tcp-dispatch-request-make-handler dbstruct) ;; cmd run-id params) + (assert *toppath* "FATAL: api:tcp-dispatch-request-make-handler called but *toppath* not set.") + (if (not *server-signature*) + (set! *server-signature* (tt:mk-signature *toppath*))) + (lambda (indat) + (api:register-thread (current-thread) (car indat)) + (let* ((result + (let* ((numthreads (api:get-count-threads-alive)) + (delay-wait (if (> numthreads 10) + (- numthreads 10) + 0)) + (normal-proc (lambda (cmd run-id params) + (case cmd + ((ping) *server-signature*) + (else + (api:dispatch-request dbstruct cmd run-id params)))))) + (set! *api-process-request-count* numthreads) + (set! *db-last-access* (current-seconds)) +;; (if (not (eq? numthreads numthreads)) +;; (begin +;; (api:remove-dead-or-terminated) +;; (let ((threads-now (api:get-count-threads-alive))) +;; (debug:print 0 *default-log-port* "WARNING: numthreads="numthreads", numthreads="numthreads", remaining="threads-now) +;; (set! numthreads threads-now)))) + (match indat + ((cmd run-id params meta) + (let* ((start-t (current-milliseconds)) + (db-ok (let* ((dbfname (dbmod:run-id->dbfname run-id)) + (ok (equal? dbfname (dbr:dbstruct-dbfname dbstruct)))) + (case cmd + ((ping) #t) ;; we are fine + (else + (assert ok "FATAL: database file and run-id not aligned."))))) + (ttdat *server-info*) + (server-state (tt-state ttdat)) + (maxthreads 20) ;; make this a parameter? + (status (cond + ((> numthreads maxthreads) + (let* ((testsuite (common:get-testsuite-name)) + (mtexe (common:find-local-megatest)) + (proc (lambda () + ;; we are overloaded, try to start another server + (debug:print 0 *default-log-port* "Too many threads running, starting another server") + (tt:server-process-run *toppath* testsuite mtexe run-id)))) + (set! *server-start-requests* (cons proc *server-start-requests*))) + ;; 'busy + 'loaded ;; not ideal since the client will not backoff + ) + (else 'ok))) + (errmsg (case status + ((busy) (conc "Server overloaded, "numthreads" threads in flight, current cmd: " cmd "\n current threads: " (api:get-threads))) + ((loaded) (conc "Server loaded, "numthreads" threads in flight")) + (else #f))) + (result (case status + ((busy) + (if (eq? cmd 'ping) + (normal-proc cmd run-id params) + ;; numthreads must be greater than 5 for busy + (* 0.1 (- numthreads maxthreads)) ;; was 15 + )) ;; (- numthreads 29)) ;; call back in as many seconds + ((loaded) + ;; (if (eq? (rmt:transport-mode) 'tcp) + ;; (thread-sleep! 0.5)) + (normal-proc cmd run-id params)) + (else + (normal-proc cmd run-id params)))) + (meta (case cmd + ((ping) `((sstate . ,server-state)(sload . ,numthreads))) + (else `((wait . ,delay-wait))))) + (payload (list status errmsg result meta))) + ;; (cmd run-id params meta) + (db:add-stats cmd run-id params (- (current-milliseconds) start-t)) + payload)) + (else + (assert #f "FATAL: failed to deserialize indat "indat)))))) + ;; (set! *api-process-request-count* (- *api-process-request-count* 1)) + ;; (serialize payload) + + (api:unregister-thread (current-thread)) + result))) + +(define *api-halt-writes* #f) + +(define (api:dispatch-request dbstruct cmd run-id params) + (if (not *no-sync-db*) + (db:open-no-sync-db)) + (let* ((start-time (current-milliseconds))) + (if (member cmd api:write-queries) + (let loop () + (if *api-halt-writes* + (begin + (thread-sleep! 0.2) + (if (< (- (current-milliseconds) start-time) + 5000) ;; hope it don't take more than five seconds to sync + (loop-time) + #;(debug:print 0 *default-log-port* "ERROR: writes halted for more than 5 seconds, sync might be taking too long")))))) + (db:add-stats 'api-write-blocking-for-sync run-id params (- (current-milliseconds) start-time))) + (case cmd + ;;=============================================== + ;; READ/WRITE QUERIES + ;;=============================================== + + ((get-keys-write) (db:get-keys dbstruct)) ;; force a dummy "write" query to force server; for debug in -repl + + ;; SERVERS + ((start-server) (apply tt:server-process-run params)) + ((kill-server) (set! *server-run* #f)) + + ;; TESTS + + ;;((test-set-state-status-by-id) (apply mt:test-set-state-status-by-id dbstruct params)) + ;;BB - commented out above because it was calling below, eventually, incorrectly (dbstruct passed to mt:test-set-state-status-by-id, which previosly did more, but now only passes thru to db:set-state-status-and-roll-up-items. + ((test-set-state-status-by-id) + + ;; (define (db:set-state-status-and-roll-up-items dbstruct run-id test-name item-path state status comment) + (db:set-state-status-and-roll-up-items + dbstruct + (list-ref params 0) ; run-id + (list-ref params 1) ; test-name + #f ; item-path + (list-ref params 2) ; state + (list-ref params 3) ; status + (list-ref params 4) ; comment + )) + + ((delete-test-records) (apply db:delete-test-records dbstruct params)) + ((delete-old-deleted-test-records) (apply db:delete-old-deleted-test-records dbstruct params)) + ((test-set-state-status) (apply db:test-set-state-status dbstruct params)) + ((test-set-top-process-pid) (apply db:test-set-top-process-pid dbstruct params)) + ((set-state-status-and-roll-up-items) (apply db:set-state-status-and-roll-up-items dbstruct params)) + ((set-state-status-and-roll-up-run) (apply db:set-state-status-and-roll-up-run dbstruct params)) + ((top-test-set-per-pf-counts) (apply db:top-test-set-per-pf-counts dbstruct params)) + ((test-set-archive-block-id) (apply db:test-set-archive-block-id dbstruct params)) + + ((insert-test) (db:insert-test dbstruct run-id params)) + + ;; RUNS + ((register-run) (apply db:register-run dbstruct params)) + ((set-tests-state-status) (apply db:set-tests-state-status dbstruct params)) + ((delete-run) (apply db:delete-run dbstruct params)) + ((lock/unlock-run) (apply db:lock/unlock-run dbstruct params)) + ((update-run-event_time) (apply db:update-run-event_time dbstruct params)) + ((update-run-stats) (apply db:update-run-stats dbstruct params)) + ((set-var) (apply db:set-var dbstruct params)) + ((inc-var) (apply db:inc-var dbstruct params)) + ((dec-var) (apply db:dec-var dbstruct params)) + ((del-var) (apply db:del-var dbstruct params)) + ((add-var) (apply db:add-var dbstruct params)) + + ((insert-run) (apply db:insert-run dbstruct params)) + + ;; STEPS + ((teststep-set-status!) (apply db:teststep-set-status! dbstruct params)) + ((delete-steps-for-test!) (apply db:delete-steps-for-test! dbstruct params)) + + ;; TEST DATA + ((test-data-rollup) (apply db:test-data-rollup dbstruct params)) + ((csv->test-data) (apply db:csv->test-data dbstruct params)) + + ;; MISC + ((sync-cachedb->db) (let ((run-id (car params))) + (db:sync-touched dbstruct run-id db:initialize-main-db force-sync: #t))) + ((get-toplevels-and-incompletes) (apply db:get-toplevels-and-incompletes dbstruct params)) + ((mark-incomplete) #f);;(thread-start! (make-thread (lambda () ;; no need to block on this one + ;; (apply db:find-and-mark-incomplete dbstruct params) + ;; #t)))) + ((create-all-triggers) (db:create-all-triggers dbstruct)) + ((drop-all-triggers) (db:drop-all-triggers dbstruct)) + + ;; TESTMETA + ((testmeta-add-record) (apply db:testmeta-add-record dbstruct params)) + ((testmeta-update-field) (apply db:testmeta-update-field dbstruct params)) + ((get-tests-tags) (db:get-tests-tags dbstruct)) + + ;; TASKS + ((tasks-add) (apply tasks:add dbstruct params)) + ((tasks-set-state-given-param-key) (apply tasks:set-state-given-param-key dbstruct params)) + ((tasks-get-last) (apply tasks:get-last dbstruct params)) + + ;; NO SYNC DB + ((no-sync-set) (apply db:no-sync-set *no-sync-db* params)) + ((no-sync-get/default) (apply db:no-sync-get/default *no-sync-db* params)) + ((no-sync-del!) (apply db:no-sync-del! *no-sync-db* params)) + ((no-sync-get-lock) (apply db:no-sync-get-lock *no-sync-db* params)) + ((no-sync-add-job) (apply db:no-sync-add-job *no-sync-db* params)) + ((no-sync-take-job) (apply db:no-sync-take-job *no-sync-db* params)) + ((no-sync-job-records-clean) (apply db:no-sync-job-records-clean *no-sync-db* params)) + + ;; NO SYNC DB PROCESSES + ((register-process) (apply dbfile:register-process *no-sync-db* params)) + ((set-process-done) (apply dbfile:set-process-done *no-sync-db* params)) + ((set-process-status) (apply dbfile:set-process-status *no-sync-db* params)) + ((get-process-options) (apply dbfile:get-process-options *no-sync-db* params)) + + ;; ARCHIVES + ;; ((archive-get-allocations) + ((archive-register-disk) (apply db:archive-register-disk dbstruct params)) + ((archive-register-block-name)(apply db:archive-register-block-name dbstruct params)) + ;; ((archive-allocate-testsuite/area-to-block)(apply db:archive-allocate-testsuite/area-to-block dbstruct block-id testsuite-name areakey)) + + ;;====================================================================== + ;; READ ONLY QUERIES + ;;====================================================================== + + ;; KEYS + ((get-key-val-pairs) (apply db:get-key-val-pairs dbstruct params)) + ((get-keys) (db:get-keys dbstruct)) + ((get-key-vals) (apply db:get-key-vals dbstruct params)) + ((get-target) (apply db:get-target dbstruct params)) + ((get-targets) (db:get-targets dbstruct)) + + ;; ARCHIVES + ((test-get-archive-block-info) (apply db:test-get-archive-block-info dbstruct params)) + + ;; TESTS + ((test-toplevel-num-items) (apply db:test-toplevel-num-items dbstruct params)) + ((get-test-info-by-id) (apply db:get-test-info-by-id dbstruct params)) + ((get-test-state-status-by-id) (apply db:get-test-state-status-by-id dbstruct params)) + ((test-get-rundir-from-test-id) (apply db:test-get-rundir-from-test-id dbstruct params)) + ((get-count-tests-running-for-testname) (apply db:get-count-tests-running-for-testname dbstruct params)) + ((get-count-tests-running) (apply db:get-count-tests-running dbstruct params)) + ((get-count-tests-running-in-jobgroup) (apply db:get-count-tests-running-in-jobgroup dbstruct params)) + ;; ((delete-test-step-records) (apply db:delete-test-step-records dbstruct params)) + ;; ((get-previous-test-run-record) (apply db:get-previous-test-run-record dbstruct params)) + ((get-matching-previous-test-run-records)(apply db:get-matching-previous-test-run-records dbstruct params)) + ((test-get-logfile-info) (apply db:test-get-logfile-info dbstruct params)) + ((test-get-records-for-index-file) (apply db:test-get-records-for-index-file dbstruct params)) + ((get-testinfo-state-status) (apply db:get-testinfo-state-status dbstruct params)) + ((test-get-top-process-pid) (apply db:test-get-top-process-pid dbstruct params)) + ((test-get-paths-matching-keynames-target-new) (apply db:test-get-paths-matching-keynames-target-new dbstruct params)) + ((get-prereqs-not-met) (apply db:get-prereqs-not-met dbstruct params)) + ((get-count-tests-running-for-run-id) (apply db:get-count-tests-running-for-run-id dbstruct params)) + ((get-not-completed-cnt) (apply db:get-not-completed-cnt dbstruct params)) + ((get-raw-run-stats) (apply db:get-raw-run-stats dbstruct params)) + ((get-test-times) (apply db:get-test-times dbstruct params)) + + ;; RUNS + ((get-run-info) (apply db:get-run-info dbstruct params)) + ((get-run-status) (apply db:get-run-status dbstruct params)) + ((get-run-state) (apply db:get-run-state dbstruct params)) + ((get-run-state-status) (apply db:get-run-state-status dbstruct params)) + ((set-run-status) (apply db:set-run-status dbstruct params)) + ((set-run-state-status) (apply db:set-run-state-status dbstruct params)) + ((update-tesdata-on-repilcate-db) (apply db:update-tesdata-on-repilcate-db dbstruct params)) + ((get-tests-for-run) (apply db:get-tests-for-run dbstruct params)) + ((get-tests-for-run-state-status) (apply db:get-tests-for-run-state-status dbstruct params)) + ((get-test-id) (apply db:get-test-id dbstruct params)) + ((get-tests-for-run-mindata) (apply db:get-tests-for-run-mindata dbstruct params)) + ;; ((get-tests-for-runs-mindata) (apply db:get-tests-for-runs-mindata dbstruct params)) + ((get-runs) (apply db:get-runs dbstruct params)) + ((simple-get-runs) (apply db:simple-get-runs dbstruct params)) + ((get-num-runs) (apply db:get-num-runs dbstruct params)) + ((get-runs-cnt-by-patt) (apply db:get-runs-cnt-by-patt dbstruct params)) + ((get-all-run-ids) (db:get-all-run-ids dbstruct)) + ((get-prev-run-ids) (apply db:get-prev-run-ids dbstruct params)) + ((get-run-ids-matching-target) (apply db:get-run-ids-matching-target dbstruct params)) + ((get-runs-by-patt) (apply db:get-runs-by-patt dbstruct params)) + ((get-run-name-from-id) (apply db:get-run-name-from-id dbstruct params)) + ((get-main-run-stats) (apply db:get-main-run-stats dbstruct params)) + ((get-var) (apply db:get-var dbstruct params)) + ((get-run-stats) (apply db:get-run-stats dbstruct params)) + ((get-run-times) (apply db:get-run-times dbstruct params)) + + ;; STEPS + ((get-steps-data) (apply db:get-steps-data dbstruct params)) + ((get-steps-for-test) (apply db:get-steps-for-test dbstruct params)) + ((get-steps-info-by-id) (apply db:get-steps-info-by-id dbstruct params)) + + ;; TEST DATA + ((read-test-data) (apply db:read-test-data dbstruct params)) + ((read-test-data-varpatt) (apply db:read-test-data-varpatt dbstruct params)) + ((get-data-info-by-id) (apply db:get-data-info-by-id dbstruct params)) + + ;; MISC + ((get-latest-host-load) (apply db:get-latest-host-load dbstruct params)) + ((have-incompletes?) (apply db:have-incompletes? dbstruct params)) + ((login) (apply db:login dbstruct params)) + ((general-call) (let ((stmtname (car params)) + (run-id (cadr params)) + (realparams (cddr params))) + (db:general-call dbstruct run-id stmtname realparams))) + ((sdb-qry) (apply sdb:qry params)) + ((ping) (current-process-id)) + ((get-changed-record-ids) (apply db:get-changed-record-ids dbstruct params)) + ((get-changed-record-test-ids) (apply db:get-changed-record-test-ids dbstruct params)) + ((get-changed-record-run-ids) (apply db:get-changed-record-run-ids dbstruct params)) + ((get-run-record-ids) (apply db:get-run-record-ids dbstruct params)) + ((get-all-runids) (apply db:get-all-runids dbstruct)) + ;; TESTMETA + ((testmeta-get-record) (apply db:testmeta-get-record dbstruct params)) + + ;; TASKS + ((find-task-queue-records) (apply tasks:find-task-queue-records dbstruct params)) + (else + (debug:print 0 *default-log-port* "ERROR: bad api call " cmd) + (conc "ERROR: BAD api call " cmd)))) Index: apimod.scm ================================================================== --- apimod.scm +++ apimod.scm @@ -18,20 +18,15 @@ ;;====================================================================== (declare (unit apimod)) (declare (uses commonmod)) -(declare (uses ulex)) (module apimod * (import scheme chicken data-structures extras) (import (prefix sqlite3 sqlite3:) posix typed-records srfi-18) (import commonmod) -(import (prefix ulex ulex:)) -(define (api:execute-requests params) - #f) - ) Index: archive.scm ================================================================== --- archive.scm +++ archive.scm @@ -16,15 +16,25 @@ ;; along with Megatest. If not, see . ;; ;; strftime('%m/%d/%Y %H:%M:%S','now','localtime') -(use (prefix sqlite3 sqlite3:) srfi-1 posix regex regex-case srfi-69 format md5 message-digest srfi-18) - (declare (unit archive)) (declare (uses db)) +(declare (uses debugprint)) +(declare (uses mtargs)) (declare (uses common)) +(declare (uses commonmod)) +(declare (uses rmtmod)) + +(use (prefix sqlite3 sqlite3:) srfi-1 posix regex regex-case srfi-69 + format md5 message-digest srfi-18) + +(import commonmod + debugprint + rmtmod + (prefix mtargs args:)) (include "common_records.scm") (include "db_records.scm") ;;====================================================================== @@ -346,14 +356,14 @@ (rsync-exe (or (configf:lookup *configdat* "archive" "rsync") "rsync")) (print-prefix "Running: ") (archive-info (archive:allocate-new-archive-block blockid-cache *toppath* tsname min-space target-patt run-patt "megatest-db")) (archive-dir (if archive-info (cdr archive-info) #f)) (archive-id (if archive-info (car archive-info) -1)) - (home-host (common:get-homehost)) + (home-host (server:choose-server *toppath* 'homehost)) (archive-time (seconds->std-time-str (current-seconds))) (archive-staging-db (conc *toppath* "/.db-snapshot/archive_" archive-time)) - (tmp-db-path (conc (common:get-db-tmp-area) "/megatest.db")) + (tmp-db-path (conc (dbfile:make-tmpdir-name *toppath* "") "/megatest.db")) (dbfile (conc archive-staging-db "/megatest.db"))) (create-directory archive-staging-db #t) (let-values (((pid-val exit-status exit-code) (run-n-wait rsync-exe params: (list "-v" (conc (car home-host) ":"tmp-db-path) archive-staging-db) print-cmd: print-prefix))) (if (eq? exit-code 0) (case archiver @@ -384,31 +394,31 @@ (let-values (((pid-val exit-status exit-code) (run-n-wait bup-exe params: bup-save-params print-cmd: print-prefix))) (if (not (eq? exit-code 0)) (begin (debug:print-error 0 *default-log-port* "There was an error archiving data with bup. Archive failed.") (exit 1)) - (debug:print-info 2 *default-log-port* "To restore megatest.db run megatest -archive replicacte-db -source archive-dir -time-stamp . Current timestamp: " (seconds->std-time-str (current-seconds))))))) + (debug:print-info 0 *default-log-port* "To restore megatest.db run megatest -archive replicacte-db -source archive-dir -time-stamp . Current timestamp: " (seconds->std-time-str (current-seconds))))))) (else (debug:print-info 0 *default-log-port* "No support for databse archiving with " archiver))) (debug:print-error 0 *default-log-port* "There was an error rsyncing tmp database"))))) (define (archive:restore-db archive-path ts) (let* ((bup-exe (or (configf:lookup *configdat* "archive" "bup") "bup")) (archive-internal-path (conc (common:get-testsuite-name) "-megatest-db/" ts "/megatest.db" )) (bup-restore-params (list "-d" archive-path "restore" "-C" *toppath* archive-internal-path))) - (debug:print-info 0 *default-log-port* "Restoring archived data to " *toppath* " from archive in " archive-path " ... " archive-internal-path) - (run-n-wait bup-exe params: bup-restore-params print-cmd: #f)) + (debug:print-info 2 *default-log-port* "Restoring archived data to " *toppath* " from archive in " archive-path " ... " archive-internal-path) + (run-n-wait bup-exe params: bup-restore-params print-cmd: "Running:")) + (sleep 2) (db:multi-db-sync - (db:setup #f) + (db:setup) ;; (db:setup-db *dbstruct-dbs* *toppath* #f) 'killservers ;'dejunk ;'adj-testids 'old2new ) - (debug:print-info 1 *default-log-port* "dropping trigerrs to update linktree") + (debug:print-info 1 *default-log-port* "dropping triggers to update linktree") (rmt:drop-all-triggers) - (let* ((linktree (common:get-linktree)) ;; (configf:lookup *configdat* "setup" "linktree"))) (src-archive-linktree (rmt:get-var "src-archive-linktree"))) (if (not (equal? src-archive-linktree linktree)) (rmt:update-tesdata-on-repilcate-db src-archive-linktree linktree)) (debug:print-info 1 *default-log-port* "creating triggers after updating linktree") @@ -416,10 +426,11 @@ )) (define (archive:ls->list bup-exe archive-dir internal-path) (let ((cmd (conc bup-exe " -d " archive-dir " ls -l " internal-path "| awk '{print $6}' | sort")) (res '())) + (debug:print-info 0 *default-log-port* cmd) (handle-exceptions exn #f ;; anything goes wrong - assume the process in NOT running. (with-input-from-pipe cmd @@ -437,22 +448,23 @@ (seconds->local-time sec) "%Y-%m-%d-%H%M%S")) (define (archive:get-timestamp-dir bup-exe archive-dir testsuite-name target test-partial-path test-last-update) - (print (seconds->std-time-str test-last-update)) + (debug:print-info 0 *default-log-port* "Test last update time:" (seconds->std-time-str test-last-update)) (let* ((internal-path (conc testsuite-name "-" target)) + (archive-update-delay (string->number (or (configf:lookup *configdat* "archive" "test-update-delay") "900" ))) (ts-list (archive:ls->list bup-exe archive-dir internal-path)) (ds-flag (vector-ref (seconds->local-time) 8))) (let loop ((hed (car ts-list)) (tail (cdr ts-list))) (if (and (null? tail) (equal? hed "latest")) #f (if (and (not (null? tail)) (equal? hed "latest")) (loop (car tail) (cdr tail)) (let* ((archive-seconds (time-string->seconds hed ds-flag))) - (if (< (abs (- archive-seconds test-last-update)) 120) + (if (< (abs (- archive-seconds test-last-update)) archive-update-delay) (let* ((test-list (archive:ls->list bup-exe archive-dir (conc internal-path "/" hed "/" test-partial-path)))) (if (> (length test-list) 0) hed (if (not (null? tail)) (loop (car tail) (cdr tail)) @@ -506,10 +518,11 @@ (exclude-file (args:get-arg "-exclude-rx-from"))) (if (not archive-timestamp-dir) (debug:print-error 0 *default-log-port* "Archive not found for testsuite" (common:get-testsuite-name) " run/test/itempath" test-partial-path) (begin ;; some sanity checks, move an existing path out of the way - iif it is not a toplevel with children + (debug:print-info 0 *default-log-port* "Archive time: " archive-timestamp-dir) (if (and (not toplevel/children) ;; special handling needed for toplevel with children prev-test-physical-path (common:file-exists? prev-test-physical-path)) ;; what to do? abort or clean up or link it in? (let* ((base (pathname-directory prev-test-physical-path)) (dirn (pathname-file prev-test-physical-path)) ADDED artifacts.scm Index: artifacts.scm ================================================================== --- /dev/null +++ artifacts.scm @@ -0,0 +1,24 @@ +;;====================================================================== +;; Copyright 2019, Matthew Welland. +;; +;; This file is part of Megatest. +;; +;; Megatest is free software: you can redistribute it and/or modify +;; it under the terms of the GNU General Public License as published by +;; the Free Software Foundation, either version 3 of the License, or +;; (at your option) any later version. +;; +;; Megatest is distributed in the hope that it will be useful, +;; but WITHOUT ANY WARRANTY; without even the implied warranty of +;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +;; GNU General Public License for more details. +;; +;; You should have received a copy of the GNU General Public License +;; along with Megatest. If not, see . + +;;====================================================================== + +(declare (unit artifacts)) + +(include "artifacts/artifacts.scm") + ADDED artifacts/README Index: artifacts/README ================================================================== --- /dev/null +++ artifacts/README @@ -0,0 +1,1 @@ +NOTE: keep megatest/artifacts/ in sync with datastore/artifacts ADDED artifacts/artifacts.meta Index: artifacts/artifacts.meta ================================================================== --- /dev/null +++ artifacts/artifacts.meta @@ -0,0 +1,21 @@ +;; -*- scheme -*- +( +; Your egg's license: +(license "BSD") + +; Pick one from the list of categories (see below) for your egg and enter it +; here. +(category db) + +; A list of eggs pkts depends on. If none, you can omit this declaration +; altogether. If you are making an egg for chicken 3 and you need to use +; procedures from the `files' unit, be sure to include the `files' egg in the +; `needs' section (chicken versions < 3.4.0 don't provide the `files' unit). +; `depends' is an alias to `needs'. +;; (needs (autoload "3.0")) + +; A list of eggs required for TESTING ONLY. See the `Tests' section. +(test-depends test) + +(author "Matt Welland") +(synopsis "A sha1-chain based datastore similar to the data format in fossil scm, consisting of artifacts of single line cards.")) ADDED artifacts/artifacts.release-info Index: artifacts/artifacts.release-info ================================================================== --- /dev/null +++ artifacts/artifacts.release-info @@ -0,0 +1,3 @@ +(repo fossil "http://www.kiatoa.com/cgi-bin/fossils/{egg-name}") +(uri zip "http://www.kiatoa.com/cgi-bin/fossils/{egg-name}/zip/{egg-name}.zip?uuid={egg-release}") +(release "1.0") ADDED artifacts/artifacts.scm Index: artifacts/artifacts.scm ================================================================== --- /dev/null +++ artifacts/artifacts.scm @@ -0,0 +1,1624 @@ +;; Copyright 2006-2017, Matthew Welland. +;; +;; This file is part of artifacts +;; +;; Pkts is free software: you can redistribute it and/or modify +;; it under the terms of the GNU General Public License as published by +;; the Free Software Foundation, either version 3 of the License, or +;; (at your option) any later version. +;; +;; Pkts is distributed in the hope that it will be useful, +;; but WITHOUT ANY WARRANTY; without even the implied warranty of +;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +;; GNU General Public License for more details. +;; +;; You should have received a copy of the GNU General Public License +;; along with Pkts. If not, see . +;; + +;; CARDS: +;; +;; A card is a line of text, the first two characters are a letter followed by a +;; space. The letter is the card type. +;; +;; artifact: +;; +;; An artifact is a sorted list of cards with a final card Z that contains the shar1 hash +;; of all of the preceding cards. +;; +;; AARTIFACT: +;; +;; An alist mapping card types to card data +;; '((T . "artifacttype") +;; (a . "some content")) +;; +;; EARTIFACT: +;; +;; Extended packet using friendly keys. Must use a artifactspec to convert to/from eartifacts +;; '((ptype . "artifacttype") +;; (adata . "some content)) +;; +;; DARTIFACT: +;; +;; artifacts pulled from the database have this format: +;; +;;((aartifact (Z . "7de89c09ac024b3832c93e16cd78d11e2e28733b") <= this is a the alist +;; (t . "v1.63/tip/dev") +;; (c . "QUICKPATT") +;; (T . "runstart") +;; (P . "354eeb67120a921e3e33155ecab1b522ac10b6bd") +;; (D . "1488995096.0")) +;; (id . 8) +;; (group-id . 0) +;; (uuid . "7de89c09ac024b3832c93e16cd78d11e2e28733b") +;; (parent . "") +;; (artifact-type . "runstart") +;; (artifact . "D 1488995096.0\nP 354eeb67120a921e3e33155ecab1b522ac10b6bd\nT runstart\nc QUICKPATT\nt v1.63/tip/dev\nZ 7de89c09ac024b3832c93e16cd78d11e2e28733b")) +;; +;; artifactspec is alist of alists mapping types and nicekeys to keys +;; +;; '((posting . ((title . t) +;; (url . u) +;; (blurb . b))) +;; (comment . ((comment . c) +;; (score . s)))) + +;; Reserved cards: +;; P : artifact parent +;; R : reference artifact containing mapping of short string -> sha1sum strings +;; T : artifact type +;; D : current time from (current-time), unless provided +;; Z : shar1 hash of the packet + +;; Example usage: +;; +;; Create a artifact: +;; +;; (use artifacts) +;; (define-values (uuid artifact) +;; (alist->artifact +;; '((fruit . "apple") (meat . "beef")) ;; this is the data to convert +;; '((foods (fruit . f) (meat . m))) ;; this is the artifact spec +;; ptype: +;; 'foods)) +;; +;; Add to artifact queue: +;; +;; (define db (open-queue-db "/tmp/artifacts" "artifacts.db")) +;; (add-to-queue db artifact uuid 'foods #f 0) ;; no parent and use group_id of 0 +;; +;; Retrieve the packet from the db and extract a value: +;; +;; (alist-ref +;; 'meat +;; (dartifact->alist +;; (car (get-dartifacts db #f 0 #f)) +;; '((foods (fruit . f) +;; (meat . m))))) +;; => "beef" +;; + +(module artifacts +( +;; cards, util and misc +;; sort-cards +;; calc-sha1 +;; +;; low-level constructor procs, exposed only for development/testing, will be removed +construct-sdat +construct-artifact +card->type/value +add-z-card + +;; queue database procs +open-queue-db +add-to-queue +create-and-queue +;; lookup-by-uuid +lookup-by-id +get-dartifacts +get-not-processed-artifacts +get-related +find-artifacts +process-artifacts +get-descendents +get-ancestors +get-artifacts +;; get-last-descendent +;; with-queue-db +;; load-artifacts-to-db + +;; procs that operate directly on artifacts, sdat, aartifacts, dartifacts etc. +artifact->alist ;; artifact -> aartifact (i.e. alist) +artifact->sdat ;; artifact -> '("a aval" "b bval" ...) +sdat->alist ;; '("a aval" "b bval"...) -> ((a . "aval")(b . "bval") ...) +dblst->dartifacts ;; convert list of tuples from queue db into dartifacts +dartifact->alist ;; flatten a dartifact into an alist containing all db fields and the artifact alist +dartifacts->alists ;; apply dartifact->alist to a list of alists using a artifact-spec +alist->artifact ;; returns two values uuid, artifact +get-value ;; looks up a value given a key in a dartifact +flatten-all ;; merge the list of values from a query which includes a artifact into a flat alist <== really useful! +check-artifact + +;; artifact alists +write-alist->artifact +read-artifact->alist + +;; archive database +;; archive-open-db +;; write-archive-artifacts +;; archive-artifacts +;; mark-processed + +;; artifactsdb +artifactdb-conn ;; useful +artifactdb-fname +artifactsdb-open +artifactsdb-close +artifactsdb-add-record +;; temporary +artifactdb-artifactspec + +;; utility procs +increment-string ;; used to get indexes for strings in ref artifacts +make-report ;; make a .dot file +calc-sha1 +uuid-first-two-letters +uuid-remaining-letters + +;; file and directory utils +multi-glob +capture-dir +file-get-sha1 +check-same +link-or-copy +same-partition? +link-if-same-partition +archive-copy +write-to-archive +artifact-rollup +read-artifacts-into-hash +hash-of-artifacts->bundle +archive-dest + +;; pathname-full-filename + +;; minimal artifact functions +minimal-artifact-read +minimal-artifact->alist +afact-get-D +afact-get-Z +afact-get-T +afact-get +afact-get-number/default + + +;; bundles +write-bundle +read-bundle + +;; new artifacts db +with-todays-adb +get-all-artifacts +refresh-artifacts-db + +) + +(import (chicken base) scheme (chicken process) (chicken time posix) + (chicken io) (chicken file) (chicken pathname) + chicken.process-context.posix (chicken string) + (chicken time) (chicken sort) (chicken file posix) (chicken condition) srfi-1 + regex srfi-13 srfi-69 (chicken port) (chicken process-context) + crypt sha1 matchable message-digest sqlite3 typed-records + directory-utils + scsh-process) + +;;====================================================================== +;; DATA MANIPULATION UTILS +;;====================================================================== + +(define-inline (unescape-data data) + (string-translate* data '(("\\n" . "\n") ("\\\\" . "\\")))) + +(define-inline (escape-data data) + (string-translate* data '(("\n" . "\\n") ("\\" . "\\\\")))) + +(define-inline (make-card type data) + (conc type " " (escape-data (->string data)))) + +;; reverse an alist for doing artifactkey -> external key conversions +;; +(define-inline (reverse-aspec aspec) + (map (lambda (dat) + (cons (cdr dat)(car dat))) + aspec)) + +;; add a card to the list of cards, sdat +;; if type is #f return only sdat +;; if data is #f return only sdat +;; +(define-inline (add-card sdat type data) + (if (and type data) + (cons (make-card type data) sdat) + sdat)) + +;;====================================================================== +;; STRING AS FUNKY NUMBER +;;====================================================================== + +;; NOTE: PTDZ are removed as they are reserved. NB// the R card is not used in a +;; ref, instead the P parent card is used. +;; Question: Why does it matter to remove PTDZ? +;; To make the ref easier to use the ref strings will be the keys +;; so we cannot have overlap with any actual keys. But this is a +;; bit silly. What we need to do instead is reject keys of length +;; one where the char is in PTDZ +;; +;; This is basically base92 +;; +(define string-num-chars (string->list "!#$%&'()*+,-./0123456789:;<=>?@ABCEFGHIJKLMNOQRSUVWXY[\\]^_abcdefghijklmnopqrstuvwxyz{|}~")) +;; "0123456789abcdefghijklmnopqrstuvwxyzABCEFGHIJKLMNOQSUVWXY!#$%&'()*+,-./[]:;<=>?\\^_{}|")) + +(define (char-incr inchar) + (let* ((carry #f) + (next-char (let ((rem (member inchar string-num-chars))) + (if (eq? (length rem) 1) ;; we are at the last character in our string-num-chars list + (begin + (set! carry #t) + (car string-num-chars)) + (cadr rem))))) + (values next-char carry))) + +(define (increment-string str) + (if (string-null? str) + "0" + (let ((strlst (reverse (string->list str)))) ;; need to process the string from the lsd + (list->string + (let loop ((hed (car strlst)) + (tal (cdr strlst)) + (res '())) + (let-values (((newhed carry)(char-incr hed))) + ;; (print "newhed: " newhed " carry: " carry " tal: " tal) + (let ((newres (cons newhed res))) + (if carry ;; we'll have to propagate the carry + (if (null? tal) ;; at the end, tack on "0" (which is really a "1") + (cons (car string-num-chars) newres) + (loop (car tal)(cdr tal) newres)) + (append (reverse tal) newres))))))))) + +;;====================================================================== +;; P K T S D B I N T E R F A C E +;; +;; INTEGER, REAL, TEXT +;;====================================================================== +;; +;; spec +;; ( (tablename1 . (field1name L1 TYPE) +;; (field2name L2 TYPE) ... ) +;; (tablename2 ... )) +;; +;; Example: (tests (testname n TEXT) +;; (rundir r TEXT) +;; ... ) +;; +;; artifact keys are taken from the first letter, if that is not unique +;; then look at the next letter and so on +;; + +;; simplify frequent need to get one result with default +;; +(define (get-one db default qry . params) + (apply fold-row + car + default + db + qry + params)) + +(define (get-rows db qry . params) + (apply fold-row + cons + db + qry + params)) + +;; use this struct to hold the artifactspec and the db handle +;; +(defstruct artifactdb + (fname #f) + (artifactsdb-spec #f) + (artifactspec #f) ;; cache the artifactspec + (field-keys #f) ;; cache the field->key mapping (field1 . k1) ... + (key-fields #f) ;; cache the key->field mapping + (conn #f) + ) + +;; WARNING: There is a simplification in the artifactsdb spec w.r.t. artifactspec. +;; The field specs are the cdr of the table list - not a full +;; list. The extra list level in artifactspec is gratuitous and should +;; be removed. +;; +(define (artifactsdb-spec->artifactspec tables-spec) + (map (lambda (tablespec) + (list (car tablespec) + (map (lambda (field-spec) + (cons (car field-spec)(cadr field-spec))) + (cdr tablespec)))) + tables-spec)) + +(define (artifactsdb-open dbfname artifactsdb-spec) + (let* ((pdb (make-artifactdb)) + (dbexists (file-exists? dbfname)) + (db (open-database dbfname))) + (artifactdb-artifactsdb-spec-set! pdb artifactsdb-spec) + (artifactdb-artifactspec-set! pdb (artifactsdb-spec->artifactspec artifactsdb-spec)) + (artifactdb-fname-set! pdb dbfname) + (artifactdb-conn-set! pdb db) + (if (not dbexists) + (artifactsdb-init pdb)) + pdb)) + +(define (artifactsdb-init artifactsdb) + (let* ((db (artifactdb-conn artifactsdb)) + (artifactsdb-spec (artifactdb-artifactsdb-spec artifactsdb))) + ;; create a table for the artifacts themselves + (execute db "CREATE TABLE IF NOT EXISTS artifacts (id INTEGER PRIMARY KEY, zkey TEXT, record_id INTEGER, artifact TEXT);") + (for-each + (lambda (table) + (let* ((table-name (car table)) + (fields (cdr table)) + (stmt (conc "CREATE TABLE IF NOT EXISTS " + table-name + " (id INTEGER PRIMARY KEY," + (string-intersperse + (map (lambda (fieldspec) + (conc (car fieldspec) " " + (caddr fieldspec))) + fields) + ",") + ");"))) + (execute db stmt))) + artifactsdb-spec))) + +;; create artifact from the data and insert into artifacts table +;; +;; data is assoc list of (field . value) ... +;; tablename is a symbol matching the table name +;; +(define (artifactsdb-add-record artifactsdb tablename data #!optional (parent #f)) + (let*-values (((zkey artifact) (alist->artifact data (artifactdb-artifactspec artifactsdb) ptype: tablename))) + ;; have the data as alist so insert it into appropriate table also + (let* ((db (artifactdb-conn artifactsdb))) + ;; TODO: Address collisions + (execute db "INSERT INTO artifacts (zkey,artifact,record_id) VALUES (?,?,?);" + zkey artifact -1) + (let* (;; (artifactid (artifactsdb-artifactkey->artifactid artifactsdb artifactkey)) + (record-id (artifactsdb-insert artifactsdb tablename data))) + (execute db "UPDATE artifacts SET record_id=? WHERE zkey=?;" + record-id zkey) + )))) + +;; +(define (artifactsdb-insert artifactsdb tablename data) + (let* ((db (artifactdb-conn artifactsdb)) + (stmt (conc "INSERT INTO " tablename + " (" (string-intersperse (map conc (map car data)) ",") + ") VALUES ('" + ;; TODO: Add lookup of data type and do not + ;; wrap integers with quotes + (string-intersperse (map conc (map cdr data)) "','") + "');"))) + (print "stmt: " stmt) + (execute db stmt) + ;; lookup the record-id and return it + + )) + +(define (artifactsdb-close artifactsdb) + (finalize! (artifactdb-conn artifactsdb))) + +;; (let loop ((s "0")(n 0))(print s)(if (< n 5000)(loop (increment-string s)(+ n 1)))) + +;;====================================================================== +;; CARDS, MISC and UTIL +;;====================================================================== + +;; given string (likely multi-line) "dat" return shar1 hash +;; +(define (calc-sha1 instr) + (message-digest-string + (sha1-primitive) + instr)) + +;; given a single card return its type and value +;; +(define (card->type/value card) + (let ((ctype (substring card 0 1)) + (cval (substring card 2 (string-length card)))) + (values (string->symbol ctype) cval))) + +;;====================================================================== +;; SDAT procs +;; sdat is legacy/internal usage. Intention is to remove sdat calls from +;; the exposed calls. +;;====================================================================== + +;; sort list of cards +;; +(define-inline (sort-cards sdat) + (sort sdat string<=?)) + +;; artifact rules +;; 1. one card per line +;; 2. at least one card +;; 3. no blank lines + +;; given sdat, a list of cards return uuid, packet (as sdat) +;; +(define (add-z-card sdat) + (let* ((sorted-sdat (sort-cards sdat)) + (dat (string-intersperse sorted-sdat "\n")) + (uuid (calc-sha1 dat))) + (values + uuid + (conc + dat + "\nZ " + uuid)))) + +(define (check-artifact artifact) + (handle-exceptions + exn + #f ;; anything goes wrong - call it a crappy artifact + (let* ((sdat (string-split artifact "\n")) + (rdat (reverse sdat)) ;; reversed + (zdat (car rdat)) + (Z (cadr (string-split zdat))) + (cdat (string-intersperse (reverse (cdr rdat)) "\n"))) + (equal? Z (calc-sha1 cdat))))) + +;;====================================================================== +;; AARTIFACTs +;;====================================================================== + +;; convert a sdat (list of cards) to an alist +;; +(define (sdat->alist sdat) + (let loop ((hed (car sdat)) + (tal (cdr sdat)) + (res '())) + (let-values (( (ctype cval)(card->type/value hed) )) + ;; if this card is not one of the common ones tack it on to rem + (let* ((oldval (alist-ref ctype res)) + (newres (cons (cons ctype + (if oldval ;; list or string + (if (list? oldval) + (cons cval oldval) + (cons cval (list oldval))) + cval)) + res))) + (if (null? tal) + newres + (loop (car tal)(cdr tal) newres)))))) + +;;((aartifact (Z . "7de89c09ac024b3832c93e16cd78d11e2e28733b") <= this is a the alist +;; (t . "v1.63/tip/dev") +;; (c . "QUICKPATT") +;; (T . "runstart") +;; (P . "354eeb67120a921e3e33155ecab1b522ac10b6bd") +;; (D . "1488995096.0")) +;; (id . 8) +;; (group-id . 0) +;; (uuid . "7de89c09ac024b3832c93e16cd78d11e2e28733b") +;; (parent . "") +;; (artifact-type . "runstart") +;; (artifact . "D 1488995096.0\nP 354eeb67120a921e3e33155ecab1b522ac10b6bd\nT runstart\nc QUICKPATT\nt v1.63/tip/dev\nZ 7de89c09ac024b3832c93e16cd78d11e2e28733b")) +;; +;; artifactspec is alist of alists mapping types and nicekeys to keys +;; +;; '((posting . ((title . t) +;; (url . u) +;; (blurb . b))) +;; (comment . ((comment . c) +;; (score . s)))) + +;; DON'T USE? +;; +(define (get-value field dartifact . spec-in) + (if (null? spec-in) + (alist-ref field dartifact) + (let* ((spec (car spec-in)) + (aartifact (alist-ref 'aartifact dartifact))) ;; get the artifact alist + (if (and aartifact spec) + (let* ((ptype (alist-ref 'artifact-type dartifact)) + (pspec (alist-ref (string->symbol ptype) spec))) ;; do we have a spec for this type of artifact + (and pspec + (let* ((key (alist-ref field pspec))) + (and key (alist-ref key aartifact))))) + #f)))) + +;; convert a dartifact to a pure alist given a artifactspec +;; this flattens out the alist to include the data from +;; the queue database record +;; +(define (dartifact->alist dartifact artifactspec) + (let* ((aartifact (alist-ref 'aartifact dartifact)) + (artifact-type (or (alist-ref 'artifact-type dartifact) ;; artifact-type is from the database field artifact_type + (alist-ref 'T aartifact))) + (artifact-fields (alist-ref (string->symbol artifact-type) artifactspec)) + (rev-fields (if artifact-fields + (reverse-aspec artifact-fields) + '()))) + (append (map (lambda (entry) + (let* ((artifact-key (car entry)) + (new-key (or (alist-ref artifact-key rev-fields) artifact-key))) + `(,new-key . ,(cdr entry)))) + aartifact) + dartifact))) + +;; convert a list of dartifacts into a list of alists using artifact-spec +;; +(define (dartifacts->alists dartifacts artifact-spec) + (map (lambda (x) + (dartifact->alist x artifact-spec)) + dartifacts)) + +;; Generic flattener, make the tuple and artifact into a single flat alist +;; +;; qry-result-spec is a list of symbols corresponding to each field +;; +(define (flatten-all inlst artifactspec . qry-result-spec) + (map + (lambda (tuple) + (dartifact->alist + (apply dblst->dartifacts tuple qry-result-spec) + artifactspec)) + inlst)) + +;; call like this: +;; (construct-sdat 'a "a data" 'S "S data" ...) +;; returns list of cards +;; ( "A a value" "D 12345678900" ...) +;; +(define (construct-sdat . alldat) + (let ((have-D-card #f)) ;; flag + (if (even? (length alldat)) + (let loop ((type (car alldat)) + (data (cadr alldat)) + (tail (cddr alldat)) + (res '())) + (if (eq? type 'D)(set! have-D-card #t)) + (if (null? tail) + (if have-D-card ;; return the constructed artifact, add a D card if none found + (add-card res type data) + (add-card + (add-card res 'D (current-seconds)) + type data)) + (loop (car tail) + (cadr tail) + (cddr tail) + (add-card res type data)))) + #f))) ;; #f means it failed to create the sdat + +(define (construct-artifact . alldat) + (add-z-card + (apply construct-sdat alldat))) + +;;====================================================================== +;; CONVERTERS +;;====================================================================== + +(define (artifact->sdat artifact) + (map unescape-data (string-split artifact "\n"))) + +;; given a pure artifact return an alist +;; +(define (artifact->alist artifact #!key (artifactspec #f)) + (let ((sdat (cond + ((string? artifact) (artifact->sdat artifact)) + ((list? artifact) artifact) + (else #f)))) + (if artifact + (if artifactspec + (dartifact->alist (list (cons 'aartifact (sdat->alist sdat))) artifactspec) + (sdat->alist sdat)) + #f))) + +;; convert an alist to an sdat +;; in: '((a . "blah")(b . "foo")) +;; out: '("a blah" "b foo") +;; +(define (alist->sdat adat) + (map (lambda (dat) + (conc (car dat) " " (cdr dat))) + adat)) + +;; adat is the incoming alist, aspec is the mapping +;; from incoming key to the artifact key (usually one +;; letter to keep data tight) see the artifactspec at the +;; top of this file +;; +;; NOTE: alists can contain multiple instances of the same key (supported fine by artifacts) +;; but you (obviously I suppose) cannot use alist-ref to access those entries. +;; +(define (alist->artifact adat aspec #!key (ptype #f)(no-d #f)) + (let* ((artifact-type (or ptype + (alist-ref 'T adat) ;; can provide in the incoming alist + #f)) + (artifact-spec (if artifact-type ;; alist of external-key -> key + (or (alist-ref artifact-type aspec) '()) + (if (null? aspec) + '() + (cdar aspec)))) ;; default to first one if nothing specified + (new-alist (map (lambda (dat) + (let* ((key (car dat)) + (val (cdr dat)) + (newkey (or (alist-ref key artifact-spec) + key))) + (cons newkey (escape-data (conc val))))) ;; convert all incoming data (symbols, numbers etc.) to a string and then escape newlines. + adat)) + (new-with-type (if (alist-ref 'T new-alist) + new-alist + (cons `(T . ,artifact-type) new-alist))) + (with-d-card (if (or no-d ;; no timestamp wanted + (alist-ref 'D new-with-type)) + new-with-type + (cons `(D . ,(current-seconds)) + new-with-type)))) + (add-z-card + (alist->sdat with-d-card)))) + +;;====================================================================== +;; D B Q U E U E I N T E R F A C E +;;====================================================================== + +;; artifacts ( +;; id SERIAL PRIMARY KEY, +;; uuid TEXT NOT NULL, +;; parent_uuid TEXT default '', +;; artifact_type INTEGER DEFAULT 0, +;; group_id INTEGER NOT NULL, +;; artifact TEXT NOT NULL + +;; schema is list of SQL statements - can be used to extend db with more tables +;; +(define (open-queue-db dbpath dbfile #!key (schema '())) + (let* ((dbfname (conc dbpath "/" dbfile)) + (dbexists (if (file-exists? dbfname) #t (begin (create-directory dbpath #t) #f))) + (db (open-database dbfname))) + ;; (set-busy-handler! (dbi:db-conn db) (busy-timeout 10000)) + (if (not dbexists) ;; NOTE: In the archive we allow duplicates and other messiness. + (for-each + (lambda (stmt) + (execute db stmt)) + (cons "CREATE TABLE IF NOT EXISTS artifacts + (id INTEGER PRIMARY KEY, + group_id INTEGER NOT NULL, + uuid TEXT NOT NULL, + parent_uuid TEXT TEXT DEFAULT '', + artifact_type TEXT NOT NULL, + artifact TEXT NOT NULL, + processed INTEGER DEFAULT 0)" + schema))) ;; 0=not processed, 1=processed, 2... for expansion + db)) + +(define (add-to-queue db artifact uuid artifact-type parent-uuid group-id) + (execute db "INSERT INTO artifacts (uuid,parent_uuid,artifact_type,artifact,group_id) + VALUES(?,?,?,?,?);" ;; $1,$2,$3,$4,$5);" + uuid + (if parent-uuid parent-uuid "");; use null string as placeholder for no parent uuid. + (if artifact-type (conc artifact-type) "") + artifact + group-id)) + +;; given all needed parameters create a artifact and store it in the queue +;; procs is an alist that maps artifact-type to a function that takes a list of artifact params +;; in data and returns the uuid and artifact +;; +(define (create-and-queue conn procs artifact-type parent-uuid group-id data) + (let ((proc (alist-ref artifact-type procs))) + (if proc + (let-values (( (uuid artifact) (proc data) )) + (add-to-queue conn artifact uuid artifact-type parent-uuid group-id) + uuid) + #f))) + +;; given uuid get artifact, if group-id is specified use it (reduces probablity of +;; being messed up by a uuid collision) +;; +(define (lookup-by-uuid db artifact-uuid group-id) + (if group-id + (get-one db "SELECT artifact FROM artifacts WHERE group_id=? AND uuid=?;" group-id artifact-uuid) + (get-one db "SELECT artifact FROM artifacts WHERE uuid=?;" artifact-uuid))) + +;; find a packet by its id +;; +(define (lookup-by-id db id) + (get-one db "SELECT artifact FROM artifacts WHERE id=?;" id)) + + +;;====================================================================== +;; P R O C E S S P K T S +;;====================================================================== + +;; given a list of field values pulled from the queue db generate a list +;; of dartifact's +;; +(define (dblst->dartifacts lst . altmap) + (let* ((maplst (if (null? altmap) + '(id group-id uuid parent artifact-type artifact processed) + altmap)) + (res (map cons maplst lst))) ;; produces list of pairs, i.e an alist + (cons `(aartifact . ,(artifact->alist (alist-ref 'artifact res))) + res))) + +;; NB// ptypes is a list of symbols, '() or #f find all types +;; +(define (get-dartifacts db ptypes group-id parent-uuid #!key (uuid #f)) + (let* ((ptype-qry (if (and ptypes + (not (null? ptypes))) + (conc " IN ('" (string-intersperse (map conc ptypes) "','") "')") + (conc " LIKE '%' "))) + (rows (get-rows + db + (conc + "SELECT id,group_id,uuid,parent_uuid,artifact_type,artifact,processed FROM artifacts + WHERE artifact_type " ptype-qry " AND group_id=? + AND processed=0 " + (if parent-uuid (conc "AND parent_uuid='" parent-uuid "' ") "") + (if uuid (conc "AND uuid='" uuid "' ") "") + "ORDER BY id DESC;") + group-id))) + (map dblst->dartifacts (map vector->list rows)))) + +;; get N artifacts not yet processed for group-id +;; +(define (get-not-processed-artifacts db group-id artifact-type limit offset) + (map dblst->dartifacts + (map vector->list + (get-rows + db + "SELECT id,group_id,uuid,parent_uuid,artifact_type,artifact,processed FROM artifacts + WHERE artifact_type = ? AND group_id = ? AND processed=0 + LIMIT ? OFFSET ?;" + (conc artifact-type) ;; convert symbols to string + group-id + limit + offset + )))) + +;; given a uuid, get not processed child artifacts +;; +(define (get-related db group-id uuid) + (map dblst->dartifacts + (get-rows + db + "SELECT id,group_id,uuid,parent_uuid,artifact_type,artifact,processed FROM artifacts + WHERE parent_uuid=? AND group_id=? AND processed=0;" + uuid group-id))) + +;; generic artifact processor +;; +;; find all packets in group-id of type in ptypes and apply proc to artifactdat +;; +(define (process-artifacts conn group-id ptypes parent-uuid proc) + (let* ((artifacts (get-dartifacts conn ptypes group-id parent-uuid))) + (map proc artifacts))) + +;; criteria is an alist ((k . valpatt) ...) +;; - valpatt is a regex +;; - ptypes is a list of types (symbols expected) +;; match-type: 'any or 'all +;; +(define (find-artifacts db ptypes criteria #!key (processed #f)(match-type 'any)(artifact-spec #f)) ;; processed=#f, don't use, else use + (let* ((artifacts (get-dartifacts db ptypes 0 #f)) + (match-rules (lambda (artifactdat) ;; returns a list of matching rules + (filter (lambda (c) + ;; (print "c: " c) + (let* ((ctype (car c)) ;; card type + (rx (cdr c)) ;; card pattern + ;; (t (alist-ref 'artifact-type artifactdat)) + (artifact (alist-ref 'artifact artifactdat)) + (aartifact (artifact->alist artifact)) + (cdat (alist-ref ctype aartifact))) + ;; (print "cdat: " cdat) ;; " aartifact: " aartifact) + (if cdat + (string-match rx cdat) + #f))) + criteria))) + (res (filter (lambda (artifactdat) + (if (null? criteria) ;; looking for all artifacts + #t + (case match-type + ((any)(not (null? (match-rules artifactdat)))) + ((all)(eq? (length (match-rules artifactdat))(length criteria))) + (else + (print "ERROR: bad match type " match-type ", expecting any or all."))))) + artifacts))) + (if artifact-spec + (dartifacts->alists res artifact-spec) + res))) + +;; get descendents of parent-uuid +;; +;; NOTE: Should be doing something like the following: +;; +;; given a uuid, get not processed child artifacts +;; processed: +;; #f => get all +;; 0 => get not processed +;; 1 => get processed +;; +(define (get-ancestors db group-id uuid #!key (processed #f)) + (map dblst->dartifacts + (map vector->list + (get-rows + db + (conc + "SELECT id,group_id,uuid,parent_uuid,artifact_type,artifact,processed + FROM artifacts + WHERE uuid IN + (WITH RECURSIVE + tree(uuid,parent_uuid) + AS + ( + SELECT uuid, parent_uuid + FROM artifacts + WHERE uuid = ? + UNION ALL + SELECT t.uuid, t.parent_uuid + FROM artifacts t + JOIN tree ON t.uuid = tree.parent_uuid + ) + SELECT uuid FROM tree) + AND group_id=?" (if processed (conc " AND processed=" processed) "") ";") + uuid group-id)))) + +;; Untested +;; +(define (get-descendents db group-id uuid #!key (processed #f)) + (map dblst->dartifacts + (map vector->list + (get-rows + db + (conc + "SELECT id,group_id,uuid,parent_uuid,artifact_type,artifact,processed + FROM artifacts + WHERE uuid IN + (WITH RECURSIVE + tree(uuid,parent_uuid) + AS + ( + SELECT uuid, parent_uuid + FROM artifacts + WHERE uuid = ? + UNION ALL + SELECT t.uuid, t.parent_uuid + FROM artifacts t + JOIN tree ON t.parent_uuid = tree.uuid + ) + SELECT uuid FROM tree) + AND group_id=?" (if processed (conc " AND processed=" processed) "") ";") + uuid group-id)))) + +;; look up descendents based on given info unless passed in a list via inlst +;; +;; (define (get-last-descendent db group-id uuid #!key (processed #f)(inlst #f)) +;; (let ((descendents (or inlst (get-descendents db group-id uuid processed: processed)))) +;; (if (null? descendents) +;; #f +;; (last descendents)))) + +;;====================================================================== +;; A R C H I V E S - always to a sqlite3 db +;;====================================================================== + +;; open an archive db +;; path: archive-dir//month.db +;; +#;(define (archive-open-db archive-dir) + (let* ((curr-time (seconds->local-time (current-seconds))) + (dbpath (conc archive-dir "/" (time->string curr-time "%Y"))) + (dbfile (conc dbpath "/" (time->string curr-time "%m") ".db")) + (dbexists (if (file-exists? dbfile) #t (begin (create-directory dbpath #t) #f)))) + (let ((db (open-database dbfile))) + ;; (set-busy-handler! db (busy-timeout 10000)) + (if (not dbexists) ;; NOTE: In the archive we allow duplicates and other messiness. + (execute db "CREATE TABLE IF NOT EXISTS artifacts + (id INTEGER, + group_id INTEGER, + uuid TEXT, + parent_uuid TEXT, + artifact_type TEXT, + artifact TEXT, + processed INTEGER DEFAULT 0)")) + db))) + +;; turn on transactions! otherwise this will be painfully slow +;; +#;(define (write-archive-artifacts src-db db artifact-ids) + (let ((artifacts (get-rows + src-db + (conc "SELECT id,group_id,uuid,parent_uuid,artifact_type,artifact FROM artifacts WHERE id IN (" + (string-intersperse (map conc artifact-ids) ",") ")")))) + ;; (dbi:with-transaction + ;; db + (lambda () + (for-each + (lambda (artifact) + (apply execute db "INSERT INTO artifacts (id,group_id,uuid,parent_uuid,artifact_type,artifact) + VALUES (?,?,?,?,?,?)" + artifact)) + artifacts)))) ;; ) + +;; given a list of uuids and lists of uuids move all to +;; the sqlite3 db for the current archive period +;; +#;(define (archive-artifacts conn artifact-ids archive-dir) + (let ((db (archive-open-db archive-dir))) + (write-archive-artifacts conn db artifact-ids) + (finalize! db)) + ;; (pg:with-transaction + ;; conn + ;; (lambda () + (for-each + (lambda (id) + (get-one + conn + "DELETE FROM artifacts WHERE id=?" id)) + artifact-ids)) ;; )) + +;; given a list of ids mark all as processed +;; +(define (mark-processed conn artifact-ids) + ;; (pg:with-transaction + ;; conn + ;; (lambda () + (for-each + (lambda (id) + (get-one + conn + "UPDATE artifacts SET processed=1 WHERE id=?;" id)) + artifact-ids)) ;; x)) + +;; a generic artifact getter, gets from the artifacts db +;; +(define (get-artifacts conn ptypes) + (let* ((ptypes-str (if (null? ptypes) + "" + (conc " WHERE artifact_type IN ('" (string-intersperse ptypes ",") "') "))) + (qry-str (conc "SELECT id,group_id,uuid,parent_uuid,artifact_type,artifact,processed FROM artifacts" ptypes-str))) + (map vector->list (get-rows conn qry-str)))) + +;; make a report of the artifacts in the db +;; ptypes of '() gets all artifacts +;; display-fields +;; +(define (make-report dest conn artifactspec display-fields . ptypes) + (let* (;; (conn (dbi:db-conn (s:db))) + (all-rows (get-artifacts conn ptypes)) + (all-artifacts (flatten-all + all-rows + artifactspec + 'id 'group-id 'uuid 'parent 'artifact-type 'artifact 'processed)) + (by-uuid (let ((ht (make-hash-table))) + (for-each + (lambda (artifact) + (let ((uuid (alist-ref 'uuid artifact))) + (hash-table-set! ht uuid artifact))) + all-artifacts) + ht)) + (by-parent (let ((ht (make-hash-table))) + (for-each + (lambda (artifact) + (let ((parent (alist-ref 'parent artifact))) + (hash-table-set! ht parent (cons artifact (hash-table-ref/default ht parent '()))))) + all-artifacts) + ht)) + (oup (if dest (open-output-file dest) (current-output-port)))) + + (with-output-to-port + oup + (lambda () + (print "digraph megatest_state_status { + // ranksep=0.05 + rankdir=LR; + node [shape=\"box\"]; +") + ;; first all the names + (for-each + (lambda (artifact) + (let* ((uuid (alist-ref 'uuid artifact)) + (shortuuid (substring uuid 0 4)) + (type (alist-ref 'artifact-type artifact)) + (processed (alist-ref 'processed artifact))) + + (print "\"" uuid "\" [label=\"" shortuuid ", (" + type ", " + (if processed "processed" "not processed") ")") + (for-each + (lambda (key-field) + (let ((val (alist-ref key-field artifact))) + (if val + (print key-field "=" val)))) + display-fields) + (print "\" ];"))) + all-artifacts) + ;; now for parent-child relationships + (for-each + (lambda (artifact) + (let ((uuid (alist-ref 'uuid artifact)) + (parent (alist-ref 'parent artifact))) + (if (not (equal? parent "")) + (print "\"" parent "\" -> \"" uuid"\";")))) + all-artifacts) + + (print "}") + )) + (if dest + (begin + (close-output-port oup) + (system "dot -Tpdf out.dot -o out.pdf"))) + + )) + +;;====================================================================== +;; Read ref artifacts into a vector < laststr hash table > +;;====================================================================== + + + +;;====================================================================== +;; Read/write packets to files (convience functions) +;;====================================================================== + +;; write alist to a artifact file +;; +(define (write-alist->artifact targdir dat #!key (artifactspec '())(ptype #f)) + (let-values (((uuid artifact)(alist->artifact dat artifactspec ptype: ptype))) + (with-output-to-file (conc targdir "/" uuid ".artifact") + (lambda () + (print artifact))) + uuid)) ;; return the uuid + +;; read artifact into alist +;; +(define (read-artifact->alist artifact-file #!key (artifactspec #f)) + (artifact->alist (with-input-from-file + artifact-file + read-string) + artifactspec: artifactspec)) + +;;====================================================================== +;; File utils, stuff useful for file management +;;====================================================================== + +(define (file-get-sha1 fname) + (let* ((sha1-res (run/strings (sha1sum ,fname)))) + (car (string-split (car sha1-res))))) + +(define (link-or-copy srcf destf) + (or (handle-exceptions + exn + #f + (file-link srcf destf)) + (if (file-exists? destf) + (print "NOTE: destination already exists, skipping copy.") + (copy-file srcf destf)))) + +;; (define (files-diff file1 file2) +;; (let* ((diff-res (with-input-from-port +;; (run/port (diff "-q" ,file1 ,file2)) +;; (lambda () +;; (let* ((res (read-line))) +;; (read-lines) +;; res))))) +;; (car (string-split sha1-res)))) +;; + + +(define (check-same file1 file2) + (cond + ((not (and (file-exists? file1)(file-exists? file2))) #f) + ((not (equal? (file-size file1)(file-size file2))) #f) + (else + (let-values (((status run-ok process-id) + (run (diff "-q" ,file1 ,file2)))) + status)))) + +(define *pcache* (make-hash-table)) +(define (get-device dir) + (let ((indat (or (hash-table-ref/default *pcache* dir #f) + (let* ((inp (open-input-pipe (conc "df --output=source \""dir"\""))) + (res (read-lines inp))) + (close-input-port inp) + (hash-table-set! *pcache* dir res) + res)))) + (cadr indat))) + +(define (same-partition? dir1 dir2) + (equal? (get-device dir1)(get-device dir2))) + +(define (link-if-same-partition file1 file2) + (let* ((dir1 (pathname-directory file1)) + (dir2 (pathname-directory file2)) + (f1 (pathname-file file1)) + (f2 (pathname-file file2))) + (if (same-partition? dir1 dir2) + (let* ((tmpname (conc "."f2"-"(current-seconds)))) + ;; this steps needs to be executed as actual user + (move-file file2 (conc dir1 "/" tmpname)) + (file-link file1 file2) + (delete-file (conc dir1 "/" tmpname)))))) + +(define (uuid-first-two-letters sha1sum) + (substring sha1sum 0 2)) + +(define (uuid-remaining-letters sha1sum) + (let ((slen (string-length sha1sum))) + (substring sha1sum 2 slen))) + +(define (archive-dest destd sha1sum) + (let* ((subdir (uuid-first-two-letters sha1sum)) ;; (substring sha1sum 0 2)) + ;; (slen (string-length sha1sum)) + (rem sha1sum #;(uuid-remaining-letters sha1sum)) ;; (substring sha1sum 3 slen)) + (full-dest-dir (conc destd"/"subdir)) + (full-dest-file (conc full-dest-dir"/"rem))) + (if (not (directory-exists? full-dest-dir)) + (create-directory full-dest-dir #t)) + full-dest-file)) + +(define (write-to-archive data destd #!optional (nextnum #f)) + (let* ((sha1sum (calc-sha1 data)) + (full-dest (conc (archive-dest destd sha1sum) + (if nextnum (conc "."nextnum) "")))) + (if (file-exists? full-dest) + (if (equal? (string-intersperse (with-input-from-file full-dest read-lines) "\n") + data) + (begin + ;; (print "INFO: data already exists in "full-dest" and is identical") + sha1sum) + (let ((nextnum (if nextnum (+ nextnum 1) 0))) + (print "WARN: data already exists in "full-dest" but is different! Trying again...") + (write-to-archive data destd nextnum))) + (begin + (with-output-to-file + full-dest + (lambda () + (print data))) + sha1sum)))) ;; BUG? Does print munge data? + +;; copy srcf with sha1sum aabc... to aa/bc... +;; +(define (archive-copy srcf destd sha1sum) + (let* ((full-dest-file (archive-dest destd sha1sum))) + (let loop ((trynum 0)) + (let ((dest-name (if (> trynum 0) + (conc full-dest-file"-"trynum) + full-dest-file))) + (cond + ((not (file-exists? srcf)) #f) ;; this should be an error? + ((and (file-exists? srcf) + (file-exists? dest-name)) + (if (check-same srcf dest-name) + (link-if-same-partition dest-name srcf) + (loop (+ trynum 1)))) ;; collisions are rare, this protects against them + ((not (file-exists? dest-name)) + (link-or-copy srcf dest-name)) + (else #f)))))) + +;; multi-glob +(define (multi-glob globstrs inpath) + ;; (print "multi-glob: "globstrs", "inpath) + (if (equal? inpath "") + globstrs + (let* ((parts (string-split inpath "/" #t)) + (nextpart (car parts)) + (remaining (string-intersperse (cdr parts) "/"))) + (if (and (equal? nextpart "") ;; this must be a leading / meaning root directory + (null? globstrs)) + (multi-glob '("/") remaining) + (begin + ;; (print "nextpart="nextpart", remaining="remaining) + (apply append + (map (lambda (gstr) + (let* ((pathstr (conc gstr"/"nextpart)) + (pathstrs (glob pathstr))) + ;; (print "pathstr="pathstr) + (multi-glob pathstrs remaining))) + globstrs))))))) + + +;; perm[/user:group]: +;; DDD - octal perm (future expansion) +;; - - use umask/defacto perms (i.e. don't actively do anything) +;; x - mark as executable +;; +;; Cards: +;; file: f perm fname +;; directory: d perm fname artifactid +;; link: l perm lname destpath +;; +;; NOTE: cards are kept as (C . "value") +;; +;; given a directory path, ignore list and artifact store (hash-table): +;; 1. create sha1 tree at dest (e.g. aa/b3a7 ...) +;; 2. create artifact for each dir +;; - cards for all files +;; - cards for files that are symlinks or executables +;; 3. return (artifactid . artifact) +;; +;; NOTES: +;; Use destdir of #f to not create sha1 tree +;; Hard links will be used if srcdir and destdir appear to be same partion +;; +;; (alist->artifact adat aspec #!key (ptype #f)) +;; +;; +;; (load "../../artifacts/artifacts.scm")(import big-chicken srfi-69 artifacts)(define dirdat (make-hash-table)) +;; (capture-dir ".." ".." "/tmp/junk" '() dirdat) +;; +;; [procedure] (file-type FILE [LINK [ERROR]]) +;; Returns the file-type for FILE, which should be a filename, a file-descriptor or a port object. If LINK is given and true, symbolic-links are not followed: +;; +;; regular-file +;; directory +;; fifo +;; socket +;; symbolic-link +;; character-device +;; block-device +;; Note that not all types are supported on every platform. If ERROR is given and false, then file-type returns #f if the file does not exist; otherwise, it signals an error. +;; +;; +(define (capture-dir curr-dir src-dir dest-dir ignore-list artifacts all-seen) + (let* ((dir-dat (directory-fold + (lambda (fname res) ;; res is a list of artifact cards + (let* ((fullname (conc curr-dir"/"fname))) + ;; (print "INFO: processing "fullname) + (if (hash-table-ref/default all-seen fullname #f) ;; something circular going on + (begin + (print "WARNING: possible circular link(s) "fullname) + res) + (let* ((ftype (file-type fullname #t #f))) + (hash-table-set! all-seen fullname ftype) + (cons + (case ftype ;; get the card + ((directory) ;; (directory? fullname) + (let* ((new-curr-dir (conc curr-dir"/"fname)) + (new-src-dir (conc src-dir"/"fname))) + (let* ((dir-dat (capture-dir new-curr-dir new-src-dir + dest-dir ignore-list artifacts all-seen)) + (a-id (car dir-dat)) + (artf (cdr dir-dat))) + (hash-table-set! artifacts a-id artf) + (cons 'd (conc "- "a-id" "fname))))) ;; the card + ((symbolic-link) ;; (symbolic-link? fullname) + (let ((ldest (read-symbolic-link fullname))) + (cons 'l (conc "- "fname"/"ldest)))) ;; delimit link name from dest with / + ((regular-file) ;; must be a file + (let* ((start (current-seconds)) + (sha1sum (file-get-sha1 fullname)) + (perms (if (file-executable? fullname) "x" "-"))) + (let ((runtime (- (current-seconds) start))) + (if (> runtime 1) + (print "INFO: file "fullname" took "runtime" seconds to calculate sha1."))) + (if dest-dir + (archive-copy fullname dest-dir sha1sum)) + (cons 'f (conc perms " "sha1sum" "fname)))) + (else + (print "WARNING: file "fullname" of type "ftype" is NOT supported and will converted to empty file.") + (let* ((sha1sum (write-to-archive "" dest-dir))) + (cons 'f (conc "- "sha1sum" "fname))))) + res))))) + '() src-dir #:dotfiles? #t))) ;; => (values srcdir_artifact sub_artifacts_list) + ;; (print "dir-dat: " dir-dat) + (let-values (((a-id artf) + (alist->artifact dir-dat '() ptype: 'd no-d: #t))) + (hash-table-set! artifacts a-id artf) + (cons a-id artf)))) + +;; maybe move this into artifacts? +;; +;; currently moves *.artifact into a bundle and moves the artifacts into attic +;; future: move artifacts under 1 meg in size into bundle up to 10 meg in size +;; +(define (artifact-rollup bundle-dir) ;; cfg storepath) + ;; (let* ((bundle-dir (calc-bundle-dir cfg storepath))) + (let* ((bundles (glob (conc bundle-dir"/*.bundle"))) + (artifacts (glob (conc bundle-dir"/*.artifact")))) + (if (> (length artifacts) 30) ;; rollup only if > 30 artifacts + ;; if we have unbundled artifacts, bundle them + (let* ((ht (read-artifacts-into-hash #f artifacts: artifacts)) + (bundle (hash-of-artifacts->bundle ht))) + (write-bundle bundle bundle-dir) + (create-directory (conc bundle-dir"/attic") #t) + (for-each + (lambda (full-fname) + (let* ((fname (pathname-strip-directory full-fname)) + (newname (conc bundle-dir"/attic/"fname))) + (move-file full-fname newname #t))) + artifacts) + (conc "bundled "(length artifacts))) + "not enough artifacts to bundle"))) + +;; if destfile is a directory then calculate the sha1sum of the bundle and store it +;; by .bundle +;; +;; incoming dat is pure text (bundle already sorted and appended: +;; +(define (write-bundle bdl-data destdir) + (let* ((bdl-uuid (calc-sha1 bdl-data))) + (with-output-to-file + (conc destdir"/"bdl-uuid".bundle") + (lambda () + (print bdl-data))))) + +;; minimal (and hopefully fast) artifact reader +;; TODO: Add check of shar sum. +;; +(define (minimal-artifact-read fname) + (let* ((indat (with-input-from-file fname read-lines))) + (if (null? indat) + (values #f (conc "did not find an artifact in "fname)) + (let* ((zcard (last indat)) + (cardk (substring zcard 0 1)) + (cardv (substring zcard 2 (string-length zcard)))) + (if (equal? cardk "Z") + (values cardv (string-intersperse indat "\n")) + (values #f (conc fname" is not a valid artifact"))))))) + +;; read artifacts from directory into hash +;; NOTE: support for max-count not implemented yet +;; +(define (read-artifacts-into-hash dir #!key (artifacts #f) (max-count #f)(ht #f)) + (let* ((artifacts (or artifacts + (glob (conc dir"/*.artifact")))) + (ht (or ht (make-hash-table)))) + (for-each + (lambda (fname) + (let-values (((uuid afct) + (minimal-artifact-read fname))) + (hash-table-set! ht uuid afct))) + artifacts) + ht)) + +;; ht is: +;; uuid => artifact text +;; use write-bundle to put result into a bundle file +;; +(define (hash-of-artifacts->bundle ht) + (fold (lambda (k res) + (let* ((v (hash-table-ref ht k))) + (if res + (conc res"\n"v) + v))) + #f + (sort (hash-table-keys ht) string<=?))) + +;; minimal artifact to alist +;; +(define (minimal-artifact->alist afact) + (let* ((lines (string-split afact "\n"))) + (map (lambda (a) + (let* ((key (string->symbol (substring a 0 1))) + (sl (string-length a)) + (val (if (> sl 2) + (substring a 2 sl) + ""))) + (cons key val))) + lines))) + +;; some accessors for common cards +(define (afact-get-D afact) + (let ((dval (alist-ref 'D afact))) + (if dval + (string->number dval) + #f))) + +(define (afact-get-T afact) ;; get the artifact type as a symbol + (let ((val (alist-ref 'T afact))) + (if val + (string->symbol val) + val))) + +(define (afact-get-Z afact) + (alist-ref 'Z afact)) + +(define (afact-get afact key default) + (or (alist-ref key afact) + default)) + +(define (afact-get-number/default afact key default) + (let ((val (alist-ref key afact))) + (if val + (or (string->number val) default) ;; seems wrong + default))) + +;; bundles are never big and reading into memory for processing is fine +;; +(define (read-bundle srcfile #!optional (mode 'uuid-raw)) + (let* ((indat (with-input-from-file srcfile read-lines))) + (let loop ((tail indat) + (dat '()) ;; artifact being extracted + (res '())) ;; list of artifacts + (if (null? tail) + (reverse res) ;; last dat should be empty list + (let* ((curr-line (car tail))) + (let-values (((ctype cdata) + (card->type/value curr-line))) + (let* ((is-z-card (eq? 'Z ctype)) + (new-dat (cons (case mode + ((uuid-raw) curr-line) + (else (cons ctype cdata))) + dat))) + (if is-z-card + (loop (cdr tail) ;; done with this artifact + '() + (cons (case mode + ((uuid-raw) (cons cdata (string-intersperse (reverse new-dat) "\n"))) + (else (reverse new-dat))) + res)) + (loop (cdr tail) + new-dat + res))))))))) + + +;; find all .bundle and .artifacts files in bundle-dir +;; and inport them into sqlite handle adb +;; +(define (refresh-artifacts-db adb bundle-dir) + (let* ((bundles (glob (conc bundle-dir"/*.bundle"))) + (artifacts (glob (conc bundle-dir"/*.artifact"))) + (uuids (get-all-uuids adb 'hash))) + (with-transaction + adb + (lambda () + (for-each + (lambda (bundle-file) + ;; (print "Importing artifacts from "bundle-file) + (let* ((bdat (read-bundle bundle-file 'uuid-raw)) + (count 0) + (inc (lambda ()(set! count (+ count 1))))) + (for-each + (lambda (adat) + (match + adat + ((zval . artifact) + (if (not (hash-table-exists? uuids zval)) + (begin + ;; (print "INFO: importing new artifact "zval" from bundle "bundle-file) + (inc) + (execute adb "INSERT INTO artifacts (uuid, artifact) VALUES (?,?);" + zval artifact) + (hash-table-set! uuids zval #t)))) + (else + (print "ERROR: Bad artifact data "adat)))) + bdat) + (print "INFO: imported "count" artifacts from "bundle-file))) + bundles) + (for-each + (lambda (artifact-file) + ;; (print "Importing artifact from "artifact-file) + (let-values (((uuid artifact) (minimal-artifact-read artifact-file))) + (if uuid + (if (not (hash-table-exists? uuids uuid)) + (begin + ;; (print "INFO: importing new artifact "uuid" from "artifact-file) + (execute adb "INSERT INTO artifacts (uuid, artifact) VALUES (?,?);" + uuid artifact) + (hash-table-set! uuids uuid #t))) + (print "Bad artifact in "artifact-file)))) + artifacts))))) + +;;====================================================================== +;; Artifacts db cache +;;====================================================================== + +;; artifacts +;; id SERIAL PRIMARY KEY, +;; uuid TEXT NOT NULL, +;; artifact TEXT NOT NULL +;; +;; parents +;; id INTEGER REFERENCES artids.id, -- +;; parent_id REFERENCES artids.id +;; +;; schema is list of SQL statements - can be used to extend db with more tables +;; +(define (open-artifacts-db dbpath dbfile #!key (schema '())) + (let* ((dbfname (conc dbpath "/" dbfile)) + (dbexists (if (file-exists? dbfname) #t (begin (create-directory dbpath #t) #f))) + (adb (open-database dbfname))) + (set-busy-handler! adb (make-busy-timeout 10000)) + (execute adb "PRAGMA synchronous = 0;") + (if (not dbexists) + (with-transaction + adb + (lambda () + (for-each + (lambda (stmt) + (execute adb stmt)) + (append `("CREATE TABLE IF NOT EXISTS artifacts + (id INTEGER PRIMARY KEY, + uuid TEXT NOT NULL, + artifact TEXT NOT NULL)" + + "CREATE TABLE IF NOT EXISTS parents + (id INTEGER REFERENCES artifacts(id) NOT NULL, + parent_id INTEGER REFERENCES artifacts(id) NOT NULL)") + schema))))) + adb)) + +(define (generate-year-month-name #!optional (seconds #f)) + (let* ((curr-time (seconds->local-time (or seconds (current-seconds))))) + (time->string curr-time "%Y%m"))) + +;; I don't like this function. TODO: remove the +;; mode and option to return ht. Use instead the +;; get-all-artifacts below +;; +(define (get-all-uuids adb #!optional (mode #f)) + (let* ((res (fold-row + (lambda (res uuid) + (cons uuid res)) + '() + adb + "SELECT uuid FROM artifacts;"))) + (case mode + ((hash) + (let* ((ht (make-hash-table))) + (for-each + (lambda (uuid) + (hash-table-set! ht uuid #t)) + res) + ht)) + (else res)))) + +;; returns raw artifacts (i.e. NOT alists but instead plain text) +(define (get-all-artifacts adb) + (let* ((ht (make-hash-table))) + (for-each-row + (lambda (id uuid artifact) + (hash-table-set! ht uuid `(,id ,uuid ,artifact))) + adb + "SELECT id,uuid,artifact FROM artifacts;") + ht)) + +;; given a bundle-dir copy or create to /tmp and open +;; the YYMM.db file and hand the handle to the given proc +;; NOTE: we operate in /tmp/ to accomodate users on NFS +;; where slamming Unix locks at an NFS filer can cause +;; locking fails. Eventually this /tmp behavior will be +;; configurable. +;; +(define (with-todays-adb bundle-dir proc) + (let* ((dbname (conc (generate-year-month-name) ".db")) + (destname (conc bundle-dir"/"dbname)) + (tmparea (conc "/tmp/"(current-user-name)"-"(calc-sha1 bundle-dir))) + (tmpname (conc tmparea"/"dbname)) + (lockfile (conc destname".update-in-progress"))) + ;; (print "with-todays-adb, bundle-dir: "bundle-dir", dbname: "dbname", destname: "destname",\n tmparea: " tmparea", lockfile: "lockfile) + (if (not (file-exists? tmparea))(create-directory tmparea #t)) + (let loop ((count 0)) + (if (file-exists? lockfile) + (if (< count 30) ;; aproximately 30 seconds + (begin + (sleep 1) + (loop (+ 1 count))) + (print "ERROR: "lockfile" exists, proceeding anyway")) + (if (file-exists? destname) + (begin + (copy-file destname tmpname #t) + (copy-file destname lockfile #t))))) + (let* ((adb (open-artifacts-db tmparea dbname)) + (res (proc adb))) + (finalize! adb) + (copy-file tmpname destname #t) + (delete-file* lockfile) + res))) + +) ;; module artifacts + +;; ATTIC + ADDED artifacts/artifacts.setup Index: artifacts/artifacts.setup ================================================================== --- /dev/null +++ artifacts/artifacts.setup @@ -0,0 +1,11 @@ +;; Copyright 2007-2017, 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. + +;;;; pkts.setup +(standard-extension 'pkts "1.0") ADDED artifacts/artifactsrec.scm Index: artifacts/artifactsrec.scm ================================================================== --- /dev/null +++ artifacts/artifactsrec.scm @@ -0,0 +1,196 @@ +(define-syntax define-record-type + (syntax-rules () + ((define-record-type type + (constructor constructor-tag ...) + predicate + (field-tag accessor . more) ...) + (begin + (define type + (make-record-type 'type '(field-tag ...))) + (define constructor + (record-constructor type '(constructor-tag ...))) + (define predicate + (record-predicate type)) + (define-record-field type field-tag accessor . more) + ...)))) + +; An auxilliary macro for define field accessors and modifiers. +; This is needed only because modifiers are optional. + +(define-syntax define-record-field + (syntax-rules () + ((define-record-field type field-tag accessor) + (define accessor (record-accessor type 'field-tag))) + ((define-record-field type field-tag accessor modifier) + (begin + (define accessor (record-accessor type 'field-tag)) + (define modifier (record-modifier type 'field-tag)))))) + +; Record types + +; We define the following procedures: +; +; (make-record-type ) -> +; (record-constructor ) -> +; (record-predicate ) -> +; (record-accessor ) -> +; (record-modifier ) -> +; where +; (

...) -> +; ( ) -> +; ( ) -> +; ( ) -> + +; Record types are implemented using vector-like records. The first +; slot of each record contains the record's type, which is itself a +; record. + +(define (record-type record) + (record-ref record 0)) + +;---------------- +; Record types are themselves records, so we first define the type for +; them. Except for problems with circularities, this could be defined as: +; (define-record-type :record-type +; (make-record-type name field-tags) +; record-type? +; (name record-type-name) +; (field-tags record-type-field-tags)) +; As it is, we need to define everything by hand. + +(define :record-type (make-record 3)) +(record-set! :record-type 0 :record-type) ; Its type is itself. +(record-set! :record-type 1 ':record-type) +(record-set! :record-type 2 '(name field-tags)) + +; Now that :record-type exists we can define a procedure for making more +; record types. + +(define (make-record-type name field-tags) + (let ((new (make-record 3))) + (record-set! new 0 :record-type) + (record-set! new 1 name) + (record-set! new 2 field-tags) + new)) + +; Accessors for record types. + +(define (record-type-name record-type) + (record-ref record-type 1)) + +(define (record-type-field-tags record-type) + (record-ref record-type 2)) + +;---------------- +; A utility for getting the offset of a field within a record. + +(define (field-index type tag) + (let loop ((i 1) (tags (record-type-field-tags type))) + (cond ((null? tags) + (error "record type has no such field" type tag)) + ((eq? tag (car tags)) + i) + (else + (loop (+ i 1) (cdr tags)))))) + +;---------------- +; Now we are ready to define RECORD-CONSTRUCTOR and the rest of the +; procedures used by the macro expansion of DEFINE-RECORD-TYPE. + +(define (record-constructor type tags) + (let ((size (length (record-type-field-tags type))) + (arg-count (length tags)) + (indexes (map (lambda (tag) + (field-index type tag)) + tags))) + (lambda args + (if (= (length args) + arg-count) + (let ((new (make-record (+ size 1)))) + (record-set! new 0 type) + (for-each (lambda (arg i) + (record-set! new i arg)) + args + indexes) + new) + (error "wrong number of arguments to constructor" type args))))) + +(define (record-predicate type) + (lambda (thing) + (and (record? thing) + (eq? (record-type thing) + type)))) + +(define (record-accessor type tag) + (let ((index (field-index type tag))) + (lambda (thing) + (if (and (record? thing) + (eq? (record-type thing) + type)) + (record-ref thing index) + (error "accessor applied to bad value" type tag thing))))) + +(define (record-modifier type tag) + (let ((index (field-index type tag))) + (lambda (thing value) + (if (and (record? thing) + (eq? (record-type thing) + type)) + (record-set! thing index value) + (error "modifier applied to bad value" type tag thing))))) + +Records + +; This implements a record abstraction that is identical to vectors, +; except that they are not vectors (VECTOR? returns false when given a +; record and RECORD? returns false when given a vector). The following +; procedures are provided: +; (record? ) -> +; (make-record ) -> +; (record-ref ) -> +; (record-set! ) -> +; +; These can implemented in R5RS Scheme as vectors with a distinguishing +; value at index zero, providing VECTOR? is redefined to be a procedure +; that returns false if its argument contains the distinguishing record +; value. EVAL is also redefined to use the new value of VECTOR?. + +; Define the marker and redefine VECTOR? and EVAL. + +(define record-marker (list 'record-marker)) + +(define real-vector? vector?) + +(define (vector? x) + (and (real-vector? x) + (or (= 0 (vector-length x)) + (not (eq? (vector-ref x 0) + record-marker))))) + +; This won't work if ENV is the interaction environment and someone has +; redefined LAMBDA there. + +(define eval + (let ((real-eval eval)) + (lambda (exp env) + ((real-eval `(lambda (vector?) ,exp)) + vector?)))) + +; Definitions of the record procedures. + +(define (record? x) + (and (real-vector? x) + (< 0 (vector-length x)) + (eq? (vector-ref x 0) + record-marker))) + +(define (make-record size) + (let ((new (make-vector (+ size 1)))) + (vector-set! new 0 record-marker) + new)) + +(define (record-ref record index) + (vector-ref record (+ index 1))) + +(define (record-set! record index value) + (vector-set! record (+ index 1) value)) ADDED artifacts/tests/run.scm Index: artifacts/tests/run.scm ================================================================== --- /dev/null +++ artifacts/tests/run.scm @@ -0,0 +1,139 @@ +(use test) + +;; (use (prefix pkts pkts:)) +(use pkts (prefix dbi dbi:)) +;; (use trace)(trace sdat->alist pkt->alist) + +(if (file-exists? "queue.db")(delete-file "queue.db")) + +(test-begin "pkts and pkt archives") + +;;====================================================================== +;; Basic pkt creation, parsing and conversion routines +;;====================================================================== + +(test-begin "basic packets") +(test #f '(A "This is a packet") (let-values (((t v) + (card->type/value "A This is a packet"))) + (list t v))) +(test #f "A A\nZ 664449e7299e0065a3e25c138ccef2df13ba291e" + (let-values (((uuid res) + (add-z-card '("A A")))) + res)) +(test #f '("CC C++" "D 1486332719.0" "a A" "b C")(sort (construct-sdat 'b "C" 'a "A" 'CC "C++" 'D 1486332719.0) + string<=?)) +(define pkt-example #f) +(test #f "CC C++\nD 1486332719.0\na A\nb C\nZ 263eb3b6193de7fe65b1ded5bcda513e8b4d6b84" + (let-values (((uuid res) + (construct-pkt 'b "C" 'a "A" 'CC "C++" 'D 1486332719.0))) + (set! pkt-example (cons uuid res)) + res)) +(test-end "basic packets") + +;;====================================================================== +;; Sqlite and postgresql based queue of pkts +;;====================================================================== + +(test-begin "pkt queue") +(define db #f) +(test #f 'sqlite3 (let ((dbh (open-queue-db "." "queue.db"))) + (set! db dbh) + (dbi:db-dbtype dbh))) +(test #f (cdr pkt-example) + (begin + (add-to-queue db (cdr pkt-example)(car pkt-example) 'basic #f 0) + (lookup-by-uuid db (car pkt-example) 0))) +(test #f (cdr pkt-example) + (lookup-by-id db 1)) +(test #f 1 (length (find-pkts db '(basic) '()))) + +(test-end "pkt queue") + + +;;====================================================================== +;; Process groups of pkts +;;====================================================================== + +(test-begin "lists of packets") +(test #f '((apkt . #f) (id . 1) (group-id . 2) (uuid . 3) (parent . 4) (pkt-type . 5)) ;; ((id . 1) (group-id . 2) (uuid . 3) (parent . 4) (pkt-type . 5)) + (dblst->dpkts '(1 2 3 4 5))) +(test #f '(((apkt (Z . "263eb3b6193de7fe65b1ded5bcda513e8b4d6b84") (b . "C") (a . "A") (D . "1486332719.0") (C . " C++")) (id . 1) (group-id . 0) (uuid . "263eb3b6193de7fe65b1ded5bcda513e8b4d6b84") (parent . "") (pkt-type . "basic") (pkt . "CC C++\nD 1486332719.0\na A\nb C\nZ 263eb3b6193de7fe65b1ded5bcda513e8b4d6b84") (processed . 0))) + ;; '(((apkt (Z . "263eb3b6193de7fe65b1ded5bcda513e8b4d6b84") (b . "C") (a . "A") (D . "1486332719.0") (C . " C++")) (id . 1) (group-id . 0) (uuid . "263eb3b6193de7fe65b1ded5bcda513e8b4d6b84") (parent . "") (pkt-type . "basic") (pkt . "CC C++\nD 1486332719.0\na A\nb C\nZ 263eb3b6193de7fe65b1ded5bcda513e8b4d6b84"))) + ;; '(((id . 1) (group-id . 0) (uuid . "263eb3b6193de7fe65b1ded5bcda513e8b4d6b84") (parent . "") (pkt-type . "basic") (pkt . "CC C++\nD 1486332719.0\na A\nb C\nZ 263eb3b6193de7fe65b1ded5bcda513e8b4d6b84"))) + (get-dpkts db '(basic) 0 #f)) +(test #f '(((apkt (Z . "263eb3b6193de7fe65b1ded5bcda513e8b4d6b84") (b . "C") (a . "A") (D . "1486332719.0") (C . " C++")) (id . 1) (group-id . 0) (uuid . "263eb3b6193de7fe65b1ded5bcda513e8b4d6b84") (parent . "") (pkt-type . "basic") (pkt . "CC C++\nD 1486332719.0\na A\nb C\nZ 263eb3b6193de7fe65b1ded5bcda513e8b4d6b84") (processed . 0))) + ;; '(((apkt (Z . "263eb3b6193de7fe65b1ded5bcda513e8b4d6b84") (b . "C") (a . "A") (D . "1486332719.0") (C . " C++")) (id . 1) (group-id . 0) (uuid . "263eb3b6193de7fe65b1ded5bcda513e8b4d6b84") (parent . "") (pkt-type . "basic") (pkt . "CC C++\nD 1486332719.0\na A\nb C\nZ 263eb3b6193de7fe65b1ded5bcda513e8b4d6b84"))) + ;; '(((id . 1) (group-id . 0) (uuid . "263eb3b6193de7fe65b1ded5bcda513e8b4d6b84") (parent . "") (pkt-type . "basic") (pkt . "CC C++\nD 1486332719.0\na A\nb C\nZ 263eb3b6193de7fe65b1ded5bcda513e8b4d6b84"))) + (get-not-processed-pkts db 0 'basic 1000 0)) +(test-end "lists of packets") + +(test-begin "pkts as alists") +(define pktspec '((posting . ((title . t) ;; NOTE: same as ((posting (title . t)(url . u)(blub . b)) ... + (url . u) + (blurb . b))) + (comment . ((comment . c) + (score . s))) + (basic . ((b-field . b) + (a-field . a))))) +(define pktlst (find-pkts db '(basic) '())) +(define dpkt (car pktlst)) +(test #f "A" (get-value 'a-field dpkt pktspec)) + +(test #f "C" (alist-ref 'b-field (dpkt->alist dpkt pktspec))) + +(define basic-spec '((nada (foo . b)(bar . f))(basic (foo . f)(bar . b)))) +(define test-pkt '((foo . "fooval")(bar . "barval"))) +(let*-values (((u p) (alist->pkt test-pkt basic-spec ptype: 'basic)) + ((apkt) (pkt->alist p)) + ((bpkt) (pkt->alist p pktspec: basic-spec))) + (test #f "fooval" (alist-ref 'f apkt)) + (test #f "fooval" (alist-ref 'foo bpkt)) + (test #f #f (alist-ref 'f bpkt))) + +(test-end "pkts as alists") + +(test-begin "descendents and ancestors") + +(define (get-uuid pkt)(alist-ref 'uuid pkt)) + +;; add a child to 263e +(let-values (((uuid pkt) + (construct-pkt 'x "X" 'y "Y" 'P "263eb3b6193de7fe65b1ded5bcda513e8b4d6b84" + 'D "1486332719.0"))) + (add-to-queue db pkt uuid 'basic "263eb3b6193de7fe65b1ded5bcda513e8b4d6b84" 0)) + +(test #f '("263eb3b6193de7fe65b1ded5bcda513e8b4d6b84" "818fe30988c9673441b8f203972a8bda6af682f8") + (map (lambda (x)(alist-ref 'uuid x)) + (get-descendents + db 0 + "263eb3b6193de7fe65b1ded5bcda513e8b4d6b84"))) + +(test #f '("263eb3b6193de7fe65b1ded5bcda513e8b4d6b84" "818fe30988c9673441b8f203972a8bda6af682f8") + (map (lambda (x)(alist-ref 'uuid x)) + (get-ancestors + db 0 + "818fe30988c9673441b8f203972a8bda6af682f8"))) + +(test-end "descendents and ancestors") + +(test-end "pkts and pkt archives") + +(test-begin "pktsdb") + +(define spec '((tests (testname n TEXT) + (testpath p TEXT) + (duration d INTEGER)))) +;; (define pktsdb (make-pktdb)) +;; (pktdb-pktsdb-spec-set! pktsdb spec) + +(define pktsdb #f) + +(test #f #t (dbi:database? (let ((pdb (pktsdb-open "test.db" spec))) + (set! pktsdb pdb) + (pktdb-conn pdb)))) +;; (pp (pktdb-pktspec pktsdb)) +(test #f #t (pktsdb-add-record pktsdb 'tests '((testname . "test1")))) + +(pktsdb-close pktsdb) + +(test-end "pktsdb") ADDED attic/client.scm Index: attic/client.scm ================================================================== --- /dev/null +++ attic/client.scm @@ -0,0 +1,46 @@ + +;; Copyright 2006-2012, Matthew Welland. +;; +;; This file is part of Megatest. +;; +;; Megatest is free software: you can redistribute it and/or modify +;; it under the terms of the GNU General Public License as published by +;; the Free Software Foundation, either version 3 of the License, or +;; (at your option) any later version. +;; +;; Megatest is distributed in the hope that it will be useful, +;; but WITHOUT ANY WARRANTY; without even the implied warranty of +;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +;; GNU General Public License for more details. +;; +;; You should have received a copy of the GNU General Public License +;; along with Megatest. If not, see . + +;;====================================================================== +;; C L I E N T S +;;====================================================================== + +(declare (unit client)) + +(declare (uses common)) +(declare (uses db)) +(declare (uses tasks)) ;; tasks are where stuff is maintained about what is running. +(declare (uses commonmod)) + +(use srfi-18 extras tcp s11n srfi-1 posix regex srfi-69 hostinfo md5 + message-digest matchable spiffy uri-common intarweb http-client + spiffy-request-vars uri-common intarweb directory-utils) + +(import commonmod + debugprint) + +(module client +* + +) + +(import client) + +(include "common_records.scm") +(include "db_records.scm") + ADDED attic/filedb.scm Index: attic/filedb.scm ================================================================== --- /dev/null +++ attic/filedb.scm @@ -0,0 +1,255 @@ +;; Copyright 2006-2011, Matthew Welland. +;; +;; This file is part of Megatest. +;; +;; Megatest is free software: you can redistribute it and/or modify +;; it under the terms of the GNU General Public License as published by +;; the Free Software Foundation, either version 3 of the License, or +;; (at your option) any later version. +;; +;; Megatest is distributed in the hope that it will be useful, +;; but WITHOUT ANY WARRANTY; without even the implied warranty of +;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +;; GNU General Public License for more details. +;; +;; You should have received a copy of the GNU General Public License +;; along with Megatest. If not, see . +;; + +;; (require-extension synch sqlite3 posix srfi-13 srfi-1 utils regex) +(use sqlite3 srfi-1 posix regex srfi-69 srfi-13 posix-extras) +(import (prefix sqlite3 sqlite3:)) + +(declare (unit filedb)) + +(include "fdb_records.scm") +;; (include "settings.scm") + +(define (filedb:open-db dbpath) + (let* ((fdb (make-filedb:fdb)) + (dbexists (common:file-exists? dbpath)) + (db (sqlite3:open-database dbpath))) + (filedb:fdb-set-db! fdb db) + (filedb:fdb-set-dbpath! fdb dbpath) + (filedb:fdb-set-pathcache! fdb (make-hash-table)) + (filedb:fdb-set-idcache! fdb (make-hash-table)) + (filedb:fdb-set-partcache! fdb (make-hash-table)) + (sqlite3:set-busy-handler! db (make-busy-timeout 136000)) + (if (not dbexists) + (begin + (sqlite3:execute db "PRAGMA synchronous = OFF;") + (sqlite3:execute db "CREATE TABLE names (id INTEGER PRIMARY KEY,name TEST);") ;; for future use - change path in paths table to path_id + (sqlite3:execute db "CREATE INDEX name_index ON names (name);") + ;; NB// We store a useful subset of file attributes but do not attempt to store all + (sqlite3:execute db "CREATE TABLE paths (id INTEGER PRIMARY KEY, + path TEXT, + parent_id INTEGER, + mode INTEGER DEFAULT -1, + uid INTEGER DEFAULT -1, + gid INTEGER DEFAULT -1, + size INTEGER DEFAULT -1, + mtime INTEGER DEFAULT -1);") + (sqlite3:execute db "CREATE INDEX path_index ON paths (path,parent_id);") + (sqlite3:execute db "CREATE TABLE bases (id INTEGER PRIMARY KEY,base TEXT, updated TIMESTAMP);"))) + ;; close the sqlite3 db and open it as needed + (filedb:finalize-db! fdb) + (filedb:fdb-set-db! fdb #f) + fdb)) + +(define (filedb:reopen-db fdb) + (let ((db (sqlite3:open-database (filedb:fdb-get-dbpath fdb)))) + (filedb:fdb-set-db! fdb db) + (sqlite3:set-busy-handler! db (make-busy-timeout 136000)))) + +(define (filedb:finalize-db! fdb) + (sqlite3:finalize! (filedb:fdb-get-db fdb))) + +(define (filedb:get-current-time-string) + (string-chomp (time->string (seconds->local-time (current-seconds))))) + +(define (filedb:get-base-id db path) + (let ((stmt (sqlite3:prepare db "SELECT id FROM bases WHERE base=?;")) + (id-num #f)) + (sqlite3:for-each-row + (lambda (num) (set! id-num num)) stmt path) + (sqlite3:finalize! stmt) + id-num)) + +(define (filedb:get-path-id db path parent) + (let ((stmt (sqlite3:prepare db "SELECT id FROM paths WHERE path=? AND parent_id=?;")) + (id-num #f)) + (sqlite3:for-each-row + (lambda (num) (set! id-num num)) stmt path parent) + (sqlite3:finalize! stmt) + id-num)) + +(define (filedb:add-base db path) + (let ((existing (filedb:get-base-id db path))) + (if existing #f + (begin + (sqlite3:execute db "INSERT INTO bases (base,updated) VALUES (?,?);" path (filedb:get-current-time-string)))))) + +;; index value field notes +;; 0 inode number st_ino +;; 1 mode st_mode bitfield combining file permissions and file type +;; 2 number of hard links st_nlink +;; 3 UID of owner st_uid as with file-owner +;; 4 GID of owner st_gid +;; 5 size st_size as with file-size +;; 6 access time st_atime as with file-access-time +;; 7 change time st_ctime as with file-change-time +;; 8 modification time st_mtime as with file-modification-time +;; 9 parent device ID st_dev ID of device on which this file resides +;; 10 device ID st_rdev device ID for special files (i.e. the raw major/minor number) +;; 11 block size st_blksize +;; 12 number of blocks allocated st_blocks + +(define (filedb:add-path-stat db path parent statinfo) + (let ((stmt (sqlite3:prepare db "INSERT INTO paths (path,parent_id,mode,uid,gid,size,mtime) VALUES (?,?,?,?,?,?,?);"))) + (sqlite3:execute stmt + path + parent + (vector-ref statinfo 1) ;; mode + (vector-ref statinfo 3) ;; uid + (vector-ref statinfo 4) ;; gid + (vector-ref statinfo 5) ;; size + (vector-ref statinfo 8) ;; mtime + ) + (sqlite3:finalize! stmt))) ;; (filedb:get-current-time-string)))) + +(define (filedb:add-path db path parent) + (let ((stmt (sqlite3:prepare db "INSERT INTO paths (path,parent_id) VALUES (?,?);"))) + (sqlite3:execute stmt path parent) + (sqlite3:finalize! stmt))) + +(define (filedb:register-path fdb path #!key (save-stat #f)) + (let* ((db (filedb:fdb-get-db fdb)) + (pathcache (filedb:fdb-get-pathcache fdb)) + (stat (if save-stat (file-stat path #t))) + (id (hash-table-ref/default pathcache path #f))) + (if (not db)(filedb:reopen-db fdb)) + (if id id + (let ((plist (string-split path "/"))) + (let loop ((head (car plist)) + (tail (cdr plist)) + (parent 0)) + (let ((id (filedb:get-path-id db head parent)) + (done (null? tail))) + (if id ;; we'll have a id if the path is already registered + (if done + (begin + (hash-table-set! pathcache path id) + id) ;; return the last path id for a result + (loop (car tail)(cdr tail) id)) + (begin ;; add the path and then repeat the loop with the same data + (if save-stat + (filedb:add-path-stat db head parent stat) + (filedb:add-path db head parent)) + (loop head tail parent))))))))) + +(define (filedb:update-recursively fdb path #!key (save-stat #f)) + (let ((p (open-input-pipe (string-append "find -L " path)))) ;; (resolve-pathname path)))) ;; (string-append "find " path)))) + (print "processed 0 files...") + (let loop ((l (read-line p)) + (lc 0)) ;; line count + (if (eof-object? l) + (begin + (print " " lc " files") + (close-input-port p)) + (begin + (filedb:register-path fdb l save-stat: save-stat) ;; (get-real-path l)) ;; don't like losing the original path info + (if (= (modulo lc 100) 0) + (print " " lc " files")) + (loop (read-line p)(+ lc 1))))))) + +(define (filedb:update fdb path #!key (save-stat #f)) + ;; first get the realpath and add it to the bases table + (let ((real-path path) ;; (filedb:get-real-path path)) + (db (filedb:fdb-get-db fdb))) + (filedb:add-base db real-path) + (filedb:update-recursively fdb path save-stat: save-stat))) + +;; not used and broken +;; +(define (filedb:get-real-path path) + (let* ((p (open-input-pipe (string-append real-path " " (regexp-escape path)))) + (pth (read-line p))) + (if (eof-object? pth) path + (begin + (close-input-port p) + pth)))) + +(define (filedb:drop-base fdb path) + (print "Sorry, I don't do anything yet")) + +(define (filedb:find-all fdb pattern action) + (let* ((db (filedb:fdb-get-db fdb)) + (stmt (sqlite3:prepare db "SELECT id FROM paths WHERE path like ?;")) + (result '())) + (sqlite3:for-each-row + (lambda (num) + (action num) + (set! result (cons num result))) stmt pattern) + (sqlite3:finalize! stmt) + result)) + +(define (filedb:get-path-record fdb id) + (let* ((db (filedb:fdb-get-db fdb)) + (partcache (filedb:fdb-get-partcache fdb)) + (dat (hash-table-ref/default partcache id #f))) + (if dat dat + (let ((stmt (sqlite3:prepare db "SELECT path,parent_id FROM paths WHERE id=?;")) + (result #f)) + (sqlite3:for-each-row + (lambda (path parent_id)(set! result (list path parent_id))) stmt id) + (hash-table-set! partcache id result) + (sqlite3:finalize! stmt) + result)))) + +(define (filedb:get-children fdb parent-id) + (let* ((db (filedb:fdb-get-db fdb)) + (res '())) + (sqlite3:for-each-row + (lambda (id path parent-id) + (set! res (cons (vector id path parent-id) res))) + db "SELECT id,path,parent_id FROM paths WHERE parent_id=?;" + parent-id) + res)) + +;; retrieve all that have children and those without +;; children that match patt +(define (filedb:get-children-patt fdb parent-id search-patt) + (let* ((db (filedb:fdb-get-db fdb)) + (res '())) + ;; first get the children that have no children + (sqlite3:for-each-row + (lambda (id path parent-id) + (set! res (cons (vector id path parent-id) res))) + db "SELECT id,path,parent_id FROM paths WHERE parent_id=? AND + (id IN (SELECT parent_id FROM paths) OR path LIKE ?);" + parent-id search-patt) + res)) + +(define (filedb:get-path fdb id) + (let* ((db (filedb:fdb-get-db fdb)) + (idcache (filedb:fdb-get-idcache fdb)) + (path (hash-table-ref/default idcache id #f))) + (if (not db)(filedb:reopen-db fdb)) + (if path path + (let loop ((curr-id id) + (path "")) + (let ((path-record (filedb:get-path-record fdb curr-id))) + (if (not path-record) #f ;; this id has no path + (let* ((parent-id (list-ref path-record 1)) + (pname (list-ref path-record 0)) + (newpath (string-append "/" pname path))) + (if (= parent-id 0) ;; fields 0=path, 1=parent. root parent=0 + (begin + (hash-table-set! idcache id newpath) + newpath) + (loop parent-id newpath))))))))) + +(define (filedb:search db pattern) + (let ((action (lambda (id)(print (filedb:get-path db id))))) + (filedb:find-all db pattern action))) + ADDED attic/ftail.scm Index: attic/ftail.scm ================================================================== --- /dev/null +++ attic/ftail.scm @@ -0,0 +1,108 @@ +;;====================================================================== +;; Copyright 2017, Matthew Welland. +;; +;; This file is part of Megatest. +;; +;; Megatest is free software: you can redistribute it and/or modify +;; it under the terms of the GNU General Public License as published by +;; the Free Software Foundation, either version 3 of the License, or +;; (at your option) any later version. +;; +;; Megatest is distributed in the hope that it will be useful, +;; but WITHOUT ANY WARRANTY; without even the implied warranty of +;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +;; GNU General Public License for more details. +;; +;; You should have received a copy of the GNU General Public License +;; along with Megatest. If not, see . + +;;====================================================================== + +(declare (unit ftail)) + +(module ftail + ( + open-tail-db + tail-write + tail-get-fid + file-tail + ) + +(import scheme chicken data-structures extras) +(use (prefix sqlite3 sqlite3:) posix typed-records) + +(define (open-tail-db ) + (let* ((basedir (create-directory (conc "/tmp/" (current-user-name)))) + (dbpath (conc basedir "/megatest_logs.db")) + (dbexists (file-exists? dbpath)) + (db (sqlite3:open-database dbpath)) + (handler (sqlite3:make-busy-timeout 136000))) + (sqlite3:set-busy-handler! db handler) + (sqlite3:execute db "PRAGMA synchronous = 0;") + (if (not dbexists) + (begin + (sqlite3:execute db "CREATE TABLE IF NOT EXISTS log_files (id INTEGER PRIMARY KEY,filename TEXT,event_time TIMESTAMP DEFAULT (strftime('%s','now')));") + (sqlite3:execute db "CREATE TABLE IF NOT EXISTS log_data (id INTEGER PRIMARY KEY,fid INTEGER,line TEXT,event_time TIMESTAMP DEFAULT (strftime('%s','now')));") + )) + db)) + +(define (tail-write db fid lines) + (sqlite3:with-transaction + db + (lambda () + (for-each + (lambda (line) + (sqlite3:execute db "INSERT INTO log_data (fid,line) VALUES (?,?);" fid line)) + lines)))) + +(define (tail-get-fid db fname) + (let ((fid (handle-exceptions + exn + #f + (sqlite3:first-result db "SELECT id FROM log_files WHERE filename=?;" fname)))) + (if fid + fid + (begin + (sqlite3:execute db "INSERT INTO log_files (filename) VALUES (?);" fname) + (tail-get-fid db fname))))) + +(define (file-tail fname #!key (db-in #f)) + (let* ((inp (open-input-file fname)) + (db (or db-in (open-tail-db))) + (fid (tail-get-fid db fname))) + (let loop ((inl (read-line inp)) + (lines '()) + (lastwr (current-seconds))) + (if (eof-object? inl) + (let ((timed-out (> (- (current-seconds) lastwr) 60))) + (if timed-out (tail-write db fid (reverse lines))) + (sleep 1) + (if timed-out + (loop (read-line inp) '() (current-seconds)) + (loop (read-line inp) lines lastwr))) + (let* ((savelines (> (length lines) 19))) + ;; (print inl) + (if savelines (tail-write db fid (reverse lines))) + (loop (read-line inp) + (if savelines + '() + (cons inl lines)) + (if savelines + (current-seconds) + lastwr))))))) + +;; offset -20 means get last 20 lines +;; +(define (tail-get-lines db fid offset count) + (if (> offset 0) + (sqlite3:map-row (lambda (id line) + (vector id line)) + db + "SELECT id,line FROM log_data WHERE fid=? OFFSET ? LIMIT ?;" fid offset count) + (reverse ;; get N from the end + (sqlite3:map-row (lambda (id line) + (vector id line)) + db + "SELECT id,line FROM log_data WHERE fid=? ORDER BY id DESC LIMIT ?;" fid (abs offset))))) + +) ADDED attic/http-transport.scm Index: attic/http-transport.scm ================================================================== --- /dev/null +++ attic/http-transport.scm @@ -0,0 +1,708 @@ + +;; Copyright 2006-2012, Matthew Welland. +;; +;; This file is part of Megatest. +;; +;; Megatest is free software: you can redistribute it and/or modify +;; it under the terms of the GNU General Public License as published by +;; the Free Software Foundation, either version 3 of the License, or +;; (at your option) any later version. +;; +;; Megatest is distributed in the hope that it will be useful, +;; but WITHOUT ANY WARRANTY; without even the implied warranty of +;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +;; GNU General Public License for more details. +;; +;; You should have received a copy of the GNU General Public License +;; along with Megatest. If not, see . + +(declare (unit http-transport)) + +(declare (uses common)) +(declare (uses debugprint)) +(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)) +(declare (uses rmt)) +(declare (uses dbfile)) +(declare (uses commonmod)) +(declare (uses mtargs)) + +(module http-transport +* + + +(import srfi-1 posix regex regex-case srfi-69 hostinfo md5 + message-digest posix-extras spiffy uri-common intarweb http-client + spiffy-request-vars intarweb spiffy-directory-listing + (srfi 18) extras tcp s11n) + +(import scheme + chicken + + (prefix mtargs args:) + debugprint) + +;; Configurations for server +(tcp-buffer-size 2048) +(max-connections 2048) + +(include "common_records.scm") +(include "db_records.scm") +(include "js-path.scm") + +(import dbfile commonmod) + +(require-library stml) +(define (http-transport:make-server-url hostport) + (if (not hostport) + #f + (conc "http://" (car hostport) ":" (cadr hostport)))) + +(define *server-loop-heart-beat* (current-seconds)) + +;;====================================================================== +;; S E R V E R +;; ====================================================================== + +;; Call this to start the actual server +;; + +(define *db:process-queue-mutex* (make-mutex)) + +(define (http-transport:run hostn) + ;; Configurations for server + (tcp-buffer-size 2048) + (max-connections 2048) + (debug:print 2 *default-log-port* "Attempting to start the server ...") + (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 (portlogger:open-run-close portlogger:find-port)) + (link-tree-path (common:get-linktree)) + (tmp-area (common:get-db-tmp-area)) + (start-file (conc tmp-area "/.server-start"))) + (debug:print-info 0 *default-log-port* "portlogger recommended port: " start-port) + ;; set some parameters for the server + (root-path (if link-tree-path + link-tree-path + (current-directory))) ;; WARNING: SECURITY HOLE. FIX ASAP! + (handle-directory spiffy-directory-listing) + (handle-exception (lambda (exn chain) + (signal (make-composite-condition + (make-property-condition + 'server + 'message "server error"))))) + + ;; http-transport:handle-directory) ;; simple-directory-handler) + ;; Setup the web server and a /ctrl interface + ;; + (vhost-map `(((* any) . ,(lambda (continue) + ;; open the db on the first call + ;; This is were we set up the database connections + (let* (($ (request-vars source: 'both)) + (dat ($ 'dat)) + (res #f)) + (cond + ((equal? (uri-path (request-uri (current-request))) + '(/ "api")) + (send-response body: (api:process-request *dbstruct-dbs* $) ;; the $ is the request vars proc + headers: '((content-type text/plain))) + (mutex-lock! *heartbeat-mutex*) + (set! *db-last-access* (current-seconds)) + (mutex-unlock! *heartbeat-mutex*)) + ((equal? (uri-path (request-uri (current-request))) + '(/ "")) + (send-response body: (http-transport:main-page))) + ((equal? (uri-path (request-uri (current-request))) + '(/ "json_api")) + (send-response body: (http-transport:main-page))) + ((equal? (uri-path (request-uri (current-request))) + '(/ "runs")) + (send-response body: (http-transport:main-page))) + ((equal? (uri-path (request-uri (current-request))) + '(/ any)) + (send-response body: "hey there!\n" + headers: '((content-type text/plain)))) + ((equal? (uri-path (request-uri (current-request))) + '(/ "hey")) + (send-response body: "hey there!\n" + headers: '((content-type text/plain)))) + ((equal? (uri-path (request-uri (current-request))) + '(/ "jquery3.1.0.js")) + (send-response body: (http-transport:show-jquery) + headers: '((content-type application/javascript)))) + ((equal? (uri-path (request-uri (current-request))) + '(/ "test_log")) + (send-response body: (http-transport:html-test-log $) + headers: '((content-type text/HTML)))) + ((equal? (uri-path (request-uri (current-request))) + '(/ "dashboard")) + (send-response body: (http-transport:html-dboard $) + headers: '((content-type text/HTML)))) + (else (continue)))))))) + (handle-exceptions + exn + (debug:print 0 *default-log-port* "Failed to create file " start-file ", exn=" exn) + (with-output-to-file start-file (lambda ()(print (current-process-id))))) + (http-transport:try-start-server ipaddrstr start-port))) + +;; This is recursively run by http-transport:run until sucessful +;; +(define (http-transport:try-start-server ipaddrstr portnum) + (let ((config-hostname (configf:lookup *configdat* "server" "hostname")) + (config-use-proxy (equal? (configf:lookup *configdat* "client" "use-http_proxy") "yes"))) + (if (not config-use-proxy) + (determine-proxy (constantly #f))) + (debug:print-info 0 *default-log-port* "http-transport:try-start-server time=" (seconds->time-string (current-seconds)) " ipaddrsstr=" ipaddrstr " portnum=" portnum " config-hostname=" config-hostname) + (handle-exceptions + exn + (begin + ;; (print-error-message exn) + (if (< portnum 64000) + (begin + (debug:print 0 *default-log-port* "WARNING: attempt to start server failed. Trying again ...") + (debug:print 0 *default-log-port* " message: " ((condition-property-accessor 'exn 'message) exn)) + (debug:print 5 *default-log-port* "exn=" (condition->list exn)) + (portlogger:open-run-close portlogger:set-failed portnum) + (debug:print 0 *default-log-port* "WARNING: failed to start on portnum: " portnum ", trying next port") + (thread-sleep! 0.1) + + ;; get_next_port goes here + (http-transport:try-start-server ipaddrstr + (portlogger:open-run-close portlogger:find-port))) + (begin + (debug:print 0 *default-log-port* "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)) + (debug:print 0 *default-log-port* "INFO: Trying to start server on " ipaddrstr ":" portnum) + ;; This starts the spiffy server + ;; NEED WAY TO SET IP TO #f TO BIND ALL + ;; (start-server bind-address: ipaddrstr port: portnum) + (if config-hostname ;; this is a hint to bind directly + (start-server port: portnum) ;; bind-address: (if (equal? config-hostname "-") + ;; ipaddrstr + ;; config-hostname)) + (start-server port: portnum)) + (portlogger:open-run-close portlogger:set-port portnum "released") + (debug:print 1 *default-log-port* "INFO: server has been stopped")))) + +;;====================================================================== +;; S E R V E R U T I L I T I E S +;;====================================================================== + +;;====================================================================== +;; 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)) + +(define (http-transport:get-time-to-cleanup) + (let ((res #f)) + (mutex-lock! *http-mutex*) + (set! res (> (current-seconds) *http-connections-next-cleanup*)) + (mutex-unlock! *http-mutex*) + res)) + +(define (http-transport:inc-requests-count) + (mutex-lock! *http-mutex*) + (set! *http-requests-in-progress* (+ 1 *http-requests-in-progress*)) + ;; Use this opportunity to slow things down iff there are too many requests in flight + (if (> *http-requests-in-progress* 5) + (begin + (debug:print-info 0 *default-log-port* "Whoa there buddy, ease up...") + (thread-sleep! 1))) + (mutex-unlock! *http-mutex*)) + +(define (http-transport:dec-requests-count proc) + (mutex-lock! *http-mutex*) + (proc) + (set! *http-requests-in-progress* (- *http-requests-in-progress* 1)) + (mutex-unlock! *http-mutex*)) + +(define (http-transport:dec-requests-count-and-close-all-connections) + (set! *http-requests-in-progress* (- *http-requests-in-progress* 1)) + (let loop ((etime (+ (current-seconds) 5))) ;; give up in five seconds + (if (> *http-requests-in-progress* 0) + (if (> etime (current-seconds)) + (begin + (thread-sleep! 0.05) + (loop etime)) + (debug:print-error 0 *default-log-port* "requests still in progress after 5 seconds of waiting. I'm going to pass on cleaning up http connections")) + (close-all-connections!))) + (set! *http-connections-next-cleanup* (+ (current-seconds) 10)) + (mutex-unlock! *http-mutex*)) + +(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*))) + +;; Send "cmd" with json payload "params" to serverdat and receive result +;; +(define (http-transport:client-api-send-receive run-id runremote cmd params #!key (numretries 3)) + (assert (remote? runremote) "FATAL: http-transport:client-api-send-receive called with serverdat="serverdat) + (let* ((fullurl (remote-api-req runremote)) + (res (vector #f "uninitialized")) + (success #t) + (sparams (db:obj->string params transport: 'http)) + (server-id (remote-server-id runremote))) + (debug:print-info 11 *default-log-port* "cmd=" cmd " fullurl=" fullurl " server-id=" server-id " current time:" (current-seconds)) + + ;; 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 (vector ;;; DON'T FORGET - THIS IS THE CLIENT SIDE! NOTE: consider moving this to client.scm since we are only supporting http transport at this time. + success + (db:string->obj + (handle-exceptions + exn + (let ((call-chain (get-call-chain)) + (msg ((condition-property-accessor 'exn 'message) exn))) + (set! success #f) + (if (debug:debug-mode 1) + (debug:print-info 0 *default-log-port* "couldn't talk to server, trying again ...") + (begin + (debug:print 0 *default-log-port* "WARNING: failure in with-input-from-request to " fullurl ".") + (debug:print 0 *default-log-port* " message: " msg ", exn=" exn) + (debug:print 0 *default-log-port* " cmd: " cmd " params: " params " key:" (or server-id "thekey")) + (debug:print 0 *default-log-port* " call-chain: " call-chain))) + ;; what if another thread is communicating ok? Can't happen due to mutex + (http-transport:close-connections runremote) + (mutex-unlock! *http-mutex*) + ;; (close-connection! fullurl) + (db:obj->string #f)) + (with-input-from-request ;; was dat + fullurl + (list (cons 'key (or server-id "thekey")) + (cons 'cmd cmd) + (cons 'params sparams)) + read-string)) + transport: 'http) + 0)) ;; added this speculatively + ;; Shouldn't this be a call to the managed call-all-connections stuff above? + ;; (close-all-connections!) ;; BUG? WHY IS THIS HERE? Are we failing to reuse connections? + (mutex-unlock! *http-mutex*) + )) + (time-out (lambda () + (thread-sleep! 45) + (debug:print 0 *default-log-port* "WARNING: send-receive took more than 45 seconds!!") + #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) + (vector-set! res 0 success) + (thread-terminate! th2) + (if (vector? res) + (if (vector-ref res 0) ;; this is the first flag or the second flag? + (let* ((res-dat (vector-ref res 1))) + (if (and (string? res-dat) (string-contains res-dat "server-id mismatch")) + (signal (make-composite-condition + (make-property-condition + 'servermismatch + 'message (vector-ref res 1)))) + res)) ;; this is the *inner* vector? seriously? why? + (if (debug:debug-mode 11) + (let ((call-chain (get-call-chain))) ;; note: this code also called in nmsg-transport - consider consolidating it + (print-call-chain (current-error-port)) + (debug:print-error 11 *default-log-port* "error above occured at server, res=" res) ;; " message: " ((condition-property-accessor 'exn 'message) exn)) + (debug:print 11 *default-log-port* " server call chain:") + (pp (vector-ref res 1) (current-error-port)) + (signal (vector-ref res 0))) + res)) + (signal (make-composite-condition + (make-property-condition + 'timeout + 'message "nmsg-transport:client-api-send-receive-raw timed out talking to server"))))))) + +;; careful closing of connections stored in *runremote* +;; +(define (http-transport:close-connections runremote) + (if (remote? runremote) + (let ((api-dat (remote-api-uri runremote))) + (handle-exceptions + exn + (begin + (print-call-chain *default-log-port*) + (debug:print-error 0 *default-log-port* " closing connection failed with error: " ((condition-property-accessor 'exn 'message) exn) ", exn=" exn)) + (if (args:any-defined? "-server" "-execute" "-run") + (debug:print-info 0 *default-log-port* "Closing connections to "api-dat)) + (if api-dat (close-connection! api-dat)) + + ;; Would it be better to set *runremote* to #f? I don't think so. But we may + ;; need to clear more of the runremote fields + (remote-api-url-set! runremote #f) ;; used as a flag for connection up and running + + #t)) + #f)) + +;; 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) + ;; if none running or if > 20 seconds since + ;; server last used then start shutdown + ;; This thread waits for the server to come alive + (debug:print-info 0 *default-log-port* "Starting the sync-back, keep alive thread in server") + (let* ((servinfofile #f) + (sdat #f) + (no-sync-db (db:open-no-sync-db)) + (tmp-area (common:get-db-tmp-area)) + (started-file (conc tmp-area "/.server-started")) + (server-start-time (current-seconds)) + (server-info (let loop ((start-time (current-seconds)) + (changed #t) + (last-sdat "not this")) + (begin ;; let ((sdat #f)) + (thread-sleep! 0.01) + (debug:print-info 0 *default-log-port* "Waiting for server alive signature") + (mutex-lock! *heartbeat-mutex*) + (set! sdat *server-info*) + (mutex-unlock! *heartbeat-mutex*) + (if (and sdat + (not changed) + (> (- (current-seconds) start-time) 2)) + (let* ((servinfodir (server:get-servinfo-dir *toppath*)) ;; (conc *toppath*"/.servinfo")) + (ipaddr (car sdat)) + (port (cadr sdat)) + (servinf (conc servinfodir"/"ipaddr":"port))) + (set! servinfofile servinf) + (if (not (file-exists? servinfodir)) + (create-directory servinfodir #t)) + (with-output-to-file servinf + (lambda () + (let* ((serv-id (server:mk-signature))) + (set! *server-id* serv-id) + (print "SERVER STARTED: "ipaddr":"port" AT "(current-seconds)" server-id: "serv-id" pid: "(current-process-id)) + (print "started: "(seconds->year-week/day-time (current-seconds)))))) + (set! *on-exit-procs* (cons + (lambda () + (delete-file* servinf)) + *on-exit-procs*)) + ;; put data about this server into a simple flat file host.port + (debug:print-info 0 *default-log-port* "Received server alive signature") + sdat) + (begin + (debug:print-info 0 *default-log-port* "Still waiting, last-sdat=" last-sdat) + (sleep 4) + (if (> (- (current-seconds) start-time) 120) ;; been waiting for two minutes + (if sdat + (let* ((ipaddr (car sdat)) + (port (cadr sdat)) + (servinf (conc (server:get-servinfo-dir *toppath*)"/"ipaddr":"port))) + (debug:print-error 0 *default-log-port* "transport appears to have died, exiting server") + (exit)) + (exit) + ) + (loop start-time + (equal? sdat last-sdat) + sdat))))))) + (iface (car server-info)) + (port (cadr server-info)) + (last-access 0) + (server-timeout (server:expiration-timeout)) + (server-going #f) + (server-log-file (args:get-arg "-log"))) ;; always set when we are a server + + (handle-exceptions + exn + (debug:print 0 *default-log-port* "Failed to create " started-file ", exn=" exn) + (with-output-to-file started-file (lambda ()(print (current-process-id))))) + + (let loop ((count 0) + (server-state 'available) + (bad-sync-count 0) + (start-time (current-milliseconds))) + + ;; Use this opportunity to sync the tmp db to megatest.db + (if (not server-going) ;; *dbstruct-dbs* + (begin + (debug:print 0 *default-log-port* "SERVER: dbprep") + (set! *dbstruct-dbs* (db:setup #t)) ;; run-id)) FIXME!!! + (set! server-going #t) + (debug:print 0 *default-log-port* "SERVER: running, megatest version: " (common:get-full-version))) ;; NOTE: the server is NOT yet marked as running in the log. We do that in the keep-running routine. + (if (and no-sync-db + (common:low-noise-print 10 "sync-all")) ;; cheesy way to reduce frequency of running sync :) + (begin + (if (common:low-noise-print 120 "sync-all-print") + (debug:print 0 *default-log-port* "keep-running calling db:all-db-sync at " (time->string (seconds->local-time) "%H:%M:%S"))) + (db:all-db-sync *dbstruct-dbs*) + ))) + + ;; when things go wrong we don't want to be doing the various queries too often + ;; so we strive to run this stuff only every four seconds or so. + (let* ((sync-time (- (current-milliseconds) start-time)) + (rem-time (quotient (- 4000 sync-time) 1000))) + (if (and (<= rem-time 4) + (> rem-time 0)) + (thread-sleep! rem-time))) + + (if (< count 1) ;; 3x3 = 9 secs aprox + (loop (+ count 1) 'running bad-sync-count (current-milliseconds))) + + ;; Check that iface and port have not changed (can happen if server port collides) + (mutex-lock! *heartbeat-mutex*) + (set! sdat *server-info*) + (mutex-unlock! *heartbeat-mutex*) + + (if (not (equal? sdat (list iface port))) + (let ((new-iface (car sdat)) + (new-port (cadr sdat))) + (debug:print-info 0 *default-log-port* "WARNING: interface changed, refreshing iface and port info") + (set! iface new-iface) + (set! port new-port) + (if (not *server-id*) + (set! *server-id* (server:mk-signature))) + (debug:print 0 *default-log-port* "SERVER STARTED: " iface ":" port " AT " (current-seconds) " server-id: " *server-id*) + (flush-output *default-log-port*))) + + ;; Transfer *db-last-access* to last-access to use in checking that we are still alive + (mutex-lock! *heartbeat-mutex*) + (set! last-access *db-last-access*) + (mutex-unlock! *heartbeat-mutex*) + + (if (common:low-noise-print 120 (conc "server running on " iface ":" port)) + (begin + (if (not *server-id*) + (set! *server-id* (server:mk-signature))) + (debug:print 0 *default-log-port* (current-seconds) (current-directory) (current-process-id) (argv)) + (debug:print 0 *default-log-port* "SERVER STARTED: " iface ":" port " AT " (current-seconds) " server-id: " *server-id*) + (flush-output *default-log-port*))) + (if (common:low-noise-print 60 "dbstats") + (begin + (debug:print 0 *default-log-port* "Server stats:") + (db:print-current-query-stats))) + (let* ((hrs-since-start (/ (- (current-seconds) server-start-time) 3600))) + (cond + ((and *server-run* + (> (+ last-access server-timeout) + (current-seconds))) + (if (common:low-noise-print 120 "server continuing") + (debug:print-info 0 *default-log-port* "Server continuing, seconds since last db access: " (- (current-seconds) last-access)) + (let ((curr-time (current-seconds))) + (handle-exceptions + exn + (debug:print 0 *default-log-port* "ERROR: Failed to change timestamp on info file " servinfofile ". Are you out of space on that disk? exn=" exn) + (if (and ;; (< (- (current-seconds) server-start-time) 600) ;; run for ten minutes for experiment, 3600 thereafter + (not *server-overloaded*) + (file-exists? servinfofile)) + (change-file-times servinfofile curr-time curr-time))) + (if (and (common:low-noise-print 120 "start new server") + (> *api-process-request-count* 50)) ;; if this server is kind of busy start up another + (begin + (debug:print-info 0 *default-log-port* "Server is busy, api-count "*api-process-request-count*", start another if possible...") + (server:kind-run *toppath*) + (if (> *api-process-request-count* 100) + (begin + (debug:print-info 0 *default-log-port* "Server is overloaded at api-count=" *api-process-request-count*", removing "servinfofile) + (delete-file* servinfofile))))))) + (loop 0 server-state bad-sync-count (current-milliseconds))) + (else + (debug:print-info 0 *default-log-port* "Server timed out. seconds since last db access: " (- (current-seconds) last-access)) + (http-transport:server-shutdown port))))))) + +(define (http-transport:server-shutdown port) + (begin + ;;(BB> "http-transport:server-shutdown called") + (debug:print-info 0 *default-log-port* "Starting to shutdown the server. pid="(current-process-id)) + ;; + ;; start_shutdown + ;; + (set! *time-to-exit* #t) ;; tell on-exit to be fast as we've already cleaned up + (portlogger:open-run-close portlogger:set-port port "released") + (thread-sleep! 1) + + ;; (debug:print-info 0 *default-log-port* "Max cached queries was " *max-cache-size*) + ;; (debug:print-info 0 *default-log-port* "Number of cached writes " *number-of-writes*) + ;; (debug:print-info 0 *default-log-port* "Average cached write time " + ;; (if (eq? *number-of-writes* 0) + ;; "n/a (no writes)" + ;; (/ *writes-total-delay* + ;; *number-of-writes*)) + ;; " ms") + ;; (debug:print-info 0 *default-log-port* "Number non-cached queries " *number-non-write-queries*) + ;; (debug:print-info 0 *default-log-port* "Average non-cached time " + ;; (if (eq? *number-non-write-queries* 0) + ;; "n/a (no queries)" + ;; (/ *total-non-write-delay* + ;; *number-non-write-queries*)) + ;; " ms") + + (db:print-current-query-stats) + #;(common:save-pkt `((action . exit) + (T . server) + (pid . ,(current-process-id))) + *configdat* #t) + + ;; remove .servinfo file(s) here + + (debug:print-info 0 *default-log-port* "Server shutdown complete. Exiting") + (exit))) + +;; all routes though here end in exit ... +;; +;; start_server? +;; +(define (http-transport:launch) + ;; check the .servinfo directory, are there other servers running on this + ;; or another host? + (let* ((server-start-is-ok (server:minimal-check *toppath*))) + (if (not server-start-is-ok) + (begin + (debug:print 0 *default-log-port* "ERROR: server start not ok, exiting now.") + (exit 1)))) + + ;; check that a server start is in progress, pause or exit if so + (let* ((th2 (make-thread (lambda () + (debug:print-info 0 *default-log-port* "Server run thread started") + (http-transport:run + (if (args:get-arg "-server") + (args:get-arg "-server") + "-") + )) "Server run")) + (th3 (make-thread (lambda () + (debug:print-info 0 *default-log-port* "Server monitor thread started") + (http-transport:keep-running) + "Keep running")))) + (thread-start! th2) + (thread-sleep! 0.25) ;; give the server time to settle before starting the keep-running monitor. + (thread-start! th3) + (set! *didsomething* #t) + (thread-join! th2) + (exit))) + +;; (define (http-transport:server-signal-handler signum) +;; (signal-mask! signum) +;; (handle-exceptions +;; exn +;; (debug:print 0 *default-log-port* " ... exiting ...") +;; (let ((th1 (make-thread (lambda () +;; (thread-sleep! 1)) +;; "eat response")) +;; (th2 (make-thread (lambda () +;; (debug:print-error 0 *default-log-port* "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 *default-log-port* " Done.") +;; (exit 4)) +;; "exit on ^C timer"))) +;; (thread-start! th2) +;; (thread-start! th1) +;; (thread-join! th2)))) + +;;=============================================== +;; Java script +;;=============================================== +(define (http-transport:show-jquery) + (let* ((data (tests:readlines *java-script-lib*))) +(string-join data "\n"))) + + + +;;====================================================================== +;; web pages +;;====================================================================== + +(define (http-transport:html-test-log $) + (let* ((run-id ($ 'runid)) + (test-item ($ 'testname)) + (parts (string-split test-item ":")) + (test-name (car parts)) + + (item-name (if (equal? (length parts) 1) + "" + (cadr parts)))) + ;(print $) +(tests:get-test-log run-id test-name item-name))) + + +(define (http-transport:html-dboard $) + (let* ((page ($ 'page)) + (oup (open-output-string)) + (bdy "--------------------------") + + (ret (tests:dynamic-dboard page))) + (s:output-new oup ret) + (close-output-port oup) + + (set! bdy (get-output-string oup)) + (conc "

Dashboard

" bdy "

" ))) + +(define (http-transport:main-page) + (let ((linkpath (root-path))) + (conc "

" (pathname-strip-directory toppath) "

" + "" + "Run area: " *toppath* + "

Server Stats

" + (http-transport:stats-table) + "

" + (http-transport:runs linkpath) + "

" + ;; (http-transport:run-stats) + "" + ))) + +(define (http-transport:stats-table) + (mutex-lock! *heartbeat-mutex*) + (let ((res + (conc "" + ;; "" + "" + "" + "" + ;; "" + "" + "

Max cached queries	" max-cache-size "
Number of cached writes	" number-of-writes "
Average cached write time	" (if (eq? number-of-writes 0) + "n/a (no writes)" + (/ writes-total-delay + number-of-writes)) + " ms
Number non-cached queries	" number-non-write-queries "
Average non-cached time	" (if (eq? number-non-write-queries 0) + ;; "n/a (no queries)" + ;; (/ total-non-write-delay + ;; number-non-write-queries)) + " ms
Last access	" (seconds->time-string db-last-access) "

"))) + (mutex-unlock! *heartbeat-mutex*) + res)) + +(define (http-transport:runs linkpath) + (conc "

Runs

" + (string-intersperse + (let ((files (map pathname-strip-directory (glob (conc linkpath "/*"))))) + (map (lambda (p) + (conc "" p "
")) + files)) + " "))) + +#;(define (http-transport:run-stats) + (let ((stats (open-run-close db:get-running-stats #f))) + (conc "" + (string-intersperse + (map (lambda (stat) + (conc "")) + stats) + " ") + "

" (car stat) "

" (cadr stat) "

"))) +) ADDED attic/index-tree.scm Index: attic/index-tree.scm ================================================================== --- /dev/null +++ attic/index-tree.scm @@ -0,0 +1,61 @@ +;;====================================================================== +;; Copyright 2006-2013, Matthew Welland. +;; +;; This file is part of Megatest. +;; +;; Megatest is free software: you can redistribute it and/or modify +;; it under the terms of the GNU General Public License as published by +;; the Free Software Foundation, either version 3 of the License, or +;; (at your option) any later version. +;; +;; Megatest is distributed in the hope that it will be useful, +;; but WITHOUT ANY WARRANTY; without even the implied warranty of +;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +;; GNU General Public License for more details. +;; +;; You should have received a copy of the GNU General Public License +;; along with Megatest. If not, see . +;; +;;====================================================================== + +;;====================================================================== +;; Tests +;;====================================================================== + +(use sqlite3 srfi-1 posix regex regex-case srfi-69 dot-locking tcp directory-utils) +(import (prefix sqlite3 sqlite3:)) + +(declare (unit tests)) +(declare (uses lock-queue)) +(declare (uses db)) +(declare (uses common)) +(declare (uses items)) +(declare (uses runconfig)) +(declare (uses commonmod)) +(import commonmod) + +(include "common_records.scm") +(include "key_records.scm") +(include "db_records.scm") +(include "run_records.scm") +(include "test_records.scm") + +;; Populate the links tree with index.html files +;; +;; - start from most recent tests and work towards oldest -OR- +;; start from deepest hierarchy and work way up +;; - look up tests in megatest.db +;; - cross-reference the tests to stats.db +;; - if newer than event_time in stats.db or not registered in stats.db regenerate +;; - run du and store in stats.db +;; - when all tests at that level done generate next level up index.html +;; +;; include in rollup html index.html: +;; sum of du +;; counts of PASS, FAIL, RUNNING, REMOTEHOSTSTART, LAUNCHED, CHECK etc. +;; overall status +;; +;; include in test specific index.html: +;; host, uname, cpu graph, disk avail graph, steps, data +;; meta data, state, status, du +;; ADDED attic/lock-queue.scm Index: attic/lock-queue.scm ================================================================== --- /dev/null +++ attic/lock-queue.scm @@ -0,0 +1,258 @@ +;; Copyright 2006-2013, Matthew Welland. +;; +;; This file is part of Megatest. +;; +;; Megatest is free software: you can redistribute it and/or modify +;; it under the terms of the GNU General Public License as published by +;; the Free Software Foundation, either version 3 of the License, or +;; (at your option) any later version. +;; +;; Megatest is distributed in the hope that it will be useful, +;; but WITHOUT ANY WARRANTY; without even the implied warranty of +;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +;; GNU General Public License for more details. +;; +;; You should have received a copy of the GNU General Public License +;; along with Megatest. If not, see . +;; + +(use (prefix sqlite3 sqlite3:) srfi-18) + +(declare (unit lock-queue)) +(declare (uses common)) +(declare (uses debugprint)) +(declare (uses tasks)) +(declare (uses commonmod)) + +(import commonmod + debugprint) + +;;====================================================================== +;; attempt to prevent overlapping updates of rollup files by queueing +;; update requests in an sqlite db +;;====================================================================== + +;;====================================================================== +;; db record, +;;====================================================================== + +(define (make-lock-queue:db-dat)(make-vector 3)) +(define-inline (lock-queue:db-dat-get-db vec) (vector-ref vec 0)) +(define-inline (lock-queue:db-dat-get-path vec) (vector-ref vec 1)) +(define-inline (lock-queue:db-dat-set-db! vec val)(vector-set! vec 0 val)) +(define-inline (lock-queue:db-dat-set-path! vec val)(vector-set! vec 1 val)) + +(define (lock-queue:delete-lock-db dbdat) + (let ((fname (lock-queue:db-dat-get-path dbdat))) + (system (conc "rm -f " fname "*")))) + +(define (lock-queue:open-db fname #!key (count 10)) + (let* ((actualfname (conc fname ".lockdb")) + (dbexists (common:file-exists? actualfname)) + (db (sqlite3:open-database actualfname)) + (handler (make-busy-timeout 136000))) + (if dbexists + (vector db actualfname) + (begin + (handle-exceptions + exn + (begin + (thread-sleep! 10) + (if (> count 0) + (lock-queue:open-db fname count: (- count 1)) + (vector db actualfname))) + (sqlite3:with-transaction + db + (lambda () + (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 ( + id INTEGER PRIMARY KEY, + test_id INTEGER, + run_lock TEXT, + CONSTRAINT runlock_constraint UNIQUE (run_lock));")))))) + (sqlite3:set-busy-handler! db handler) + (vector db actualfname))) + +(define (lock-queue:set-state dbdat test-id newstate #!key (remtries 10)) + (tasks:wait-on-journal (lock-queue:db-dat-get-path dbdat) 1200) + (handle-exceptions + exn + (if (> remtries 0) + (begin + (debug:print 0 *default-log-port* "WARNING: exception on lock-queue:set-state. Trying again in 30 seconds.") + (debug:print 0 *default-log-port* " message: " ((condition-property-accessor 'exn 'message) exn)) + (thread-sleep! 30) + (lock-queue:set-state dbdat test-id newstate remtries: (- remtries 1))) + (begin + (debug:print-error 0 *default-log-port* " Failed to set lock state for test with id " test-id ", error: " ((condition-property-accessor 'exn 'message) exn) ", giving up.") + #f)) + (sqlite3:execute (lock-queue:db-dat-get-db dbdat) "UPDATE queue SET state=? WHERE test_id=?;" + newstate + test-id))) + +(define (lock-queue:any-younger? dbdat mystart test-id #!key (remtries 10)) + ;; no need to wait on journal on read only queries + ;; (tasks:wait-on-journal (lock-queue:db-dat-get-path dbdat) 1200) + (handle-exceptions + exn + (if (> remtries 0) + (begin + (debug:print 0 *default-log-port* "WARNING: exception on lock-queue:any-younger. Removing lockdb and trying again in 5 seconds.") + (debug:print 0 *default-log-port* " message: " ((condition-property-accessor 'exn 'message) exn)) + (thread-sleep! 5) + (lock-queue:delete-lock-db dbdat) + (lock-queue:any-younger? dbdat mystart test-id remtries: (- remtries 1))) + (begin + (debug:print-error 0 *default-log-port* " 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))) + (lock-queue:db-dat-get-db dbdat) + "SELECT test_id FROM queue WHERE start_time > ?;" mystart) + res))) + +(define (lock-queue:get-lock dbdat test-id #!key (count 10)(waiting-msg #f)) + (tasks:wait-on-journal (lock-queue:db-dat-get-path dbdat) 1200 remove: #t waiting-msg: "lock-queue:get-lock, waiting on journal") + (let* ((res #f) + (db (lock-queue:db-dat-get-db dbdat)) + (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 + (begin + (debug:print 0 *default-log-port* "WARNING: failed to get queue lock. Removing lock db and returning fail") ;; Will try again in a few seconds") + (debug:print 0 *default-log-port* " message: " ((condition-property-accessor 'exn 'message) exn)) + (thread-sleep! 10) + ;; (if (> count 0) + ;; #f ;; (lock-queue:get-lock dbdat test-id count: (- count 1)) - give up on retries + ;; (begin ;; never recovered, remote the lock file and return #f, no lock obtained + (lock-queue:delete-lock-db dbdat) + #f) + (sqlite3:with-transaction + db + (lambda () + (sqlite3:for-each-row (lambda (tid lockstate) + (set! res (list tid lockstate))) + lckqry) + (if res + (if (equal? (car res) test-id) + #t ;; already have the lock + #f) + (begin + (sqlite3:execute mklckqry test-id) + ;; if no error handled then return #t for got the lock + #t))))))) + (sqlite3:finalize! lckqry) + (sqlite3:finalize! mklckqry) + result))) + +(define (lock-queue:release-lock fname test-id #!key (count 10)) + (let* ((dbdat (lock-queue:open-db fname))) + (tasks:wait-on-journal (lock-queue:db-dat-get-path dbdat) 1200 "lock-queue:release-lock; waiting on journal") + (handle-exceptions + exn + (begin + (debug:print 0 *default-log-port* "WARNING: Failed to release queue lock. Will try again in few seconds") + (debug:print 0 *default-log-port* " message: " ((condition-property-accessor 'exn 'message) exn)) + (thread-sleep! (/ count 10)) + (if (> count 0) + (begin + (sqlite3:finalize! (lock-queue:db-dat-get-db dbdat)) + (lock-queue:release-lock fname test-id count: (- count 1))) + (let ((journal (conc fname "-journal"))) + ;; If we've tried ten times and failed there is a serious problem + ;; try to remove the lock db and allow it to be recreated + (handle-exceptions + exn + #f + (if (common:file-exists? journal)(delete-file journal)) + (if (common:file-exists? fname) (delete-file fname)) + #f)))) + (sqlite3:execute (lock-queue:db-dat-get-db dbdat) "DELETE FROM runlocks WHERE test_id=?;" test-id) + (sqlite3:finalize! (lock-queue:db-dat-get-db dbdat))))) + +(define (lock-queue:steal-lock dbdat test-id #!key (count 10)) + (debug:print-info 0 *default-log-port* "Attempting to steal lock at " (lock-queue:db-dat-get-path dbdat)) + (tasks:wait-on-journal (lock-queue:db-dat-get-path dbdat) 1200 "lock-queue:steal-lock; waiting on journal") + (handle-exceptions + exn + (begin + (debug:print 0 *default-log-port* "WARNING: Failed to steal queue lock. Will try again in few seconds") + (debug:print 0 *default-log-port* " message: " ((condition-property-accessor 'exn 'message) exn)) + (thread-sleep! 10) + (if (> count 0) + (lock-queue:steal-lock dbdat test-id count: (- count 1)) + #f)) + (sqlite3:execute (lock-queue:db-dat-get-db dbdat) "DELETE FROM runlocks WHERE run_lock='locked';")) + (lock-queue:get-lock dbdat 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 #!key (count 10)(waiting-msg #f)) + (let* ((dbdat (lock-queue:open-db fname)) + (mystart (current-seconds)) + (db (lock-queue:db-dat-get-db dbdat))) + ;; (tasks:wait-on-journal (lock-queue:db-dat-get-path dbdat) 1200 waiting-msg: "lock-queue:wait-turn; waiting on journal file") + (handle-exceptions + exn + (begin + (debug:print 0 *default-log-port* "WARNING: Failed to find out if it is ok to skip the wait queue. Will try again in few seconds") + (debug:print 0 *default-log-port* " message: " ((condition-property-accessor 'exn 'message) exn)) + (print-call-chain (current-error-port)) + (thread-sleep! 10) + (if (> count 0) + (begin + (sqlite3:finalize! db) + (lock-queue:wait-turn fname test-id count: (- count 1))) + (begin + (debug:print 0 *default-log-port* "Giving up calls to lock-queue:wait-turn for test-id " test-id " at path " fname ", printing call chain") + (print-call-chain (current-error-port)) + #f))) + ;; wait 10 seconds and then check to see if someone is already updating the html + (thread-sleep! 10) + (if (not (lock-queue:any-younger? dbdat mystart test-id)) ;; no processing in flight, must try to start processing + (begin + (tasks:wait-on-journal (lock-queue:db-dat-get-path dbdat) 1200 waiting-msg: "lock-queue:wait-turn; waiting on journal file") + (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? dbdat mystart test-id))) + (if younger-waiting + (begin + ;; no need for us to wait. mark in the lock queue db as skipping + ;; no point in marking anything in the queue - simply never register this + ;; test as it is *covered* by a previously started update to the html file + ;; (lock-queue:set-state dbdat test-id "skipping") + #f) ;; let the calling process know that nothing needs to be done + (if (lock-queue:get-lock dbdat test-id) + #t + (if (> (- (current-seconds) mystart) 36000) ;; waited too long, steal the lock + (lock-queue:steal-lock dbdat test-id) + (begin + (thread-sleep! 1) + (loop (lock-queue:any-younger? dbdat 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) ADDED attic/margs.scm Index: attic/margs.scm ================================================================== --- /dev/null +++ attic/margs.scm @@ -0,0 +1,103 @@ +;; Copyright 2007-2010, Matthew Welland. +;; +;; This file is part of Megatest. +;; +;; Megatest is free software: you can redistribute it and/or modify +;; it under the terms of the GNU General Public License as published by +;; the Free Software Foundation, either version 3 of the License, or +;; (at your option) any later version. +;; +;; Megatest is distributed in the hope that it will be useful, +;; but WITHOUT ANY WARRANTY; without even the implied warranty of +;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +;; GNU General Public License for more details. +;; +;; You should have received a copy of the GNU General Public License +;; along with Megatest. If not, see . + + +(declare (unit margs)) +;; (declare (uses common)) + +(define args:arg-hash (make-hash-table)) + +(define (args:get-arg arg . default) + (if (null? default) + (hash-table-ref/default args:arg-hash arg #f) + (hash-table-ref/default args:arg-hash arg (car default)))) + +;; get an arg as a number +(define (args:get-arg-number arg . default) + (let* ((val-str (args:get-arg arg)) + (val (if val-str (string->number val-str) #f))) + (if val + val + (if (null? default) + #f + default)))) + +(define (args:get-arg-from ht arg . default) + (if (null? default) + (hash-table-ref/default ht arg #f) + (hash-table-ref/default ht arg (car default)))) + + +(define (args:remove-arg-from-ht arg) + (hash-table-delete! args:arg-hash arg) +) + +(define (args:usage . args) + (if (> (length args) 0) + (apply print "ERROR: " args)) + (if (string? help) + (print help) + (print "Usage: " (car (argv)) " ... ")) + (exit 0)) + +(define (args:any-defined? . args) + (not (null? (filter (lambda (x) x) + (map args:get-arg args))))) + +;; ;; one-of args defined +;; (define (args:any-defined? . param) +;; (let ((res #f)) +;; (for-each +;; (lambda (arg) +;; (if (args:get-arg arg)(set! res #t))) +;; param) +;; res)) + +;; args: +(define (args:get-args args params switches arg-hash num-needed) + (let* ((numargs (length args)) + (adj-num-needed (if num-needed (+ num-needed 2) #f))) + (if (< numargs (if adj-num-needed adj-num-needed 2)) + (if (>= num-needed 1) + (args:usage "No arguments provided") + '()) + (let loop ((arg (cadr args)) + (tail (cddr args)) + (remargs '())) + (cond + ((member arg params) ;; args with params + (if (< (length tail) 1) + (args:usage "param given without argument " arg) + (let ((val (car tail)) + (newtail (cdr tail))) + (hash-table-set! arg-hash arg val) + (if (null? newtail) remargs + (loop (car newtail)(cdr newtail) remargs))))) + ((member arg switches) ;; args with no params (i.e. switches) + (hash-table-set! arg-hash arg #t) + (if (null? tail) remargs + (loop (car tail)(cdr tail) remargs))) + (else + (if (null? tail)(append remargs (list arg)) ;; return the non-used args + (loop (car tail)(cdr tail)(append remargs (list arg)))))))) + )) + +(define (args:print-args remargs arg-hash) + (print "ARGS: " remargs) + (for-each (lambda (arg) + (print " " arg " " (hash-table-ref/default arg-hash arg #f))) + (hash-table-keys arg-hash))) ADDED attic/mlaunch.scm Index: attic/mlaunch.scm ================================================================== --- /dev/null +++ attic/mlaunch.scm @@ -0,0 +1,35 @@ +;; Copyright 2006-2014, Matthew Welland. +;; +;; This file is part of Megatest. +;; +;; Megatest is free software: you can redistribute it and/or modify +;; it under the terms of the GNU General Public License as published by +;; the Free Software Foundation, either version 3 of the License, or +;; (at your option) any later version. +;; +;; Megatest is distributed in the hope that it will be useful, +;; but WITHOUT ANY WARRANTY; without even the implied warranty of +;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +;; GNU General Public License for more details. +;; +;; You should have received a copy of the GNU General Public License +;; along with Megatest. If not, see . + +;; strftime('%m/%d/%Y %H:%M:%S','now','localtime') + +;;====================================================================== +;; MLAUNCH +;; +;; take jobs from the given queue and keep launching them keeping +;; the cpu load at the targeted level +;; +;;====================================================================== + +(use sqlite3 srfi-1 posix regex regex-case srfi-69 format) + +(declare (unit mlaunch)) +(declare (uses db)) +(declare (uses common)) +(declare (uses commonmod)) +(import commonmod) + ADDED attic/portlogger-example.scm Index: attic/portlogger-example.scm ================================================================== --- /dev/null +++ attic/portlogger-example.scm @@ -0,0 +1,21 @@ +;; Copyright 2006-2017, Matthew Welland. +;; +;; This file is part of Megatest. +;; +;; Megatest is free software: you can redistribute it and/or modify +;; it under the terms of the GNU General Public License as published by +;; the Free Software Foundation, either version 3 of the License, or +;; (at your option) any later version. +;; +;; Megatest is distributed in the hope that it will be useful, +;; but WITHOUT ANY WARRANTY; without even the implied warranty of +;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +;; GNU General Public License for more details. +;; +;; You should have received a copy of the GNU General Public License +;; along with Megatest. If not, see . + + +(declare (uses portlogger)) + +(print (apply portlogger:main (cdr (argv)))) ADDED attic/records-vs-vectors-vs-coops.scm Index: attic/records-vs-vectors-vs-coops.scm ================================================================== --- /dev/null +++ attic/records-vs-vectors-vs-coops.scm @@ -0,0 +1,110 @@ +;; Copyright 2006-2017, Matthew Welland. +;; +;; This file is part of Megatest. +;; +;; Megatest is free software: you can redistribute it and/or modify +;; it under the terms of the GNU General Public License as published by +;; the Free Software Foundation, either version 3 of the License, or +;; (at your option) any later version. +;; +;; Megatest is distributed in the hope that it will be useful, +;; but WITHOUT ANY WARRANTY; without even the implied warranty of +;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +;; GNU General Public License for more details. +;; +;; You should have received a copy of the GNU General Public License +;; along with Megatest. If not, see . + +;; (include "vg.scm") + +;; (declare (uses vg)) + +(use foof-loop defstruct coops) + +(defstruct obj type fill-color angle) + +(define (make-vg:obj)(make-vector 3)) +(define-inline (vg:obj-get-type vec) (vector-ref vec 0)) +(define-inline (vg:obj-get-fill-color vec) (vector-ref vec 1)) +(define-inline (vg:obj-get-angle vec) (vector-ref vec 2)) +(define-inline (vg:obj-set-type! vec val)(vector-set! vec 0 val)) +(define-inline (vg:obj-set-fill-color! vec val)(vector-set! vec 1 val)) +(define-inline (vg:obj-set-angle! vec val)(vector-set! vec 2 val)) + +(use simple-exceptions) +(define vgs:obj-exn (make-exception "wrong record type, expected vgs:obj." 'assert)) +(define (make-vgs:obj)(let ((v (make-vector 4)))(vector-set! v 0 'vgs:obj) v)) +(define-inline (vgs:obj-type vec)(if (eq? (vector-ref vec 0) 'vgs:obj)(vector-ref vec 1)(raise (vgs:obj-exn 'vgs:obj-type 'xpr)))) +(define-inline (vgs:obj-fill-color vec)(if (eq? (vector-ref vec 0) 'vgs:obj)(vector-ref vec 2)(raise (vgs:obj-exn 'vgs:obj-fill-color 'xpr)))) +(define-inline (vgs:obj-angle vec)(if (eq? (vector-ref vec 0) 'vgs:obj)(vector-ref vec 3)(raise (vgs:obj-exn 'vgs:obj-angle 'xpr)))) +(define-inline (vgs:obj-type-set! vec val)(if (eq? (vector-ref vec 0) 'vgs:obj)(vector-set! vec 1 val)(raise (vgs:obj-exn 'type)))) +(define-inline (vgs:obj-fill-color-set! vec val)(if (eq? (vector-ref vec 0) 'vgs:obj)(vector-set! vec 2 val)(raise (vgs:obj-exn 'fill-color)))) +(define-inline (vgs:obj-angle-set! vec val)(if (eq? (vector-ref vec 0) 'vgs:obj)(vector-set! vec 3 val)(raise (vgs:obj-exn 'angle)))) + +(define-class () + ((type) + (fill-color) + (angle))) + + +;; first use raw vectors +(print "Using vectors") +(time + (loop ((for r (up-from 0 (to 255)))) + (loop ((for g (up-from 0 (to 255)))) + (loop ((for b (up-from 0 (to 255)))) + (let ((obj (make-vg:obj))) + (vg:obj-set-type! obj 'abc) + (vg:obj-set-fill-color! obj "green") + (vg:obj-set-angle! obj 135) + (let ((a (vg:obj-get-type obj)) + (b (vg:obj-get-fill-color obj)) + (c (vg:obj-get-angle obj))) + obj)))))) + +;; first use raw vectors with safe mode +(print "Using vectors (safe mode)") +(time + (loop ((for r (up-from 0 (to 255)))) + (loop ((for g (up-from 0 (to 255)))) + (loop ((for b (up-from 0 (to 255)))) + (let ((obj (make-vgs:obj))) + ;; (badobj (make-vector 20))) + (vgs:obj-type-set! obj 'abc) + (vgs:obj-fill-color-set! obj "green") + (vgs:obj-angle-set! obj 135) + (let ((a (vgs:obj-type obj)) + (b (vgs:obj-fill-color obj)) + (c (vgs:obj-angle obj))) + obj)))))) + +;; first use defstruct +(print "Using defstruct") +(time + (loop ((for r (up-from 0 (to 255)))) + (loop ((for g (up-from 0 (to 255)))) + (loop ((for b (up-from 0 (to 255)))) + (let ((obj (make-obj))) + (obj-type-set! obj 'abc) + (obj-fill-color-set! obj "green") + (obj-angle-set! obj 135) + (let ((a (obj-type obj)) + (b (obj-fill-color obj)) + (c (obj-angle obj))) + obj)))))) + + +;; first use defstruct +(print "Using coops") +(time + (loop ((for r (up-from 0 (to 255)))) + (loop ((for g (up-from 0 (to 255)))) + (loop ((for b (up-from 0 (to 255)))) + (let ((obj (make ))) + (set! (slot-value obj 'type) 'abc) + (set! (slot-value obj 'fill-color) "green") + (set! (slot-value obj 'angle) 135) + (let ((a (slot-value obj 'type)) + (b (slot-value obj 'fill-color)) + (c (slot-value obj 'angle))) + obj)))))) ADDED attic/runs-launch-loop-test.scm Index: attic/runs-launch-loop-test.scm ================================================================== --- /dev/null +++ attic/runs-launch-loop-test.scm @@ -0,0 +1,76 @@ +;; Copyright 2006-2017, Matthew Welland. +;; +;; This file is part of Megatest. +;; +;; Megatest is free software: you can redistribute it and/or modify +;; it under the terms of the GNU General Public License as published by +;; the Free Software Foundation, either version 3 of the License, or +;; (at your option) any later version. +;; +;; Megatest is distributed in the hope that it will be useful, +;; but WITHOUT ANY WARRANTY; without even the implied warranty of +;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +;; GNU General Public License for more details. +;; +;; You should have received a copy of the GNU General Public License +;; along with Megatest. If not, see . +;; +(use srfi-69) + +(define (runs:queue-next-hed tal reg n regful) + (if regful + (car reg) + (car tal))) + +(define (runs:queue-next-tal tal reg n regful) + (if regful + tal + (let ((newtal (cdr tal))) + (if (null? newtal) + reg + newtal + )))) + +(define (runs:queue-next-reg tal reg n regful) + (if regful + (cdr reg) + (if (eq? (length tal) 1) + '() + reg))) + +(use trace) +(trace runs:queue-next-hed + runs:queue-next-tal + runs:queue-next-reg) + + +(define tests '(1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20)) + +(define test-registry (make-hash-table)) + +(define n 3) + +(let loop ((hed (car tests)) + (tal (cdr tests)) + (reg '())) + (let* ((reglen (length reg)) + (regful (> reglen n))) + (print "hed=" hed ", length reg=" (length reg) ", (> lenreg n)=" (> (length reg) n)) + (let ((newtal (append tal (list hed)))) ;; used if we are not done with this test + (cond + ((not (hash-table-ref/default test-registry hed #f)) + (hash-table-set! test-registry hed #t) + (print "Registering #" hed) + (if (not (null? tal)) + (loop (runs:queue-next-hed tal reg n regful) + (runs:queue-next-tal tal reg n regful) + (let ((newl (append reg (list hed)))) + (if regful + (cdr newl) + newl))))) + (else + (print "Running #" hed) + (if (not (null? tal)) + (loop (runs:queue-next-hed tal reg n regful) + (runs:queue-next-tal tal reg n regful) + (runs:queue-next-reg tal reg n regful)))))))) ADDED attic/sdb.scm Index: attic/sdb.scm ================================================================== --- /dev/null +++ attic/sdb.scm @@ -0,0 +1,116 @@ +;;====================================================================== +;; Copyright 2006-2013, Matthew Welland. +;; +;; This file is part of Megatest. +;; +;; Megatest is free software: you can redistribute it and/or modify +;; it under the terms of the GNU General Public License as published by +;; the Free Software Foundation, either version 3 of the License, or +;; (at your option) any later version. +;; +;; Megatest is distributed in the hope that it will be useful, +;; but WITHOUT ANY WARRANTY; without even the implied warranty of +;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +;; GNU General Public License for more details. +;; +;; You should have received a copy of the GNU General Public License +;; along with Megatest. If not, see . + +;;====================================================================== + +;;====================================================================== +;; Simple persistant strings lookup table. Keep out of the main db +;; so writes/reads don't slow down central access. +;;====================================================================== + +(require-extension (srfi 18) extras) +(use sqlite3 srfi-1 posix regex regex-case srfi-69 csv-xml s11n md5 message-digest base64) +(import (prefix sqlite3 sqlite3:)) +(import (prefix base64 base64:)) + +(declare (unit sdb)) + +;; +(define (sdb:open fname) + (let* ((dbpath (pathname-directory fname)) + (dbexists (let ((fe (common:file-exists? fname))) + (if fe + fe + (begin + (create-directory dbpath #t) + #f)))) + (sdb (sqlite3:open-database fname)) + (handler (make-busy-timeout 136000))) + (sqlite3:set-busy-handler! sdb handler) + (if (not dbexists) + (sdb:initialize sdb)) + (sqlite3:execute sdb "PRAGMA synchronous = 1;") + sdb)) + +(define (sdb:initialize sdb) + (sqlite3:execute sdb "CREATE TABLE IF NOT EXISTS strs + (id INTEGER PRIMARY KEY, + str TEXT, + CONSTRAINT str UNIQUE (str));") + (sqlite3:execute sdb "CREATE INDEX IF NOT EXISTS strindx ON strs (str);")) + +;; (define sumup (let ((a 0))(lambda (x)(set! a (+ x a)) a))) + +(define (sdb:register-string sdb str) + (sqlite3:execute sdb "INSERT OR IGNORE INTO strs (str) VALUES (?);" str)) + +(define (sdb:string->id sdb str-cache str) + (let ((id (hash-table-ref/default str-cache str #f))) + (if (not id) + (sqlite3:for-each-row + (lambda (sid) + (set! id sid) + (hash-table-set! str-cache str id)) + sdb + "SELECT id FROM strs WHERE str=?;" str)) + id)) + +(define (sdb:id->string sdb id-cache id) + (let ((str (hash-table-ref/default id-cache id #f))) + (if (not str) + (sqlite3:for-each-row + (lambda (istr) + (set! str istr) + (hash-table-set! id-cache id str)) + sdb + "SELECT str FROM strs WHERE id=?;" id)) + str)) + +;; Numbers get passed though in both directions +;; +(define (make-sdb:qry fname) + (let ((sdb #f) + (scache (make-hash-table)) + (icache (make-hash-table))) + (lambda (cmd var) + (case cmd + ((setup) (set! sdb (if (not sdb) + (sdb:open (if var var fname))))) + ((setdb) (set! sdb var)) + ((getdb) sdb) + ((finalize) (if sdb + (begin + (sqlite3:finalize! sdb) + (set! sdb #f)))) + ((getid) (let ((id (if (or (number? var) + (string->number var)) + var + (sdb:string->id sdb scache var)))) + (if id + id + (begin + (sdb:register-string sdb var) + (sdb:string->id sdb scache var))))) + ((getstr) (if (or (number? var) + (string->number var)) + (sdb:id->string sdb icache var) + var)) + ((passid) var) + ((passstr) var) + (else #f))))) + ADDED attic/synchash.scm Index: attic/synchash.scm ================================================================== --- /dev/null +++ attic/synchash.scm @@ -0,0 +1,137 @@ +;;====================================================================== +;; Copyright 2006-2012, Matthew Welland. +;; +;; This file is part of Megatest. +;; +;; Megatest is free software: you can redistribute it and/or modify +;; it under the terms of the GNU General Public License as published by +;; the Free Software Foundation, either version 3 of the License, or +;; (at your option) any later version. +;; +;; Megatest is distributed in the hope that it will be useful, +;; but WITHOUT ANY WARRANTY; without even the implied warranty of +;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +;; GNU General Public License for more details. +;; +;; You should have received a copy of the GNU General Public License +;; along with Megatest. If not, see . +;; +;;====================================================================== + +;;====================================================================== +;; A hash of hashes that can be kept in sync by sending minial deltas +;;====================================================================== + +(use format) +(use srfi-1 srfi-69 sqlite3) +(import (prefix sqlite3 sqlite3:)) + +(declare (unit synchash)) +(declare (uses db)) +(declare (uses server)) +(declare (uses rmtmod)) + +(include "db_records.scm") + +(import rmtmod) + +(define (synchash:make) + (make-hash-table)) + +;; given an alist of objects '((id obj) ...) +;; 1. remove unchanged objects from the list +;; 2. create a list of removed objects by id +;; 3. remove removed objects from synchash +;; 4. replace or add new or changed objects to synchash +;; +(define (synchash:get-delta indat synchash) + (let ((deleted '()) + (changed '()) + (found '()) + (orig-keys (hash-table-keys synchash))) + (for-each + (lambda (item) + (let* ((id (car item)) + (dat (cadr item)) + (ref (hash-table-ref/default synchash id #f))) + (if (not (equal? dat ref)) ;; item changed or new + (begin + (set! changed (cons item changed)) + (hash-table-set! synchash id dat))) + (set! found (cons id found)))) + indat) + (for-each + (lambda (id) + (if (not (member id found)) + (begin + (set! deleted (cons id deleted)) + (hash-table-delete! synchash id)))) + orig-keys) + (list changed deleted) + ;; (list indat '()) ;; just for debugging + )) + +;; keynum => the field to use as the unique key (usually 0 but can be other field) +;; +(define (synchash:client-get proc synckey keynum synchash run-id . params) + (let* ((data (rmt:synchash-get run-id proc synckey keynum params)) + (newdat (car data)) + (removs (cadr data)) + (myhash (hash-table-ref/default synchash synckey #f))) + (if (not myhash) + (begin + (set! myhash (make-hash-table)) + (hash-table-set! synchash synckey myhash))) + (for-each + (lambda (item) + (let ((id (car item)) + (dat (cadr item))) + ;; (debug:print-info 2 *default-log-port* "Processing item: " item) + (hash-table-set! myhash id dat))) + newdat) + (for-each + (lambda (id) + (hash-table-delete! myhash id)) + removs) + ;; WHICH ONE!? + ;; data)) ;; return the changed and deleted list + (list newdat removs))) ;; synchash)) + +(define *synchashes* (make-hash-table)) + +(define (synchash:server-get dbstruct run-id proc synckey keynum params) + ;; (debug:print-info 2 *default-log-port* "synckey: " synckey ", keynum: " keynum ", params: " params) + (let* ((dbdat (db:get-db dbstruct run-id)) + (db (db:dbdat-get-db dbdat)) + (synchash (hash-table-ref/default *synchashes* synckey #f)) + (newdat (apply (case proc + ((db:get-runs) db:get-runs) + ((db:get-tests-for-run-mindata) db:get-tests-for-run-mindata) + ((db:get-test-info-by-ids) db:get-test-info-by-ids) + (else + (print "ERROR: sync for hash " proc " not setup! Edits needed in synchash.scm") + print)) + db params)) + (postdat #f) + (make-indexed (lambda (x) + (list (vector-ref x keynum) x)))) + ;; Now process newdat based on the query type + (set! postdat (case proc + ((db:get-runs) + ;; (debug:print-info 2 *default-log-port* "Get runs call") + (let ((header (vector-ref newdat 0)) + (data (vector-ref newdat 1))) + ;; (debug:print-info 2 *default-log-port* "header: " header ", data: " data) + (cons (list "header" header) ;; add the header keyed by the word "header" + (map make-indexed data)))) ;; add each element keyed by the keynum'th val + (else + ;; (debug:print-info 2 *default-log-port* "Non-get runs call") + (map make-indexed newdat)))) + ;; (debug:print-info 2 *default-log-port* "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))) + ADDED attic/vg-test.scm Index: attic/vg-test.scm ================================================================== --- /dev/null +++ attic/vg-test.scm @@ -0,0 +1,119 @@ +;; Copyright 2006-2017, Matthew Welland. +;; +;; This file is part of Megatest. +;; +;; Megatest is free software: you can redistribute it and/or modify +;; it under the terms of the GNU General Public License as published by +;; the Free Software Foundation, either version 3 of the License, or +;; (at your option) any later version. +;; +;; Megatest is distributed in the hope that it will be useful, +;; but WITHOUT ANY WARRANTY; without even the implied warranty of +;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +;; GNU General Public License for more details. +;; +;; You should have received a copy of the GNU General Public License +;; along with Megatest. If not, see . +;; +(use canvas-draw iup foof-loop) +(import canvas-draw-iup) + +(load "vg.scm") + +(define numtorun 1000) +;; (if (> (length (argv)) 1) +;; (string->number (cadr (argv))) +;; 1000)) + + (use trace) + ;; (trace + ;; ;; vg:draw-rect + ;; ;; vg:grow-rect + ;; vg:get-extents-for-objs + ;; vg:components-get-extents + ;; vg:instances-get-extents + ;; vg:get-extents-for-two-rects + ;; canvas-line!) + +(define d1 (vg:drawing-new)) +(define l1 (vg:lib-new)) +(define c1 (vg:comp-new)) +(define c2 (vg:comp-new)) +(define bt1 (vg:make-rect-obj 10 40 20 50 text: "A long piece of text" font: "Helvetica, -10")) + +(let ((r1 (vg:make-rect-obj 20 20 30 30 text: "r1" font: "Helvetica, -20")) + (r2 (vg:make-rect-obj 30 30 60 60 text: "r2" font: "Helvetica, -10")) + (t1 (vg:make-text-obj 60 60 "The middle" font: "Helvetica, -10"))) + (vg:add-objs-to-comp c1 r1 r2 t1 bt1)) + +(loop ((for x (up-from 0 (to 20)))) + (loop ((for y (up-from 0 (to 20)))) + (vg:add-objs-to-comp c1 (vg:make-rect-obj x y (+ x 5)(+ y 5))))) + +(let ((start (current-seconds))) + (let loop ((i 0)) + (vg:add-obj-to-comp c1 (vg:make-rect-obj 0 0 100 100)) + (if (< i numtorun)(loop (+ i 1)))) + (print "Run time: " (- (current-seconds) start))) + +(vg:add-obj-to-comp c1 (vg:make-line-obj 0 0 100 100)) + +;; add the c1 component to lib l1 with name firstcomp +(vg:add-comp-to-lib l1 "firstcomp" c1) +(vg:add-comp-to-lib l1 "secondcomp" c2) + +;; add the l1 lib to drawing with name firstlib +(vg:add-lib d1 "firstlib" l1) + +;; instantiate firstlib/firstcomp as inst1 in drawing d1 at 0,0 +(vg:instantiate d1 "firstlib" "firstcomp" "inst1" 0 0) +(vg:instantiate d1 "firstlib" "firstcomp" "inst2" 200 200) + + +;; (vg:drawing-scalex-set! d1 1.1) +;; (vg:drawing-scaley-set! d1 0.5) + +;; (define xtnts (vg:scale-offset-xy +;; (vg:component-get-extents c1) +;; 1.1 1.1 -2 -2)) + +;; get extents of c1 and put a rectange around it +;; +(define xtnts (apply vg:grow-rect 10 10 (vg:components-get-extents d1 c1))) +(vg:add-objs-to-comp c1 (apply vg:make-rect-obj xtnts)) + +(define bt1xt (vg:obj-get-extents d1 bt1)) +(print "bt1xt: " bt1xt) +(vg:add-objs-to-comp c1 (apply vg:make-rect-obj bt1xt)) + +;; get extents of all objects and put rectangle around it +;; +(define big-xtnts (vg:instances-get-extents d1)) +(vg:add-objs-to-comp c2 (apply vg:make-rect-obj big-xtnts)) +(vg:instantiate d1 "firstlib" "secondcomp" "inst3" 0 0) + +(vg:drawing-scalex-set! d1 1.5) +(vg:drawing-scaley-set! d1 1.5) + +(define cnv #f) +(define the-cnv (canvas + #:size "500x400" + #:expand "YES" + #:scrollbar "YES" + #:posx "0.5" + #:posy "0.5" + #:action (make-canvas-action + (lambda (c xadj yadj) + (set! cnv c))))) + +(show + (dialog + (vbox + the-cnv))) + +(vg:drawing-cnv-set! d1 cnv) +(vg:draw d1 #t) + +;; (canvas-rectangle! cnv 10 100 10 80) + +(main-loop) ADDED bin/.11/lib/libpangox-1.0.so Index: bin/.11/lib/libpangox-1.0.so ================================================================== --- /dev/null +++ bin/.11/lib/libpangox-1.0.so cannot compute difference between binary files ADDED bin/.11/lib/libpangox-1.0.so.0 Index: bin/.11/lib/libpangox-1.0.so.0 ================================================================== --- /dev/null +++ bin/.11/lib/libpangox-1.0.so.0 cannot compute difference between binary files ADDED bin/.11/lib/libxcb-xlib.so.0 Index: bin/.11/lib/libxcb-xlib.so.0 ================================================================== --- /dev/null +++ bin/.11/lib/libxcb-xlib.so.0 cannot compute difference between binary files Index: cgisetup/models/pgdb.scm ================================================================== --- cgisetup/models/pgdb.scm +++ cgisetup/models/pgdb.scm @@ -18,10 +18,11 @@ ;;====================================================================== (declare (unit pgdb)) (declare (uses configf)) +(declare (uses mtargs)) ;; I don't know how to mix compilation units and modules, so no module here. ;; ;; (module pgdb ;; ( @@ -31,10 +32,11 @@ ;; (import scheme) ;; (import data-structures) ;; (import chicken) (use typed-records (prefix dbi dbi:)) +(import (prefix mtargs args:)) ;; given a configdat lookup the connection info and open the db ;; (define (pgdb:open configdat #!key (dbname #f)(dbispec #f)) (let ((pgconf (or dbispec @@ -177,15 +179,15 @@ state status owner event-time comment fail-count pass-count last_update publish-time run-id area-id )) ;; given all needed info create run record ;; (define (pgdb:insert-run dbh ttype-id target run-name state status owner event-time comment fail-count pass-count area-id last-update publish-time) - (dbi:exec + (dbi:exec dbh "INSERT INTO runs (ttype_id,target,run_name,state,status,owner,event_time,comment,fail_count,pass_count,area_id,last_update,publish_time) VALUES (?,?,?,?,?,?,?,?,?,?,?,?, ?);" - ttype-id target run-name state status owner event-time comment fail-count pass-count area-id last-update publish-time)) + ttype-id target run-name state status owner event-time comment fail-count pass-count area-id last-update publish-time)) ;;====================================================================== ;; T E S T - S T E P S ;;====================================================================== Index: chicken.makefile ================================================================== --- chicken.makefile +++ chicken.makefile @@ -23,11 +23,11 @@ # CHICKEN_BIN_DIR=$(shell dirname $(shell which csi)) # if have csi on path use that, else use default # CSIPATH=$(shell which csi) # CKPATH=$(shell dirname $(shell dirname $(CSIPATH))) -CHICKEN_PREFIX=$(or $(CKPATH),$(PREFIX)/bin/.$(ARCHSTR)) +sCHICKEN_PREFIX=$(or $(CKPATH),$(PREFIX)/bin/.$(ARCHSTR)) whatever : @echo "CHICKEN_PREFIX=$(CHICKEN_PREFIX)" tgz-$(USER)/postgresql-9.6.4.tar.gz : @@ -66,11 +66,10 @@ cd tgz-$(USER)/nanomsg-1.0.0/build-$(USER); make; make install $(CHICKEN_PREFIX)/chicken-4.13.0/LICENSE : tgz-$(USER)/chicken-4.13.0.tar.gz mkdir -p build-$(USER)/eggs-installed cd build-$(USER);tar xf ../tgz-$(USER)/chicken-4.13.0.tar.gz - if [[ -e $(CHICKEN_PREFIX)/chicken-4.13.0/LICENSE ]];then touch $(CHICKEN_PREFIX)/chicken-4.13.0/LICENSE;fi tgz-$(USER)/opensrc.fossil : cd tgz-$(USER); fossil clone http://www.kiatoa.com/fossils/opensrc opensrc.fossil mkdir tgz-$(USER)/opensrc cd tgz-$(USER)/opensrc; fossil open --nested ../opensrc.fossil; fossil up; fossil uv sync @@ -102,11 +101,11 @@ cd tgz-$(USER)/ffcall; make CC="gcc -fPIC"; make install $(CHICKEN_PREFIX)/bin/sqlite3 : build-$(USER)/sqlite-autoconf-3090200/configure cd build-$(USER)/sqlite-autoconf-3090200; ./configure --prefix=$(CHICKEN_PREFIX); make; make install -$(CHICKEN_PREFIX)/bin/csi : $(SQLITE3_DEP) $(CHICKEN_PREFIX)/lib/libiupweb.so $(CHICKEN_PREFIX)/chicken-4.13.0/LICENSE +$(CHICKEN_PREFIX)/bin/csi : $(CHICKEN_PREFIX)/bin/sqlite3 $(CHICKEN_PREFIX)/lib/libiupweb.so $(CHICKEN_PREFIX)/chicken-4.13.0/LICENSE cd build-$(USER)/chicken-4.13.0;make PLATFORM=linux PREFIX=$(CHICKEN_PREFIX) cd build-$(USER)/chicken-4.13.0;make PLATFORM=linux PREFIX=$(CHICKEN_PREFIX) install ALL_CKBIN=chicken chicken-bind chicken-bug chicken-dump \ chicken-install chicken-profile chicken-sqlite3 chicken-status \ @@ -113,56 +112,35 @@ chicken-uninstall csc csi feathers nanocat sqlite3 vacuumdb logpro \ refdb CKBIN_WRAPPERS=$(addprefix $(PREFIX)/bin/,$(ALL_CKBIN)) -$(PREFIX)/bin/% : $(CHICKEN_PREFIX)/bin/% $(CHICKEN_PREFIX)/bin/csi +$(PREFIX)/bin/% : $(CHICKEN_PREFIX)/bin/% $(CHICKEN_PREFIX)/bin/csi $(EGGSTARG2) utils/mk_wrapper_tool $(PREFIX) $* $(PREFIX)/bin/$* chmod a+x $(PREFIX)/bin/$* $(PREFIX)/bin : mkdir -p $(PREFIX)/bin $(CHICKEN_PREFIX)/bin -# For the future - binwrappers -chicken : $(PREFIX)/bin $(CHICKEN_PREFIX)/bin/csi postgresql.done nanomsg.done iup.done canvas-draw.done sqlite3.done sql-de-lite.done dbi.done $(EGGSTARG2) +chicken : $(PREFIX)/bin $(CHICKEN_PREFIX)/bin/csi binwrappers @echo "Fake target to build prefix chicken" binwrappers : $(CKBIN_WRAPPERS) -# make the dep a dummy if not requiring our own build of postgres -ifeq ($(BUILD_POSTGRES),yes) -PG_DEP=$(CHICKEN_PREFIX)/bin/pg_config -else -PG_DEP=$(CHICKEN_PREFIX)/bin/csi -endif - -postgresql.done : $(PG_DEP) +postgresql.done : $(CHICKEN_PREFIX)/bin/pg_config CSC_OPTIONS="-I$(CHICKEN_PREFIX)/include -L$(CHICKEN_PREFIX)/lib -L$(CHICKEN_PREFIX)/lib64" $(CHICKEN_PREFIX)/bin/chicken-install postgresql > postgresql.done -ifeq ($(BUILD_NANOMSG),yes) -NMSG_DEP=$(CHICKEN_PREFIX)/lib/libnanomsg.so -else -NMSG_DEP=$(CHICKEN_PREFIX)/bin/csi -endif - -nanomsg.done : $(NMSG_DEP) +nanomsg.done : $(CHICKEN_PREFIX)/lib/libnanomsg.so CSC_OPTIONS="-I$(CHICKEN_PREFIX)/include -L$(CHICKEN_PREFIX)/lib -L$(CHICKEN_PREFIX)/lib64" $(CHICKEN_PREFIX)/bin/chicken-install nanomsg > nanomsg.done iup.done : $(CHICKEN_PREFIX)/lib/libcallback.a CSC_OPTIONS="-I$(CHICKEN_PREFIX)/include -L$(CHICKEN_PREFIX)/lib" $(CHICKEN_PREFIX)/bin/chicken-install -D no-library-checks -feature disable-iup-web -feature disable-iup-pplot -feature disable-iup-matrixex iup > iup.done canvas-draw.done : CSC_OPTIONS="-I$(CHICKEN_PREFIX)/include -L$(CHICKEN_PREFIX)/lib" $(CHICKEN_PREFIX)/bin/chicken-install -D no-library-checks canvas-draw > canvas-draw.done -# make the dep a dummy if not requiring our own build of postgres -ifeq ($(BUILD_SQLITE3),yes) -SQLITE3_DEP=$(CHICKEN_PREFIX)/bin/sqlite3 -else -SQLITE3_DEP=$(CHICKEN_PREFIX)/bin/csi -endif - -sqlite3.done : $(SQLITE3_DEP) +sqlite3.done : CSC_OPTIONS="-I$(CHICKEN_PREFIX)/include -L$(CHICKEN_PREFIX)/lib" $(CHICKEN_PREFIX)/bin/chicken-install sqlite3 > sqlite3.done sql-de-lite.done : CSC_OPTIONS="-I$(CHICKEN_PREFIX)/include -L$(CHICKEN_PREFIX)/lib" $(CHICKEN_PREFIX)/bin/chicken-install sql-de-lite > sql-de-lite.done DELETED client.scm Index: client.scm ================================================================== --- client.scm +++ /dev/null @@ -1,123 +0,0 @@ - -;; Copyright 2006-2012, Matthew Welland. -;; -;; This file is part of Megatest. -;; -;; Megatest is free software: you can redistribute it and/or modify -;; it under the terms of the GNU General Public License as published by -;; the Free Software Foundation, either version 3 of the License, or -;; (at your option) any later version. -;; -;; Megatest is distributed in the hope that it will be useful, -;; but WITHOUT ANY WARRANTY; without even the implied warranty of -;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the -;; GNU General Public License for more details. -;; -;; You should have received a copy of the GNU General Public License -;; along with Megatest. If not, see . - -;;====================================================================== -;; C L I E N T S -;;====================================================================== - -(use srfi-18 extras tcp s11n srfi-1 posix regex srfi-69 hostinfo md5 - message-digest matchable spiffy uri-common intarweb http-client - spiffy-request-vars uri-common intarweb directory-utils) - -(declare (unit client)) - -(declare (uses common)) -(declare (uses db)) -(declare (uses tasks)) ;; tasks are where stuff is maintained about what is running. - -(include "common_records.scm") -(include "db_records.scm") - -;; client:get-signature -(define (client:get-signature) - (if *my-client-signature* *my-client-signature* - (let ((sig (conc (get-host-name) " " (current-process-id)))) - (set! *my-client-signature* sig) - *my-client-signature*))) - -;; Not currently used! But, I think it *should* be used!!! -#;(define (client:logout serverdat) - (let ((ok (and (socket? serverdat) - (cdb:logout serverdat *toppath* (client:get-signature))))) - ok)) - -#;(define (client:connect iface port) - (http-transport:client-connect iface port) - #;(case (server:get-transport) - ((rpc) (rpc:client-connect iface port)) - ((http) (http:client-connect iface port)) - ((zmq) (zmq:client-connect iface port)) - (else (rpc:client-connect iface port)))) - -(define (client:setup areapath #!key (remaining-tries 100) (failed-connects 0)) - (client:setup-http areapath remaining-tries: remaining-tries failed-connects: failed-connects) - #;(case (server:get-transport) - ((rpc) (rpc-transport:client-setup remaining-tries: remaining-tries failed-connects: failed-connects)) ;;(client:setup-rpc run-id)) - ((http)(client:setup-http areapath remaining-tries: remaining-tries failed-connects: failed-connects)) - (else (rpc-transport:client-setup remaining-tries: remaining-tries failed-connects: failed-connects)))) ;; (client:setup-rpc run-id)))) - -;; Do all the connection work, look up the transport type and set up the -;; connection if required. -;; -;; There are two scenarios. -;; 1. We are a test manager and we received *transport-type* and *runremote* via cmdline -;; 2. We are a run tests, list runs or other interactive process and we must figure out -;; *transport-type* and *runremote* from the monitor.db -;; -;; client:setup -;; -;; lookup_server, need to remove *runremote* stuff -;; - -(define (client:setup-http areapath #!key (remaining-tries 100) (failed-connects 0)(area-dat #f)) - (debug:print-info 2 *default-log-port* "client:setup remaining-tries=" remaining-tries) - (server:start-and-wait areapath) - (if (<= remaining-tries 0) - (begin - (debug:print-error 0 *default-log-port* "failed to start or connect to server") - (exit 1)) - ;; - ;; Alternatively here, we can get the list of candidate servers and work our way - ;; through them searching for a good one. - ;; - (let* ((server-dat (server:get-rand-best areapath)) ;; (server:get-first-best areapath)) - (runremote (or area-dat *runremote*))) - (if (not server-dat) ;; no server found - (client:setup-http areapath remaining-tries: (- remaining-tries 1)) - (let ((host (cadr server-dat)) - (port (caddr server-dat))) - (debug:print-info 4 *default-log-port* "client:setup server-dat=" server-dat ", remaining-tries=" remaining-tries) - (if (and (not area-dat) - (not *runremote*)) - (set! *runremote* (make-remote))) - (if (and host port) - (let* ((start-res (case *transport-type* - ((http)(http-transport:client-connect host port)))) - (ping-res (case *transport-type* - ((http)(rmt:login-no-auto-client-setup start-res))))) - (if (and start-res - ping-res) - (let ((runremote (or area-dat *runremote*))) ;; it might have been generated only a few statements ago - (remote-conndat-set! runremote start-res) ;; (hash-table-set! runremote run-id start-res) - (debug:print-info 2 *default-log-port* "connected to " (http-transport:server-dat-make-url start-res)) - start-res) - (begin ;; login failed but have a server record, clean out the record and try again - (debug:print-info 0 *default-log-port* "client:setup, login unsuccessful, will attempt to start server ... start-res=" start-res ", server-dat=" server-dat) ;; had runid. Fixes part of Randy;s ticket 1405717332 - (case *transport-type* - ((http)(http-transport:close-connections))) - (remote-conndat-set! runremote #f) ;; (hash-table-delete! runremote run-id) - (thread-sleep! 1) - (client:setup-http areapath remaining-tries: (- remaining-tries 1)) - ))) - (begin ;; no server registered - ;; (server:kind-run areapath) - (server:start-and-wait areapath) - (debug:print-info 0 *default-log-port* "client:setup, no server registered, remaining-tries=" remaining-tries) - (thread-sleep! 1) ;; (+ 5 (random (- 20 remaining-tries)))) ;; give server a little time to start up, randomize a little to avoid start storms. - (client:setup-http areapath remaining-tries: (- remaining-tries 1))))))))) - Index: common.scm ================================================================== --- common.scm +++ common.scm @@ -15,37 +15,58 @@ ;; ;; You should have received a copy of the GNU General Public License ;; along with Megatest. If not, see . ;;====================================================================== + +(declare (unit common)) +(declare (uses commonmod)) +(declare (uses rmtmod)) +(declare (uses debugprint)) +(declare (uses mtargs)) + (use srfi-1 data-structures posix regex-case (prefix base64 base64:) format dot-locking csv-xml z3 udp ;; sql-de-lite hostinfo md5 message-digest typed-records directory-utils stack matchable regex posix (srfi 18) extras ;; tcp (prefix nanomsg nmsg:) (prefix sqlite3 sqlite3:) pkts (prefix dbi dbi:) ) +(use posix-extras pathname-expand files) -(declare (unit common)) -;; (declare (uses commonmod)) -;; (import commonmod) +(import commonmod + debugprint + rmtmod + (prefix mtargs args:)) + +(define (remove-server-files directory-path) + (let ((files (glob (string-append directory-path "/server*")))) + (for-each delete-file* files))) (include "common_records.scm") - - -;; (require-library margs) -;; (include "margs.scm") - -;; (define old-exit exit) -;; -;; (define (exit . code) -;; (if (null? code) -;; (old-exit) -;; (old-exit code))) - +(define (remove-files filespec) + (let ((files (glob filespec))) + (for-each delete-file* files))) + +(define (stop-the-train) + (thread-start! (make-thread (lambda () + (let loop () + (if (and *toppath* + (file-exists? (conc *toppath*"/stop-the-train"))) + (let* ((msg (conc "ERROR: found file "*toppath*"/stop-the-train, exiting immediately"))) + ;; yes, print to current-output-port AND *default-log-port*, annoying but necessary I think + (print msg) + (remove-server-files (conc *toppath* "/logs")) + (debug:print 0 *default-log-port* msg) + (remove-files (conc *toppath* "/logs/server*")) + (remove-files (conc *toppath* "/.servinfo/*")) + (remove-files (conc *toppath* "/.mtdb/*lock")) + (exit 1))) + (thread-sleep! 5) + (loop)))))) ;; execute thunk, return value. If exception thrown, trap exception, return #f, and emit nonfatal condition note to *default-log-port* . ;; arguments - thunk, message (define (common:fail-safe thunk warning-message-on-exception) (handle-exceptions @@ -129,55 +150,48 @@ (define *test-meta-updated* (make-hash-table)) (define *globalexitstatus* 0) ;; attempt to work around possible thread issues (define *passnum* 0) ;; when running track calls to run-tests or similar ;; (define *alt-log-file* #f) ;; used by -log -(define *common:denoise* (make-hash-table)) ;; for low noise printing +;; (define *common:denoise* (make-hash-table)) ;; for low noise printing (define *default-log-port* (current-error-port)) (define *time-zero* (current-seconds)) ;; for the watchdog +(define *on-exit-procs* '()) ;; add procs to this list to be executed on exit (define *default-area-tag* "local") ;; DATABASE -(define *dbstruct-db* #f) ;; used to cache the dbstruct in db:setup. Goal is to remove this. -;; db stats -(define *db-stats* (make-hash-table)) ;; hash of vectors < count duration-total > -(define *db-stats-mutex* (make-mutex)) ;; db access (define *db-last-access* (current-seconds)) ;; last db access, used in server -(define *db-write-access* #t) +;; (define *db-write-access* #t) ;; db sync -(define *db-last-sync* 0) ;; last time the sync to megatest.db happened +;; (define *db-last-sync* 0) ;; last time the sync to megatest.db happened (define *db-sync-in-progress* #f) ;; if there is a sync in progress do not try to start another -(define *db-multi-sync-mutex* (make-mutex)) ;; protect access to *db-sync-in-progress*, *db-last-sync* +;; (define *db-multi-sync-mutex* (make-mutex)) ;; protect access to *db-sync-in-progress*, *db-last-sync* ;; task db (define *task-db* #f) ;; (vector db path-to-db) (define *db-access-allowed* #t) ;; flag to allow access -(define *db-access-mutex* (make-mutex)) -(define *db-transaction-mutex* (make-mutex)) +;; (define *db-access-mutex* (make-mutex)) ;; moved to dbfile +;; (define *db-transaction-mutex* (make-mutex)) (define *db-cache-path* #f) -(define *db-with-db-mutex* (make-mutex)) +;; (define *db-with-db-mutex* (make-mutex)) (define *db-api-call-time* (make-hash-table)) ;; hash of command => (list of times) -;; no sync db -(define *no-sync-db* #f) ;; SERVER -(define *my-client-signature* #f) (define *transport-type* 'http) ;; override with [server] transport http|rpc|nmsg (define *runremote* #f) ;; if set up for server communication this will hold ;; (define *max-cache-size* 0) (define *logged-in-clients* (make-hash-table)) (define *server-id* #f) (define *server-info* #f) ;; good candidate for easily convert to non-global (define *time-to-exit* #f) -(define *server-run* #t) (define *run-id* #f) (define *server-kind-run* (make-hash-table)) (define *home-host* #f) ;; (define *total-non-write-delay* 0) (define *heartbeat-mutex* (make-mutex)) -(define *api-process-request-count* 0) -(define *max-api-process-requests* 0) +;; (define *api-process-request-count* 0) +;; (define *max-api-process-requests* 0) (define *server-overloaded* #f) ;; client (define *rmt-mutex* (make-mutex)) ;; remote access calls mutex @@ -197,12 +211,11 @@ (define *launch-setup-mutex* (make-mutex)) ;; need to be able to call launch:setup often so mutex it and re-call the real deal only if *toppath* not set (define *homehost-mutex* (make-mutex)) ;; Miscellaneous (define *triggers-mutex* (make-mutex)) ;; block overlapping processing of triggers - -(use posix-extras pathname-expand files) +(define *numcpus-cache* (make-hash-table)) ;; this plugs a hole in posix-extras in recent chicken versions > 4.9) (let-values (( (chicken-release-number chicken-major-version) (apply values (map string->number @@ -225,35 +238,21 @@ (string-match "^-(s|ss|sx|script)$" (cadr argv))) (caddr argv)) (else (car argv)))) (fullpath (realpath this-script))) fullpath)) + +;;====================================================================== + (define *common:this-exe-fullpath* (common:get-this-exe-fullpath)) (define *common:this-exe-dir* (pathname-directory *common:this-exe-fullpath*)) (define *common:this-exe-name* (pathname-strip-directory *common:this-exe-fullpath*)) -;; when called from a wrapper I need sometimes to find the calling -;; wrapper, this is for dashboard to find the correct megatest. -;; -(define (common:find-local-megatest #!optional (progname "megatest")) - (let ((res (filter file-exists? - (map (lambda (updir) - (let* ((lm (car (argv))) - (dir (pathname-directory lm)) - (exe (pathname-strip-directory lm))) - (conc (if dir (conc dir "/") "") - (case (string->symbol exe) - ((dboard) (conc updir progname)) - ((mtest) (conc updir progname)) - ((dashboard) progname) - (else exe))))) - '("../../" "../"))))) - (if (null? res) - (begin - (debug:print 0 *current-log-port* "Failed to find this executable! Using what can be found on the path") - progname) - (car res)))) +(define (common:get-sync-lock-filepath) + (let* ((tmp-area (common:make-tmpdir-name *toppath* "")) + (lockfile (conc tmp-area "/megatest.db.lock"))) + lockfile)) (define *common:logpro-exit-code->status-sym-alist* '( ( 0 . pass ) ( 1 . fail ) ( 2 . warn ) @@ -294,20 +293,39 @@ (else "FAIL"))) (define (common:logpro-exit-code->test-status exit-code) (status-sym->string (common:logpro-exit-code->status-sym exit-code))) +;; (defstruct remote - (hh-dat (common:get-homehost)) ;; homehost record ( addr . hhflag ) - (server-url (if *toppath* (server:check-if-running *toppath*))) ;; (server:check-if-running *toppath*) #f)) + + ;; transport to be used + ;; http - use http-transport + ;; http-read-cached - use http-transport for writes but in-mem cached for reads + (rmode 'http) + (hh-dat (let ((res (or (server:choose-server *toppath* 'homehost) + (cons #f #f)))) + (assert (pair? res)(conc "FATAL: hh-dat should be a pair, got "res)) + res)) + (server-url #f) ;; (server:check-if-running *toppath*) #f)) + (server-id #f) + (server-info #f) ;; (if *toppath* (server:check-if-running *toppath*) #f)) (last-server-check 0) ;; last time we checked to see if the server was alive - (conndat #f) - (transport *transport-type*) + (connect-time (current-seconds)) ;; when we first connected + (last-access (current-seconds)) ;; last time we talked to server + ;; (conndat #f) ;; iface port api-uri api-url api-req seconds server-id (server-timeout (server:expiration-timeout)) (force-server #f) (ro-mode #f) - (ro-mode-checked #f)) ;; flag that indicates we have checked for ro-mode + (ro-mode-checked #f) ;; flag that indicates we have checked for ro-mode + + ;; conndat stuff + (iface #f) ;; TODO: Consolidate this data with server-url and server-info above + (port #f) + (api-url #f) + (api-uri #f) + (api-req #f)) ;; launching and hosts (defstruct host (reachable #f) (last-update 0) @@ -358,10 +376,11 @@ (conc megatest-version "-" megatest-fossil-hash)) (define (common:version-signature) (conc megatest-version "-" (substring megatest-fossil-hash 0 4))) +;;====================================================================== ;; from metadat lookup MEGATEST_VERSION ;; (define (common:get-last-run-version) ;; RADT => How does this work in send-receive function??; assume it is the value saved in some DB (rmt:get-var "MEGATEST_VERSION")) @@ -370,45 +389,55 @@ (substring (common:get-last-run-version) 0 6))) (define (common:set-last-run-version) (rmt:set-var "MEGATEST_VERSION" (common:version-signature))) +;;====================================================================== ;; postive number if megatest version > db version ;; negative number if megatest version < db version (define (common:version-db-delta) - (- megatest-version (common:get-last-run-version-number))) + (- megatest-version (common:get-last-run-version-number))) (define (common:version-changed?) (not (equal? (common:get-last-run-version) (common:version-signature)))) + +;; From 1.70 to 1.81, db's are compatible. +;; +;; BUG: This logic is almost certainly not quite correct. +;; (define (common:api-changed?) - (not (equal? (substring (->string megatest-version) 0 4) - (substring (conc (common:get-last-run-version)) 0 4)))) - - -(define (common:get-sync-lock-filepath) - (let* ((tmp-area (common:get-db-tmp-area)) - (lockfile (conc tmp-area "/megatest.db.sync-lock"))) - lockfile)) - + (let* ((megatest-major-version (substring (->string megatest-version) 0 4)) + (run-major-version (substring (conc (common:get-last-run-version)) 0 4))) + (and (not (member megatest-major-version '("1.81" "1.80"))) + (not (equal? megatest-major-version run-major-version))))) + +;;====================================================================== ;; Move me elsewhere ... ;; RADT => Why do we meed the version check here, this is called only if version misma ;; (define (common:cleanup-db dbstruct #!key (full #f)) - (apply db:multi-db-sync - dbstruct - 'schema - ;; 'new2old - 'killservers - 'adj-target - ;; 'old2new - 'new2old - ;; (if full - '(dejunk) - ;; '()) - ) + (case (rmt:transport-mode) + ((http) + (apply db:multi-db-sync + dbstruct + 'schema + 'killservers + 'adj-target + 'new2old + '(dejunk) + )) + ((tcp nfs) + (apply db:multi-db-sync + dbstruct + 'schema + 'killservers + 'adj-target + 'new2old + '(dejunk) + ))) (if (common:api-changed?) (common:set-last-run-version))) (define (common:snapshot-file filepath #!key (subdir ".") ) (if (file-exists? filepath) @@ -487,22 +516,12 @@ (when (>= (age-wks daysfile) 1) (copy daysfile wksfile) (copy hrsfile daysfile)) #t) #f)) - -(define (common:safe-vector-ref vec indx default) - (if (vector? vec) - (handle-exceptions - exn - (begin - (debug:print-info 0 *default-log-port* "remote data issue: exn=" exn) - default) - (vector-ref vec indx)) - default)) - - + +;;====================================================================== ;; Rotate logs, logic: ;; if > 500k and older than 1 week: ;; remove previous compressed log and compress this log ;; WARNING: This proc operates assuming that it is in the directory above the ;; logs directory you wish to log-rotate. @@ -510,11 +529,11 @@ (define (common:rotate-logs) (let* ((all-files (make-hash-table)) (stats (make-hash-table)) (inc-stat (lambda (key) (hash-table-set! stats key (+ (hash-table-ref/default stats key 0) 1)))) - (max-allowed (string->number (or (configf:lookup *configdat* "setup" "max-logfiles") "300")))) ;; name -> age + (max-allowed (string->number (or (configf:lookup *configdat* "setup" "max-logfiles") "600")))) ;; name -> age (if (not (directory-exists? "logs"))(create-directory "logs")) (directory-fold (lambda (file rem) (handle-exceptions exn @@ -583,21 +602,23 @@ exn (debug:print-error 0 *default-log-port* "failed to remove " fullname ", exn=" exn) (delete-file* fullname))))) files) (debug:print-info 0 *default-log-port* "Deleted " (length files) " files from logs, keeping " max-allowed " files.")))))) - + +;;====================================================================== ;; Force a megatest cleanup-db if version is changed and skip-version-check not specified ;; Do NOT check if not on homehost! ;; (define (common:exit-on-version-changed) - (if (common:on-homehost?) + (if (and *toppath* ;; do nothing if *toppath* not yet provided + (common:on-homehost?)) (if (common:api-changed?) (let* ((mtconf (conc (get-environment-variable "MT_RUN_AREA_HOME") "/megatest.config")) - (dbfile (conc (get-environment-variable "MT_RUN_AREA_HOME") "/megatest.db")) - (read-only (not (file-write-access? dbfile))) - (dbstruct (db:setup #t))) + (dbfile (conc (get-environment-variable "MT_RUN_AREA_HOME") ".mtdb/main.db")) + (read-only (not (file-write-access? dbfile))) + (dbstruct (db:setup))) ;; (db:setup-db *dbstruct-dbs* *toppath* #f))) ;; #t))) (debug:print 0 *default-log-port* "WARNING: Version mismatch!\n" " expected: " (common:version-signature) "\n" " got: " (common:get-last-run-version)) (cond @@ -615,21 +636,22 @@ (common:cleanup-db dbstruct))) ((not (common:file-exists? mtconf)) (debug:print 0 *default-log-port* " megatest.config does not exist in this area. Cannot proceed with megatest version migration.") (exit 1)) ((not (common:file-exists? dbfile)) - (debug:print 0 *default-log-port* " megatest.db does not exist in this area. Cannot proceed with megatest version migration.") + (debug:print 0 *default-log-port* " .mtdb/main.db does not exist in this area. Cannot proceed with megatest version migration.") (exit 1)) ((not (eq? (current-user-id)(file-owner mtconf))) - (debug:print 0 *default-log-port* " You do not own megatest.db in this area. Cannot proceed with megatest version migration.") + (debug:print 0 *default-log-port* " You do not own .mtdb/main.db in this area. Cannot proceed with megatest version migration.") (exit 1)) (read-only (debug:print 0 *default-log-port* " You have read-only access to this area. Cannot proceed with megatest version migration.") (exit 1)) (else (debug:print 0 *default-log-port* " to switch versions you can run: \"megatest -cleanup-db\"") (exit 1))))))) +;;====================================================================== ;; (begin ;; (debug:print 0 *default-log-port* "ERROR: cannot migrate version unless on homehost. Exiting.") ;; (exit 1)))) ;;====================================================================== @@ -698,22 +720,21 @@ "")))) (define (common:alist-ref/default key alist default) (or (alist-ref key alist) default)) -(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) - (or (getenv "MT_MEGATEST") "megatest")) +;; moved into commonmod +;; +;; (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:read-encoded-string instr) (handle-exceptions exn (handle-exceptions @@ -723,54 +744,10 @@ (print-call-chain (current-error-port)) #f) (read (open-input-string (base64:base64-decode instr)))) (read (open-input-string (z3:decode-buffer (base64:base64-decode instr)))))) -;; dot-locking egg seems not to work, using this for now -;; if lock is older than expire-time then remove it and try again -;; to get the lock -;; -(define (common:simple-file-lock fname #!key (expire-time 300)) - (let ((fmod-time (handle-exceptions - ext - (current-seconds) - (file-modification-time fname)))) - (if (common:file-exists? fname) - (if (> (- (current-seconds) fmod-time) expire-time) - (begin - (handle-exceptions exn #f (delete-file* fname)) - (common:simple-file-lock fname expire-time: expire-time)) - #f) - (let ((key-string (conc (get-host-name) "-" (current-process-id)))) - (with-output-to-file fname - (lambda () - (print key-string))) - (thread-sleep! 0.25) - (if (common:file-exists? fname) - (handle-exceptions exn - #f - (with-input-from-file fname - (lambda () - (equal? key-string (read-line))))) - #f))))) - -(define (common:simple-file-lock-and-wait fname #!key (expire-time 300)) - (let ((end-time (+ expire-time (current-seconds)))) - (let loop ((got-lock (common:simple-file-lock fname expire-time: expire-time))) - (if got-lock - #t - (if (> end-time (current-seconds)) - (begin - (thread-sleep! 3) - (loop (common:simple-file-lock fname expire-time: expire-time))) - #f))))) - -(define (common:simple-file-release-lock fname) - (handle-exceptions - exn - #f ;; I don't really care why this failed (at least for now) - (delete-file* fname))) ;;====================================================================== ;; S T A T E S A N D S T A T U S E S ;;====================================================================== @@ -793,10 +770,11 @@ "REMOVING" "CLEANING" "ARCHIVE_REMOVING" )) +;;====================================================================== ;; BBnote: *common:std-statuses* dashboard filter control and test control status buttons defined here; used in set-fields-panel and dboard:make-controls ;; note these statuses are sorted from better to worse. ;; This sort order is important to dcommon:status-compare3 and db:set-state-status-and-roll-up-items (define *common:std-statuses* '(;; (0 "DELETED") @@ -815,14 +793,14 @@ (define *common:ended-states* ;; states which indicate the test is stopped and will not proceed '("COMPLETED" "ARCHIVED" "KILLED" "KILLREQ" "STUCK" "INCOMPLETE" )) (define *common:badly-ended-states* ;; these roll up as CHECK, i.e. results need to be checked - '("KILLED" "KILLREQ" "STUCK" "INCOMPLETE" "DEAD")) + '("KILLED" "KILLREQ" "STUCK" "INCOMPLETE" "DEAD" "CHECK")) (define *common:well-ended-states* ;; an item's prereq in this state allows item to proceed - '("PASS" "WARN" "CHECK" "WAIVED" "SKIP")) + '("PASS" "WARN" "WAIVED" "SKIP")) ;; BBnote: *common:running-states* used from db:set-state-status-and-roll-up-items (define *common:running-states* ;; test is either running or can be run '("RUNNING" "REMOTEHOSTSTART" "LAUNCHED" "STARTED")) @@ -830,10 +808,11 @@ '("COMPLETED" "KILLED" "UNKNOWN" "INCOMPLETE" "ARCHIVED")) (define *common:not-started-ok-statuses* ;; if not one of these statuses when in not_started state treat as dead '("n/a" "na" "PASS" "FAIL" "WARN" "CHECK" "WAIVED" "DEAD" "SKIP")) +;;====================================================================== ;; group tests into buckets corresponding to rollup ;;; Running, completed-pass, completed-non-pass + worst status, not started. ;; filter out ;(define (common:categorize-items-for-rollup in-tests) ; ( @@ -845,10 +824,11 @@ (lambda (a b) (let ((a-num (cadr (or (assoc a items-order) '(0 0)))) (b-num (cadr (or (assoc b items-order) '(0 0))))) (acomp a-num b-num)))))) +;;====================================================================== ;; ;; given a toplevel with currstate, currstatus apply state and status ;; ;; => (newstate . newstatus) ;; (define (common:apply-state-status currstate currstatus state status) ;; (let* ((cstate (string->symbol (string-downcase currstate))) ;; (cstatus (string->symbol (string-downcase currstatus))) @@ -920,13 +900,14 @@ (configf:lookup *configdat* "setup" "testsuite" ) (getenv "MT_TESTSUITE_NAME") (pathname-file (or (if (string? *toppath* ) (pathname-file *toppath*) #f) - (common:get-topath #f))) + (common:get-toppath #f))) "please-set-setup-area-name")) ;; (pathname-file (current-directory))))) +;;====================================================================== ;; safe getting of toppath (define (common:get-toppath areapath) (or *toppath* (if areapath (begin @@ -948,10 +929,14 @@ (debug:print-error 0 *default-log-port* "Unable to find megatest home directory.") #f) (loop (pathname-directory thepath))))) )) + +;;====================================================================== +;; redefine for future cleanup (converge on area-name, the more generic +;; (define common:get-area-name common:get-testsuite-name) (define (common:get-db-tmp-area . junk) (if *db-cache-path* *db-cache-path* @@ -959,160 +944,46 @@ (handle-exceptions exn (begin (debug:print-error 0 *default-log-port* "Couldn't create path to " *db-cache-path* ", exn=" exn) (exit 1)) - (let* ((tsname (common:get-testsuite-name)) + (let* ((toppath (common:real-path *toppath*)) + (tsname (common:get-testsuite-name)) (dbpath (common:get-create-writeable-dir (list (conc "/tmp/" (current-user-name) "/megatest_localdb/" tsname "/" - (string-translate *toppath* "/" ".")) + (string-translate toppath "/" ".")) (conc "/tmp/" (current-process-id) ;; just in case we have an issue with the dir by own user name - "/megatest_localdb/" + "/"(current-user-name) "/megatest_localdb/" tsname - (string-translate *toppath* "/" ".")) + (string-translate toppath "/" ".")) )))) (set! *db-cache-path* dbpath) + ;; ensure megatest area has .mtdb + (let ((dbarea (conc *toppath* "/.mtdb"))) + (if (not (file-exists? dbarea)) + (create-directory dbarea))) + ;; ensure tmp area has .mtdb + (let ((dbarea (conc dbpath "/.mtdb"))) + (if (not (file-exists? dbarea)) + (create-directory dbarea))) dbpath)) #f))) (define (common:get-area-path-signature) (message-digest-string (md5-primitive) *toppath*)) -(define (common:get-signature str) - (message-digest-string (md5-primitive) str)) - ;;====================================================================== ;; E X I T H A N D L I N G ;;====================================================================== (define (common:run-sync?) - (and (common:on-homehost?) - (args:get-arg "-server"))) - -;; (let ((ohh (common:on-homehost?)) -;; (srv (args:get-arg "-server"))) -;; (and ohh srv))) - ;; (debug:print-info 0 *default-log-port* "common:run-sync? ohh=" ohh ", srv=" srv) - - - -(define *wdnum* 0) -(define *wdnum*mutex (make-mutex)) - - -(define (common:human-time) - (time->string (seconds->local-time (current-seconds)) "%Y-%m-%d %H:%M:%S")) - - -;; currently the primary job of the watchdog is to run the sync back to megatest.db from the db in /tmp -;; if we are on the homehost and we are a server (by definition we are on the homehost if we are a server) -;; -(define (common:readonly-watchdog dbstruct) - (thread-sleep! 0.05) ;; delay for startup - (debug:print-info 13 *default-log-port* "common:readonly-watchdog entered.") - ;; sync megatest.db to /tmp/.../megatst.db - (let* ((sync-cool-off-duration 3) - (golden-mtdb (dbr:dbstruct-mtdb dbstruct)) - (golden-mtpath (db:dbdat-get-path golden-mtdb)) - (tmp-mtdb (dbr:dbstruct-tmpdb dbstruct)) - (tmp-mtpath (db:dbdat-get-path tmp-mtdb))) - (debug:print-info 0 *default-log-port* "Read-only periodic sync thread started.") - (let loop ((last-sync-time 0)) - (debug:print-info 13 *default-log-port* "loop top tmp-mtpath="tmp-mtpath" golden-mtpath="golden-mtpath) - (let* ((duration-since-last-sync (- (current-seconds) last-sync-time))) - (debug:print-info 13 *default-log-port* "duration-since-last-sync="duration-since-last-sync) - (if (and (not *time-to-exit*) - (< duration-since-last-sync sync-cool-off-duration)) - (thread-sleep! (- sync-cool-off-duration duration-since-last-sync))) - (if (not *time-to-exit*) - (let ((golden-mtdb-mtime (file-modification-time golden-mtpath)) - (tmp-mtdb-mtime (file-modification-time tmp-mtpath))) - (if (> golden-mtdb-mtime tmp-mtdb-mtime) - (if (< golden-mtdb-mtime (- (current-seconds) 3)) ;; file has NOT been touched in past three seconds, this way multiple servers won't fight to sync back - (let ((res (db:multi-db-sync dbstruct 'old2new))) - (debug:print-info 13 *default-log-port* "rosync called, " res " records transferred.")))) - (loop (current-seconds))) - #t))) - (debug:print-info 0 *default-log-port* "Exiting readonly-watchdog timer, *time-to-exit* = " *time-to-exit*" pid="(current-process-id)" mtpath="golden-mtpath))) - -;; TODO: for multiple areas, we will have multiple watchdogs; and multiple threads to manage -(define (common:watchdog) - (debug:print-info 13 *default-log-port* "common:watchdog entered.") - (if (launch:setup) - (if (common:on-homehost?) - (let ((dbstruct (db:setup #t))) - (debug:print-info 13 *default-log-port* "after db:setup with dbstruct=" dbstruct) - (cond - ((dbr:dbstruct-read-only dbstruct) - (debug:print-info 13 *default-log-port* "loading read-only watchdog") - (common:readonly-watchdog dbstruct)) - (else - (debug:print-info 13 *default-log-port* "loading writable-watchdog.") - (let* ((syncer (or (configf:lookup *configdat* "server" "sync-method") "delta-sync"))) ;; "brute-force-sync"))) - (cond - ((equal? syncer "brute-force-sync") - (server:writable-watchdog-bruteforce dbstruct)) - ((equal? syncer "delta-sync") - (server:writable-watchdog-deltasync dbstruct)) - (else - (debug:print-error 0 *default-log-port* "Unknown server/sync-method specified ("syncer") - valid values are brute-force-sync and delta-sync.") - (exit 1))) - ;;(debug:print 1 *default-log-port* "INFO: ["(common:human-time)"] Syncer started (method="syncer")") - ))) - (debug:print-info 13 *default-log-port* "watchdog done.")) - (debug:print-info 13 *default-log-port* "no need for watchdog on non-homehost")))) - - -(define (std-exit-procedure) - ;;(common:telemetry-log-close) - (on-exit (lambda () 0)) - ;;(debug:print-info 13 *default-log-port* "std-exit-procedure called; *time-to-exit*="*time-to-exit*) - (let ((no-hurry (if *time-to-exit* ;; hurry up - #f - (begin - (set! *time-to-exit* #t) - #t)))) - (debug:print-info 4 *default-log-port* "starting exit process, finalizing databases.") - (if (and no-hurry (debug:debug-mode 18)) - (rmt:print-db-stats)) - (let ((th1 (make-thread (lambda () ;; thread for cleaning up, give it five seconds - (if *dbstruct-db* (db:close-all *dbstruct-db*)) ;; one second allocated - (if *task-db* - (let ((db (cdr *task-db*))) - (if (sqlite3:database? db) - (begin - (sqlite3:interrupt! db) - (sqlite3:finalize! db #t) - ;; (vector-set! *task-db* 0 #f) - (set! *task-db* #f))))) - (http-client#close-all-connections!) - ;; (if (and *runremote* - ;; (remote-conndat *runremote*)) - ;; (begin - ;; (http-client#close-all-connections!))) ;; for http-client - (if (not (eq? *default-log-port* (current-error-port))) - (close-output-port *default-log-port*)) - (set! *default-log-port* (current-error-port))) "Cleanup db exit thread")) - (th2 (make-thread (lambda () - (debug:print 4 *default-log-port* "Attempting clean exit. Please be patient and wait a few seconds...") - (if no-hurry - (begin - (thread-sleep! 5)) ;; give the clean up few seconds to do it's stuff - (begin - (thread-sleep! 2))) - (debug:print 4 *default-log-port* " ... done") - ) - "clean exit"))) - (thread-start! th1) - (thread-start! th2) - (thread-join! th1) - ) - ) - - 0) + (and *toppath* ;; gate if called before *toppath* is set + (common:on-homehost?) + (args:get-arg "-server"))) + (define (std-signal-handler signum) ;; (signal-mask! signum) (set! *time-to-exit* #t) ;;(debug:print-info 13 *default-log-port* "got signal "signum) @@ -1137,10 +1008,11 @@ ;;====================================================================== ;; M I S C U T I L S ;;====================================================================== +;;====================================================================== ;; convert stuff to a number if possible (define (any->number val) (cond ((number? val) val) ((string? val) (string->number val)) @@ -1163,31 +1035,17 @@ (set! res #t)))) (string-split patts ",")) res) #t)) +;;====================================================================== ;; '(print (string-intersperse (map cadr (hash-table-ref/default (read-config "megatest.config" \#f \#t) "disks" '"'"'("none" ""))) "\n"))' (define (common:get-disks #!key (configf #f)) (hash-table-ref/default (or configf (read-config "megatest.config" #f #t)) "disks" '("none" ""))) -;; return first command that exists, else #f -;; -(define (common:which cmds) - (if (null? cmds) - #f - (let loop ((hed (car cmds)) - (tal (cdr cmds))) - (let ((res (with-input-from-pipe (conc "which " hed) read-line))) - (if (and (string? res) - (common:file-exists? res)) - res - (if (null? tal) - #f - (loop (car tal)(cdr tal)))))))) - (define (common:get-install-area) (let ((exe-path (car (argv)))) (if (common:file-exists? exe-path) (handle-exceptions exn @@ -1195,10 +1053,11 @@ (pathname-directory (pathname-directory (pathname-directory exe-path)))) #f))) +;;====================================================================== ;; return first path that can be created or already exists and is writable ;; (define (common:get-create-writeable-dir dirs) (if (null? dirs) #f @@ -1219,10 +1078,11 @@ res (if (null? tal) #f (loop (car tal)(cdr tal)))))))) +;;====================================================================== ;; return the youngest timestamp . filename ;; (define (common:get-youngest glob-list) (let ((all-files (apply append (map (lambda (patt) @@ -1241,10 +1101,11 @@ (list curmod fname) res))) '(0 "n/a") all-files))) +;;====================================================================== ;; use bash to expand a glob. Does NOT handle paths with spaces! ;; (define (common:bash-glob instr) (string-split (with-input-from-pipe @@ -1253,10 +1114,11 @@ ;;====================================================================== ;; Some safety net stuff ;;====================================================================== +;;====================================================================== ;; return input if it is a list or return null (define (common:list-or-null inlst #!key (ovrd #f)(message #f)) (if (list? inlst) inlst (begin @@ -1266,10 +1128,11 @@ ;;====================================================================== ;; T A R G E T S , S T A T E , S T A T U S , ;; R U N N A M E A N D T E S T P A T T ;;====================================================================== +;;====================================================================== ;; (map print (map car (hash-table->alist (read-config "runconfigs.config" #f #t)))) ;; (define (common:get-runconfig-targets #!key (configf #f)) (let ((targs (sort (map car (hash-table->alist (or configf ;; NOTE: There is no value in using runconfig:read here. @@ -1282,10 +1145,11 @@ (filter (lambda (x) (patt-list-match x target-patt)) targs) targs))) +;;====================================================================== ;; Lookup a value in runconfigs based on -reqtarg or -target ;; (define (runconfigs-get config var) (let ((targ (common:args-get-target))) ;; (or (args:get-arg "-reqtarg")(args:get-arg "-target")(getenv "MT_TARGET")))) (if targ @@ -1322,35 +1186,32 @@ rtestpatt) (else (debug:print-info 0 *default-log-port* "using testpatt " args-testpatt " rtestpatt:" rtestpatt) args-testpatt)))) - - (define (common:false-on-exception thunk #!key (message #f)) (handle-exceptions exn (begin (if message (debug:print-info 0 *default-log-port* message)) #f) (thunk) )) (define (common:file-exists? path-string #!key (silent #f)) - ;; this avoids stack dumps in the case where - - ;;;; TODO: catch permission denied exceptions and emit appropriate warnings, eg: system error while trying to access file: "/nfs/pdx/disks/icf_env_disk001/bjbarcla/gwa/issues/mtdev/randy-slow/reproduce/q... + ;;;; TODO: catch permission denied exceptions and emit appropriate warnings. Might be able to get rid of with chicken 5? (common:false-on-exception (lambda () (file-exists? path-string)) message: (if (not silent) (conc "Unable to access path: " path-string) #f) )) (define (common:directory-exists? path-string) - ;;;; TODO: catch permission denied exceptions and emit appropriate warnings, eg: system error while trying to access file: "/nfs/pdx/disks/icf_env_disk001/bjbarcla/gwa/issues/mtdev/randy-slow/reproduce/q... + ;;;; TODO: catch permission denied exceptions and emit appropriate warnings (common:false-on-exception (lambda () (directory-exists? path-string)) message: (conc "Unable to access path: " path-string) )) +;;====================================================================== ;; does the directory exist and do we have write access? ;; ;; returns the directory or #f ;; (define (common:directory-writable? path-string) @@ -1410,10 +1271,11 @@ (debug:print-error 0 *default-log-port* "Invalid target, spaces or blanks not allowed \"" target "\", target should be: " (string-intersperse keys "/") ", have " tlist " for elements") (if exit-if-bad (exit 1)) #f) #f)))) +;;====================================================================== ;; looking only (at least for now) at the MT_ variables craft the full testname ;; (define (common:get-full-test-name) (if (getenv "MT_TEST_NAME") (if (and (getenv "MT_ITEMPATH") @@ -1420,76 +1282,17 @@ (not (equal? (getenv "MT_ITEMPATH") ""))) (getenv "MT_TEST_NAME") (conc (getenv "MT_TEST_NAME") "/" (getenv "MT_ITEMPATH"))) #f)) +;;====================================================================== ;; logic for getting homehost. Returns (host . at-home) ;; IF *toppath* is not set, wait up to five seconds trying every two seconds ;; (this is to accomodate the watchdog) ;; -(define (common:get-homehost #!key (trynum 5)) - ;; called often especially at start up. use mutex to eliminate collisions - (mutex-lock! *homehost-mutex*) - (cond - (*home-host* - (mutex-unlock! *homehost-mutex*) - *home-host*) - ((not *toppath*) - (mutex-unlock! *homehost-mutex*) - (launch:setup) ;; safely mutexed now - (if (> trynum 0) - (begin - (thread-sleep! 2) - (common:get-homehost trynum: (- trynum 1))) - #f)) - (else - (let* ((currhost (get-host-name)) - (bestadrs (server:get-best-guess-address currhost)) - ;; first look in config, then look in file .homehost, create it if not found - (homehost (or (configf:lookup *configdat* "server" "homehost" ) - (handle-exceptions - exn - (if (> trynum 0) - (let ((delay-time (* (- 5 trynum) 5))) - (mutex-unlock! *homehost-mutex*) - (debug:print 0 *default-log-port* "ERROR: ["(common:human-time)"] Failed to read .homehost file, delaying " - delay-time " seconds and trying again, message: " ((condition-property-accessor 'exn 'message) exn) - ", exn=" exn) - (thread-sleep! delay-time) - (common:get-homehost trynum: (- trynum 1))) - (begin - (mutex-unlock! *homehost-mutex*) - (debug:print 0 *default-log-port* "ERROR: ["(common:human-time) - "] Failed to read .homehost file after trying five times. Giving up and exiting, message: " - ((condition-property-accessor 'exn 'message) exn)) - (exit 1))) - (let ((hhf (conc *toppath* "/.homehost"))) - (if (common:file-exists? hhf) - (with-input-from-file hhf read-line) - (if (file-write-access? *toppath*) - (begin - (with-output-to-file hhf - (lambda () - (print bestadrs))) - (begin - (mutex-unlock! *homehost-mutex*) - (car (common:get-homehost)))) - #f)))))) - (at-home (or (equal? homehost currhost) - (equal? homehost bestadrs)))) - (set! *home-host* (cons homehost at-home)) - (mutex-unlock! *homehost-mutex*) - *home-host*)))) - -;; am I on the homehost? -;; -(define (common:on-homehost?) - (let ((hh (common:get-homehost))) - (if hh - (cdr hh) - #f))) - + +;;====================================================================== ;; do we honor the caches of the config files? ;; (define (common:use-cache?) (let ((res #t)) ;; priority by order of evaluation (if *configdat* ;; sillyness here. can't use setup/use-cache to know if we can use the cached files! @@ -1503,10 +1306,11 @@ (set! res #t) (if (equal? (getenv "MT_USE_CACHE") "no") (set! res #f)))) ;; overrides -no-cache switch res)) +;;====================================================================== ;; force use of server? ;; (define (common:force-server?) (let* ((force-setting (configf:lookup *configdat* "server" "force")) (force-type (if force-setting (string->symbol force-setting) #f)) @@ -1519,18 +1323,19 @@ (else (debug:print 0 *default-log-port* "ERROR: Bad server force setting " force-setting ", forcing server.") #t)))) ;; default to requiring server (if force-result (begin - (debug:print-info 0 *default-log-port* "forcing use of server, force setting is \"" force-setting "\".") + (debug:print-info 0 *default-log-port* "ATTENTION! Forcing use of server, force setting is \"" force-setting "\".") #t) #f))) ;;====================================================================== ;; M I S C L I S T S ;;====================================================================== +;;====================================================================== ;; items in lista are matched value and position in listb ;; return the remaining items in listb or #f ;; (define (common:list-is-sublist lista listb) (if (null? lista) @@ -1549,10 +1354,11 @@ (car talb) (cdr talb))) #f))))) +;;====================================================================== ;; Needed for long lists to be sorted where (apply max ... ) dies ;; (define (common:max inlst) (let loop ((max-val (car inlst)) (hed (car inlst)) @@ -1561,10 +1367,11 @@ (loop (max hed max-val) (car tal) (cdr tal)) (max hed max-val)))) +;;====================================================================== ;; get min or max, use > for max and < for min, this works around the limits on apply ;; (define (common:min-max comp lst) (if (null? lst) #f ;; better than an exception for my needs @@ -1571,10 +1378,11 @@ (fold (lambda (a b) (if (comp a b) a b)) (car lst) lst))) +;;====================================================================== ;; get min or max, use > for max and < for min, this works around the limits on apply ;; (define (common:sum lst) (if (null? lst) 0 @@ -1581,10 +1389,11 @@ (fold (lambda (a b) (+ a b)) (car lst) lst))) +;;====================================================================== ;; path list to hash-table tree ;; ((a b c)(a b d)(e b c)) => ((a (b (d) (c))) (e (b (c)))) ;; (define (common:list->htree lst) (let ((resh (make-hash-table))) @@ -1602,10 +1411,11 @@ (hash-table-set! ht hed (make-hash-table)) (loop ht hed tal))))) lst) resh)) +;;====================================================================== ;; hash-table tree to html list tree ;; ;; tipfunc takes two parameters: y the tip value and path the path to that point ;; (define (common:htree->html ht path tipfunc) @@ -1627,10 +1437,11 @@ (list levelname (common:htree->html y newpath tipfunc)))))) datlist))))) +;;====================================================================== ;; hash-table tree to alist tree ;; (define (common:htree->atree ht) (map (lambda (x) (cons (car x) @@ -1642,10 +1453,11 @@ ;;====================================================================== ;; M U N G E D A T A I N T O N I C E F O R M S ;;====================================================================== +;;====================================================================== ;; Generate an index for a sparse list of key values ;; ( (rowname1 colname1 val1)(rowname2 colname2 val2) ) ;; ;; => ;; @@ -1681,16 +1493,18 @@ new-colnames (if (> curr-rownum rownum) curr-rownum rownum) (if (> curr-colnum colnum) curr-colnum colnum) )))))) +;;====================================================================== ;; if it looks like a number -> convert it to a number, else return it ;; (define (common:lazy-convert inval) (let* ((as-num (if (string? inval)(string->number inval) #f))) (or as-num inval))) +;;====================================================================== ;; convert string a=1; b=2; c=a silly thing; d= ;; to '((a . 1)(b . 2)(c . "a silly thing")(d . "")) ;; (define (common:val->alist val #!key (convert #f)) (let ((val-list (string-split-fields ";\\s*" val #:infix))) @@ -1708,22 +1522,24 @@ ;;====================================================================== ;; S Y S T E M S T U F F ;;====================================================================== +;;====================================================================== ;; lazy-safe get file mod time. on any error (file not existing etc.) return 0 ;; (define (common:lazy-modification-time fpath) (handle-exceptions exn (begin - (debug:print 0 *default-log-port* "Failed to get modifcation time for " fpath ", treating it as zero. exn=" exn) + (debug:print 2 *default-log-port* "Failed to get modification time for " fpath ", treating it as zero. exn=" exn) 0) (if (file-exists? fpath) (file-modification-time fpath) 0))) +;;====================================================================== ;; find timestamp of newest file associated with a sqlite db file (define (common:lazy-sqlite-db-modification-time fpath) (let* ((glob-list (handle-exceptions exn (begin @@ -1736,19 +1552,21 @@ (apply max (map common:lazy-modification-time file-list)))) +;;====================================================================== ;; return a nice clean pathname made absolute (define (common:nice-path dir) (let ((match (string-match "^(~[^\\/]*)(\\/.*|)$" dir))) (if match ;; using ~ for home? (common:nice-path (conc (common:read-link-f (cadr match)) "/" (caddr match))) (normalize-pathname (if (absolute-pathname? dir) dir (conc (current-directory) "/" dir)))))) +;;====================================================================== ;; make "nice-path" available in config files and the repl (define nice-path common:nice-path) (define (common:read-link-f path) (handle-exceptions @@ -1759,19 +1577,41 @@ (with-input-from-pipe (conc "/bin/readlink -f " path) (lambda () (read-line))))) +;; for reasons I don't understand multiple calls to real-path in parallel threads +;; must be protected by mutexes +;; +(define (common:real-path inpath) + ;; (process:cmd-run-with-stderr->list "readlink" "-f" inpath)) ;; cmd . params) + ;; (let-values + ;; (((inp oup pid) (process "readlink" (list "-f" inpath)))) + ;; (with-input-from-port inp + ;; (let loop ((inl (read-line)) + ;; (res #f)) + ;; (print "inl=" inl) + ;; (if (eof-object? inl) + ;; (begin + ;; (close-input-port inp) + ;; (close-output-port oup) + ;; ;; (process-wait pid) + ;; res) + ;; (loop (read-line) inl)))))) + (with-input-from-pipe (conc "readlink -f " inpath) read-line)) + +;;====================================================================== ;; returns *effective load* (not normalized) ;; (define (common:get-intercept onemin fivemin) (if (< onemin fivemin) ;; load is decreasing, just use the onemin load onemin (let* ((load-change (- onemin fivemin)) (tchange (- 300 60))) (max (+ onemin (* 60 (/ load-change tchange))) 0)))) +;;====================================================================== ;; calculate a delay number based on a droop curve ;; inputs are: ;; - load-in, load as from uptime, NOT normalized ;; - numcpus, number of cpus, ideally use the real cpus, not threads ;; @@ -1797,18 +1637,22 @@ (min (max (/ (expt r1 (* r2 s2 ratio)) s1) 0) 30)) (else (debug:print 0 *default-log-port* "BAD exp-params, should be \"r1 r2 s1 s2\" but got " paramstr) 30))))) -(define (common:print-delay-table) - (let loop ((x 0)) - (print x "," (common:get-delay x 1)) - (if (< x 2) - (loop (+ x 0.1))))) - -(define (get-cpu-load #!key (remote-host #f)) - (car (common:get-cpu-load remote-host))) +;; -mrw- this appears to not be used +;; +;; (define (common:print-delay-table) +;; (let loop ((x 0)) +;; (print x "," (common:get-delay x 1)) +;; (if (< x 2) +;; (loop (+ x 0.1))))) + +;; (define (get-cpu-load #!key (remote-host #f)) +;; (car (common:get-cpu-load remote-host))) + +;;====================================================================== ;; (let* ((load-res (process: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))) @@ -1817,18 +1661,19 @@ ;; (if (number? newval) ;; (set! cpu-load newval)))))) ;; (car load-res)) ;; cpu-load)) -;; get values from cached info from dropping file in logs dir +;;====================================================================== +;; get values from cached info from dropping file in .sysdata dir ;; e.g. key is host and dtype is normalized-load ;; (define (common:get-cached-info key dtype #!key (age 10)) (if *toppath* (let* ((fullpath (conc *toppath* "/.sysdata/" key "-" dtype ".log")) - (delfile (lambda () - (debug:print-info 1 *default-log-port* " removing bad file " fullpath ", exn=" exn) + (delfile (lambda (exn) + (debug:print-info 2 *default-log-port* " removing bad file " fullpath ", exn=" exn) (delete-file* fullpath) #f))) (if (and (file-exists? fullpath) (file-read-access? fullpath)) (handle-exceptions @@ -1846,15 +1691,15 @@ 0) (file-change-time fullpath))))) (if (< real-age age) (handle-exceptions exn - (delfile) + (delfile exn) (let* ((res (with-input-from-file fullpath read))) (if (eof-object? res) (begin - (delfile) + (delfile "n/a") #f) res))) (begin (debug:print-info 2 *default-log-port* "file " fullpath " is too old (" real-age" seconds) to trust, skipping reading it") @@ -1870,25 +1715,29 @@ (fullpath (conc fulldir "/" key "-" dtype ".log"))) (if (not (file-exists? fulldir))(create-directory fulldir #t)) (handle-exceptions exn (begin - (debug:print 0 *default-log-path* "failed to write file " fullpath ", exn=" exn) + (debug:print 0 *default-log-port* "failed to write file " fullpath ", exn=" exn) #f) (with-output-to-file fullpath (lambda ()(pp dat))))) #f)) (define (common:raw-get-remote-host-load remote-host) - (handle-exceptions - exn - (begin - (debug:print 0 *default-log-port* "failed to ssh to " remote-host " and get loadavg. exn=" exn) - #f) ;; more specific handling of errors needed - (with-input-from-pipe - (conc "ssh " remote-host " cat /proc/loadavg") - (lambda ()(list (read)(read)(read)))))) - + (let* ((inp #f)) + (handle-exceptions + exn + (begin + (close-input-pipe inp) + (debug:print 0 *default-log-port* "failed to ssh to " remote-host " and get loadavg. exn=" exn) + #f) ;; more specific handling of errors needed + (set! inp (open-input-pipe (conc "ssh " remote-host " cat /proc/loadavg"))) + (let ((res (list (read inp)(read inp)(read inp)))) + (close-input-pipe inp) + res)))) + +;;====================================================================== ;; get cpu load by reading from /proc/loadavg, return all three values ;; (define (common:get-cpu-load remote-host) (handle-exceptions exn @@ -1895,16 +1744,15 @@ (begin (debug:print 0 *default-log-port* "failed to ssh or read loadavg from host " remote-host ", exn=" exn) '(-99 -99 -99)) (let* ((actual-hostname (or remote-host (get-host-name) "localhost"))) (or (common:get-cached-info actual-hostname "cpu-load") - (let ((result (if remote-host + (let ((result (if (and remote-host + (not (equal? remote-host (get-host-name)))) (map (lambda (res) (if (eof-object? res) 9e99 res)) - (with-input-from-pipe - (conc "ssh " remote-host " cat /proc/loadavg") - (lambda ()(list (read)(read)(read))))) + (common:raw-get-remote-host-load remote-host)) (with-input-from-file "/proc/loadavg" (lambda ()(list (read)(read)(read))))))) (match result ((l1 l2 l3) @@ -1915,10 +1763,11 @@ (common:write-cached-info actual-hostname "cpu-load" result) result) '(-1 -1 -1))) ;; -1 is bad result (else '(-2 -2 -2)))))))) +;;====================================================================== ;; get normalized cpu load by reading from /proc/loadavg and /proc/cpuinfo return all three values and the number of real cpus and the number of threads ;; returns alist '((adj-cpu-load . normalized-proc-load) ... etc. ;; keys: adj-proc-load, adj-core-load, 1m-load, 5m-load, 15m-load ;; (define (common:get-normalized-cpu-load remote-host) @@ -1937,18 +1786,22 @@ (> (length res) 2)) res) ((eq? res #f) default) ;; add messages? ((eq? res #f) default) ;; this would be the #eof (else default)))) + +(define (common:ssh-get-loadavg remote-host) + (let ((inp (open-input-pipe (conc "ssh " remote-host " \"cat /proc/loadavg;cat /proc/cpuinfo;echo end\"")))) + (let* ((res (read-lines inp))) + (close-input-pipe inp) + res))) (define (common:get-normalized-cpu-load-raw remote-host) (let* ((actual-host (or remote-host (get-host-name)))) ;; #f is localhost (or (common:get-cached-info actual-host "normalized-load") (let ((data (if remote-host - (with-input-from-pipe - (conc "ssh " remote-host " \"cat /proc/loadavg;cat /proc/cpuinfo;echo end\"") - read-lines) + (common:ssh-get-loadavg remote-host) (append (with-input-from-file "/proc/loadavg" read-lines) (with-input-from-file "/proc/cpuinfo" read-lines) @@ -1998,10 +1851,11 @@ (define (common:unix-ping hostname) (let ((res (system (conc "ping -c 1 " hostname " > /dev/null")))) (eq? res 0))) +;;====================================================================== ;; ideally put all this info into the db, no need to preserve it across moving homehost ;; ;; return list of ;; ( reachable? cpuload update-time ) (define (common:get-host-info hostname) @@ -2029,10 +1883,11 @@ (alist-ref 'adj-core-load (common:get-normalized-cpu-load hostname)))) ;; this is cheaper than you might think. get-normalized-cpu-load is cached for up to 5 seconds (else (list #f 0 -1) ;; bad host, don't use! )))) +;;====================================================================== ;; see defstruct host at top of file. ;; host: reachable last-update last-used last-cpuload ;; (define (common:update-host-loads-table hosts-raw) (let* ((hosts (filter (lambda (x) @@ -2053,10 +1908,11 @@ (host-reachable-set! rec is-reachable) (host-last-update-set! rec last-reached-time) (host-last-cpuload-set! rec load))) hosts))) +;;====================================================================== ;; go through the hosts from least recently used to most recently used, pick the first that meets the load criteral from the ;; [host-rules] section. ;; (define (common:get-least-loaded-host hosts-raw host-type configdat) (let* ((rdat (configf:lookup configdat "host-rules" host-type)) @@ -2119,17 +1975,27 @@ (host-last-used-set! rec curr-time) new-best) (if (null? tal) #f (loop (car tal)(cdr tal) best-host))))))))) (define (common:wait-for-homehost-load maxnormload msg) - (let* ((hh-dat (if (common:on-homehost?) ;; if we are on the homehost then pass in #f so the calls are local. - #f - (common:get-homehost))) - (hh (if hh-dat (car hh-dat) #f))) - (common:wait-for-normalized-load maxnormload msg hh))) - -(define *numcpus-cache* (make-hash-table)) + (let loop ((start-time (current-seconds))) ;; we saw some instances of this being called before *toppath* was set. This might be an early setup race. This delay should help but it is impossible to test... + (if (not *toppath*) + (begin + (debug:print 0 *default-log-port* "ERROR: common:wait-for-homehost-load called before *toppath* set.") + (thread-sleep! 30) + (if (< (- (current-seconds) start-time) 300) + (loop start-time))))) + (case (rmt:transport-mode) + ((http) + (let* ((hh-dat (if (common:on-homehost?) ;; if we are on the homehost then pass in #f so the calls are local. + #f + (server:choose-server *toppath* 'homehost))) + (hh (if hh-dat (car hh-dat) #f))) + (common:wait-for-normalized-load maxnormload msg hh))) + (else + (common:wait-for-normalized-load maxnormload msg (get-host-name))))) + (define (common:get-num-cpus remote-host) (let* ((actual-host (or remote-host (get-host-name)))) ;; hosts had better not be changing the number of cpus too often! (or (hash-table-ref/default *numcpus-cache* actual-host #f) (let* ((numcpus (or (common:get-cached-info actual-host "num-cpus" age: (+ 2592000 (random 3600))) @@ -2142,22 +2008,24 @@ #f) ;; if zero return #f so caller knows that things are not working (loop (if (string-match "^processor\\s+:\\s+\\d+$" inl) (+ numcpu 1) numcpu) (read-line)))))) - (result (if remote-host - (with-input-from-pipe + (result (if (and remote-host + (not (equal? remote-host (get-host-name)))) + (common:generic-ssh (conc "ssh " remote-host " cat /proc/cpuinfo") - proc) + proc -1) (with-input-from-file "/proc/cpuinfo" proc)))) (if (and (number? result) (> result 0)) (common:write-cached-info actual-host "num-cpus" result)) result)))) (hash-table-set! *numcpus-cache* actual-host numcpus) numcpus)))) +;;====================================================================== ;; wait for normalized cpu load to drop below maxload ;; (define (common:wait-for-normalized-load maxnormload msg remote-host #!optional (rem-tries 5)) (let ((num-cpus (common:get-num-cpus remote-host))) (if num-cpus @@ -2166,58 +2034,55 @@ (thread-sleep! (random 60)) ;; we failed to get num cpus. wait a bit and try again (if (> rem-tries 0) (common:wait-for-normalized-load maxnormload msg remote-host (- rem-tries 1)) #f))))) +;;====================================================================== ;; DO NOT CALL THIS DIRECTLY. It is called from common:wait-for-normalized-load ;; count - count down to zero, at some point we'd give up if the load never drops ;; num-tries - count down to zero number tries to get numcpus ;; (define (common:wait-for-cpuload maxnormload numcpus-in #!key (count 1000) (msg #f)(remote-host #f)(num-tries 5)) (let* ((loadavg (common:get-cpu-load remote-host)) - ;; not possible to have zero. If we get 1, it's possible that we got the previous default, and we should check again - (numcpus (if (<= 1 numcpus-in) - (common:get-num-cpus remote-host) - numcpus-in)) - (first (car loadavg)) - (next (cadr loadavg)) - (adjmaxload (* maxnormload (max 1 numcpus))) ;; possible bug - ;; where numcpus - ;; (or could be - ;; maxload) is - ;; zero, crude - ;; fallback is to - ;; at least use 1 - ;; effective load accounts for load jumps, this should elminate all the first-next-avg, adjwait, load-jump-limit - ;; etc. - (effective-load (common:get-intercept first next)) - (recommended-delay (common:get-delay effective-load numcpus)) - (effective-host (or remote-host "localhost")) - (normalized-effective-load (/ effective-load numcpus)) - (will-wait (> normalized-effective-load maxnormload))) - (if (> recommended-delay 0) - (let* ((actual-delay (min recommended-delay 30))) - (if (common:low-noise-print 30 (conc (round actual-delay) "-safe-load")) - (debug:print-info 0 *default-log-port* "Load control, delaying " + ;; not possible to have zero. If we get 1, it's possible that we got the previous default, and we should check again + (numcpus (if (<= 1 numcpus-in) + (common:get-num-cpus remote-host) numcpus-in)) + (first (car loadavg)) + (next (cadr loadavg)) + (adjmaxload (* maxnormload (max 1 numcpus))) ;; possible bug where numcpus (or could be maxload) is zero, crude + ;; fallback is to at least use 1 + ;; effective load accounts for load jumps, this should elminate all the first-next-avg, adjwait, load-jump-limit + ;; etc. + (effective-load (common:get-intercept first next)) + (recommended-delay (common:get-delay effective-load numcpus)) + (effective-host (or remote-host "localhost")) + (normalized-effective-load (/ effective-load numcpus)) + (will-wait (> normalized-effective-load maxnormload))) + (if (and will-wait (> recommended-delay 1)) + (let* ((actual-delay (min recommended-delay 30))) + (if (common:low-noise-print 30 (conc (round actual-delay) "-safe-load")) + (debug:print-info 0 *default-log-port* "Load control, delaying " actual-delay " seconds to maintain safe load. current normalized effective load is " - normalized-effective-load".")) - (thread-sleep! actual-delay))) + normalized-effective-load". maxnormload = " maxnormload " numcpus = " numcpus " loadavg = " loadavg " effective-load = " effective-load)) + (thread-sleep! actual-delay))) (cond ;; bad data, try again to get the data ((not will-wait) - (if (common:low-noise-print 30 (conc (round normalized-effective-load) "-load-acceptable-" effective-host)) - (debug:print 0 *default-log-port* "Effective load on " effective-host " is acceptable at " effective-load " continuing."))) + (if (common:low-noise-print 3600 (conc (round normalized-effective-load) "-load-acceptable-" effective-host)) + (debug:print 0 *default-log-port* "Effective load on " effective-host " is acceptable at " effective-load " continuing."))) + ((and (< first 0) ;; this indicates the loadavg data is bad - machine may not be reachable (> num-tries 0)) (debug:print 0 *default-log-port* "WARNING: received bad data from get-cpu-load " first ", we'll sleep 10s and try " num-tries " more times.") (thread-sleep! 10) (common:wait-for-cpuload maxnormload numcpus-in count: count remote-host: remote-host num-tries: (- num-tries 1))) + ;; need to wait for load to drop ((and will-wait ;; (> first adjmaxload) (> count 0)) (debug:print-info 0 *default-log-port* "Delaying 15" ;; adjwait @@ -2241,10 +2106,11 @@ (debug:print 0 *default-log-port* "Load on " effective-host " is acceptable at effective normalized load of " effective-normalized-load " continuing.")) (debug:print 0 *default-log-port* "Load on " effective-host ", " first" could not be retrieved. Giving up and continuing.")))))) +;;====================================================================== ;; DO NOT CALL THIS DIRECTLY. It is called from common:wait-for-normalized-load ;; ;; (define (common:wait-for-cpuload maxload-in numcpus-in waitdelay #!key (count 1000) (msg #f)(remote-host #f)(force-maxload #f)(num-tries 5)) ;; (let* ((loadavg (common:get-cpu-load remote-host)) ;; (numcpus (if (<= 1 numcpus-in) ;; not possible to have zero. If we get 1, it's possible that we got the previous default, and we should check again @@ -2333,37 +2199,18 @@ (uname #f)) (if (null? (car uname-res)) "unknown" (caar uname-res)))) -;; for reasons I don't understand multiple calls to real-path in parallel threads -;; must be protected by mutexes -;; -(define (common:real-path inpath) - ;; (process:cmd-run-with-stderr->list "readlink" "-f" inpath)) ;; cmd . params) - ;; (let-values - ;; (((inp oup pid) (process "readlink" (list "-f" inpath)))) - ;; (with-input-from-port inp - ;; (let loop ((inl (read-line)) - ;; (res #f)) - ;; (print "inl=" inl) - ;; (if (eof-object? inl) - ;; (begin - ;; (close-input-port inp) - ;; (close-output-port oup) - ;; ;; (process-wait pid) - ;; res) - ;; (loop (read-line) inl)))))) - (with-input-from-pipe (conc "readlink -f " inpath) read-line)) - ;;====================================================================== ;; D I S K S P A C E ;;====================================================================== (define (common:get-disk-space-used fpath) (with-input-from-pipe (conc "/usr/bin/du -s " fpath) read)) +;;====================================================================== ;; given path get free space, allows override in [setup] ;; with free-space-script /path/to/some/script.sh ;; (define (get-df path) (if (configf:lookup *configdat* "setup" "free-space-script") @@ -2420,24 +2267,26 @@ (list (> dbspace required) dbspace required dirpath))) +;;====================================================================== ;; check space in dbdir and in megatest dir ;; returns: ok/not dbspace required-space ;; (define (common:check-db-dir-space) (let* ((required (string->number ;; default is 1GB (or actually a billion bytes) This is the number of 1 kB blocks. (or (configf:lookup *configdat* "setup" "dbdir-space-required") "1000000"))) - (dbdir (common:get-db-tmp-area)) ;; (db:get-dbdir)) + (dbdir (common:make-tmpdir-name *toppath* "")) ;; (db:get-dbdir)) (tdbspace (common:check-space-in-dir dbdir required)) (mdbspace (common:check-space-in-dir *toppath* required))) (sort (list tdbspace mdbspace) (lambda (a b) (< (cadr a)(cadr b)))))) - + +;;====================================================================== ;; check available space in dbdir, exit if insufficient ;; (define (common:check-db-dir-and-exit-if-insufficient) (let* ((spacedat (car (common:check-db-dir-space))) ;; look only at worst for now (is-ok (car spacedat)) @@ -2446,11 +2295,12 @@ (dbdir (cadddr spacedat))) (if (not is-ok) (begin (debug:print-error 0 *default-log-port* "Insufficient space in " dbdir ", require " required ", have " dbspace ", exiting now.") (exit 1))))) - + +;;====================================================================== ;; paths is list of lists ((name path) ... ) ;; (define (common:get-disk-with-most-free-space disks minsize) (let* ((best #f) (bestsize 0) @@ -2503,10 +2353,11 @@ (map car disks)) (if (and best (> bestsize minsize)) best #f))) ;; #f means no disk candidate found +;;====================================================================== ;; convert a spec string to a list of vectors #( rx action rx-string ) (define (common:spec-string->list-of-specs spec-string actions) (let ((spec-strings (string-split-fields "\\s*;\\s*" spec-string #:infix)) (actions-regex (regexp (conc "^(.*)\\s+(" (string-intersperse (map conc actions) "|") ")")))) (filter @@ -2518,10 +2369,11 @@ (begin (debug:print 0 *default-log-port* "WARNING: Unrecognised rule \"" s "\" in clean-up specification.") #f)))) spec-strings)))) +;;====================================================================== ;; given a list of specs rx . rule and a file return the first matching rule ;; (define (common:file-find-rule fname rules) ;; rule is vector #( rx action rx-string) (let loop ((rule (car rules)) (tail (cdr rules))) @@ -2531,10 +2383,11 @@ rule ;; return the whole rule so regex can be printed etc. (if (null? tail) #f (loop (car tail)(cdr tail))))))) +;;====================================================================== ;; given a spec apply some rules to a directory ;; ;; WARNING: This function will REMOVE files - be sure your spec and path is correct! ;; ;; spec format: @@ -2562,39 +2415,32 @@ ((directory? p)(hash-table-set! directories p #t)) (else (case (vector-ref rule 1) ((keep)(hash-table-set! keepers p rule)) ((remove) - (print "Removing file " p) + (debug:print 0 *default-log-port* "Removing file " p) (delete-file p)) ((compress) - (print "Compressing file " p) + (debug:print 0 *default-log-port* "Compressing file " p) (system (conc compress " " p))) (else - (print "No match for file " p)))))))) + (debug:print 0 *default-log-port* "No match for file " p)))))))) (if remove-empty (for-each (lambda (d) (if (null? (glob (conc d "/.*")(conc d "/*"))) (begin - (print "Removing empty directory " d) + (debug:print 0 *default-log-port* "Removing empty directory " d) (delete-directory d)))) (sort (hash-table-keys directories) (lambda (a b)(> (string-length a)(string-length b)))))) )) ;;====================================================================== ;; E N V I R O N M E N T V A R S ;;====================================================================== -(define (bb-check-path #!key (msg "check-path: ")) - (let ((path (or (get-environment-variable "PATH") "none"))) - (debug:print-info 0 *default-log-port* (conc msg" : $PATH="path)) - (if (string-match "^.*/isoenv-core/.*" path) - (debug:print-error 0 *default-log-port* (conc msg" : !!ISOENV PRESENT!!")) ;; remove for prod - (debug:print-info 1 *default-log-port* (conc msg" : **no isoenv present**"))))) - - -(define (save-environment-as-files fname #!key (ignorevars (list "USER" "HOME" "DISPLAY" "LS_COLORS" "XKEYSYMDB" "EDITOR" "MAKEFLAGS" "MAKEF" "MAKEOVERRIDES"))) + +(define (save-environment-as-files fname #!key (ignorevars (list "USER" "HOME" "DISPLAY" "LS_COLORS" "XKEYSYMDB" "EDITOR" "MAKEFLAGS" "MAKEF" "MAKEOVERRIDES" "HOSTNAME" "PROMPT_COMMAND"))) ;;(bb-check-path msg: "save-environment-as-files entry") (let ((envvars (get-environment-variables)) (whitesp (regexp "[^a-zA-Z0-9_\\-:,\\.\\/%$]")) (mungeval (lambda (val) (cond @@ -2604,13 +2450,16 @@ (with-output-to-file (conc fname ".csh") (lambda () (for-each (lambda (keyval) (let* ((key (car keyval)) (val (cdr keyval)) - (delim (if (string-search whitesp val) + (delim (if (and (string-search whitesp val) + (not (string-search "^\".*\"$" val)) + (not (string-search "^'.*'$" val))) "\"" ""))) + (print (if (or (member key ignorevars) (string-search whitesp key)) "# setenv " "setenv ") key " " delim (mungeval val) delim))) @@ -2618,11 +2467,13 @@ (with-output-to-file (conc fname ".sh") (lambda () (for-each (lambda (keyval) (let* ((key (car keyval)) (val (cdr keyval)) - (delim (if (string-search whitesp val) + (delim (if (and (string-search whitesp val) + (not (string-search "^\".*\"$" val)) + (not (string-search "^'.*'$" val))) "\"" ""))) (print (if (or (member key ignorevars) (string-search whitesp key) (string-search ":" key)) ;; internal only values to be skipped. @@ -2629,21 +2480,18 @@ "# export " "export ") key "=" delim (mungeval val) delim))) envvars))))) - (define (common:get-param-mapping #!key (flavor #f)) "returns alist mapping string keys in testconfig/subrun to megatest command line switches; if flavor is switch-symbol, maps tcmt symbolic switches to megatest switches" (let ((default '(("tag-expr" . "-tagexpr") ("mode-patt" . "-modepatt") ("run-name" . "-runname") ("contour" . "-contour") ("target" . "-target") ("test-patt" . "-testpatt") - ("rerun" . "-rerun") - ("setvars" . "-setvars") ("msg" . "-m") ("log" . "-log") ("start-dir" . "-start-dir") ("new" . "-set-state-status")))) (if (eq? flavor 'switch-symbol) @@ -2650,10 +2498,11 @@ (map (lambda (x) (cons (string->symbol (conc "-" (car x))) (cdr x))) default) default))) +;;====================================================================== ;; set some env vars from an alist, return an alist with original values ;; (("VAR" "value") ...) ;; a value of #f means "unset this var" ;; (define (alist->env-vars lst) @@ -2669,11 +2518,11 @@ (unsetenv var)))) lst) res) '())) - +;;====================================================================== ;; clear vars matching pattern, run proc, set vars back ;; if proc is a string run that string as a command with ;; system. ;; (define *common:orig-env* @@ -2718,40 +2567,10 @@ (hash-table-for-each vars (lambda (var val) (setenv var val))) vars)) - -(define (common:propogate-mt-vars-to-subrun proc propogate-vars) - (let ((vars (make-hash-table)) - (var-patt "^MT_.*")) - (for-each - (lambda (vardat) ;; each env var - ;(for-each - ;(lambda (var-patt) - (if (string-match var-patt (car vardat)) - (let ((var (car vardat)) - (val (cdr vardat))) - (hash-table-set! vars var val) - (if (member var propogate-vars) - (begin - (print var " " (string-substitute "MT_" "PARENT_" var)) - (setenv (string-substitute "MT_" "PARENT_" var) val))) - (unsetenv var)))) -; var-patts)) - (get-environment-variables)) - (cond - ((string? proc)(system proc)) - (proc (proc))) - (hash-table-for-each - vars - (lambda (var val) - (if (member var propogate-vars) - (unsetenv (string-substitute "MT_" "PARENT_" var))) - (setenv var val))) - vars)) - (define (common:run-a-command cmd #!key (with-vars #f) (with-orig-env #f)) (let* ((pre-cmd (dtests:get-pre-command)) (post-cmd (dtests:get-post-command)) (fullcmd (if (or pre-cmd post-cmd) @@ -2761,286 +2580,10 @@ (cond (with-vars (common:without-vars fullcmd)) (with-orig-env (common:with-orig-env fullcmd)) (else (common:without-vars fullcmd "MT_.*"))))) -;;====================================================================== -;; T I M E A N D D A T E -;;====================================================================== - -;; Convert strings like "5s 2h 3m" => 60x60x2 + 3x60 + 5 -(define (common:hms-string->seconds tstr) - (let ((parts (string-split-fields "\\w+" tstr)) - (time-secs 0) - ;; s=seconds, m=minutes, h=hours, d=days, M=months, y=years, w=weeks - (trx (regexp "(\\d+)([smhdMyw])"))) - (for-each (lambda (part) - (let ((match (string-match trx part))) - (if match - (let ((val (string->number (cadr match))) - (unt (caddr match))) - (if val - (set! time-secs (+ time-secs (* val - (case (string->symbol unt) - ((s) 1) - ((m) 60) ;; minutes - ((h) 3600) - ((d) 86400) - ((w) 604800) - ((M) 2628000) ;; aproximately one month - ((y) 31536000) - (else #f)))))))))) - parts) - time-secs)) - -(define (seconds->hr-min-sec secs) - (let* ((hrs (quotient secs 3600)) - (min (quotient (- secs (* hrs 3600)) 60)) - (sec (- secs (* hrs 3600)(* min 60)))) - (conc (if (> hrs 0)(conc hrs "hr ") "") - (if (> min 0)(conc min "m ") "") - sec "s"))) - -(define (seconds->time-string sec) - (time->string - (seconds->local-time sec) "%H:%M:%S")) - -(define (seconds->work-week/day-time sec) - (time->string - (seconds->local-time sec) "ww%V.%u %H:%M")) - -(define (seconds->work-week/day sec) - (time->string - (seconds->local-time sec) "ww%V.%u")) - -(define (seconds->year-work-week/day sec) - (time->string - (seconds->local-time sec) "%yww%V.%w")) - -(define (seconds->year-work-week/day-time sec) - (time->string - (seconds->local-time sec) "%Yww%V.%w %H:%M")) - -(define (seconds->year-week/day-time sec) - (time->string - (seconds->local-time sec) "%Yw%V.%w %H:%M")) - -(define (seconds->quarter sec) - (case (string->number - (time->string - (seconds->local-time sec) - "%m")) - ((1 2 3) 1) - ((4 5 6) 2) - ((7 8 9) 3) - ((10 11 12) 4) - (else #f))) - -;; basic ISO8601 format (e.g. "2017-02-28 06:02:54") date time => Unix epoch -;; -(define (common:date-time->seconds datetime) - (local-time->seconds (string->time datetime "%Y-%m-%d %H:%M:%S"))) - -;; given span of seconds tstart to tend -;; find start time to mark and mark delta -;; -(define (common:find-start-mark-and-mark-delta tstart tend) - (let* ((deltat (- (max tend (+ tend 10)) tstart)) ;; can't handle runs of less than 4 seconds. Pad it to 10 seconds ... - (result #f) - (min 60) - (hr (* 60 60)) - (day (* 24 hr)) - (yr (* 365 day)) ;; year - (mo (/ yr 12)) - (wk (* day 7))) - (for-each - (lambda (max-blks) - (for-each - (lambda (span) ;; 5 2 1 - (if (not result) - (for-each - (lambda (timeunit timesym) ;; year month day hr min sec - (if (not result) - (let* ((time-blk (* span timeunit)) - (num-blks (quotient deltat time-blk))) - (if (and (> num-blks 4)(< num-blks max-blks)) - (let ((first (* (quotient tstart time-blk) time-blk))) - (set! result (list span timeunit time-blk first timesym)) - ))))) - (list yr mo wk day hr min 1) - '( y mo w d h m s)))) - (list 8 6 5 2 1))) - '(5 10 15 20 30 40 50 500)) - (if values - (apply values result) - (values 0 day 1 0 'd)))) - -;; given x y lim return the cron expansion -;; -(define (common:expand-cron-slash x y lim) - (let loop ((curr x) - (res `())) - (if (< curr lim) - (loop (+ curr y) (cons curr res)) - (reverse res)))) - -;; expand a complex cron string to a list of cron strings -;; -;; x/y => x, x+y, x+2y, x+3y while x+Ny a, b ,c -;; -;; NOTE: with flatten a lot of the crud below can be factored down. -;; -(define (common:cron-expand cron-str) - (if (list? cron-str) - (flatten - (fold (lambda (x res) - (if (list? x) - (let ((newres (map common:cron-expand x))) - (append x newres)) - (cons x res))) - '() - cron-str)) ;; (map common:cron-expand cron-str)) - (let ((cron-items (string-split cron-str)) - (slash-rx (regexp "(\\d+)/(\\d+)")) - (comma-rx (regexp ".*,.*")) - (max-vals '((min . 60) - (hour . 24) - (dayofmonth . 28) ;;; BUG!!!! This will be a bug for some combinations - (month . 12) - (dayofweek . 7)))) - (if (< (length cron-items) 5) ;; bad spec - cron-str ;; `(,cron-str) ;; just return the string, something downstream will fix it - (let loop ((hed (car cron-items)) - (tal (cdr cron-items)) - (type 'min) - (type-tal '(hour dayofmonth month dayofweek)) - (res '())) - (regex-case - hed - (slash-rx ( _ base incr ) (let* ((basen (string->number base)) - (incrn (string->number incr)) - (expanded-vals (common:expand-cron-slash basen incrn (alist-ref type max-vals))) - (new-list-crons (fold (lambda (x myres) - (cons (conc (if (null? res) - "" - (conc (string-intersperse res " ") " ")) - x " " (string-intersperse tal " ")) - myres)) - '() expanded-vals))) - ;; (print "new-list-crons: " new-list-crons) - ;; (fold (lambda (x res) - ;; (if (list? x) - ;; (let ((newres (map common:cron-expand x))) - ;; (append x newres)) - ;; (cons x res))) - ;; '() - (flatten (map common:cron-expand new-list-crons)))) - ;; (map common:cron-expand (map common:cron-expand new-list-crons)))) - (else (if (null? tal) - cron-str - (loop (car tal)(cdr tal)(car type-tal)(cdr type-tal)(append res (list hed))))))))))) - - -;; given a cron string and the last time event was processed return #t to run or #f to not run -;; -;; min hour dayofmonth month dayofweek -;; 0-59 0-23 1-31 1-12 0-6 ### NOTE: dayofweek does not include 7 -;; -;; #t => yes, run the job -;; #f => no, do not run the job -;; -(define (common:cron-event cron-str now-seconds-in last-done) ;; ref-seconds = #f is NOW. - (let* ((cron-items (map string->number (string-split cron-str))) - (now-seconds (or now-seconds-in (current-seconds))) - (now-time (seconds->local-time now-seconds)) - (last-done-time (seconds->local-time last-done)) - (all-times (make-hash-table))) - ;; (print "cron-items: " cron-items "(length cron-items): " (length cron-items)) - (if (not (eq? (length cron-items) 5)) ;; don't even try to figure out junk strings - #f - (match-let ((( cmin chour cdayofmonth cmonth cdayofweek) - cron-items) - ;; 0 1 2 3 4 5 6 - ((nsec nmin nhour ndayofmonth nmonth nyr ndayofweek n7 n8 n9) - (vector->list now-time)) - ((lsec lmin lhour ldayofmonth lmonth lyr ldayofweek l7 l8 l9) - (vector->list last-done-time))) - ;; create all possible time slots - ;; remove invalid slots due to (for example) day of week - ;; get the start and end entries for the ref-seconds (current) time - ;; if last-done > ref-seconds => this is an ERROR! - ;; does the last-done time fall in the legit region? - ;; yes => #f do not run again this command - ;; no => #t ok to run the command - (for-each ;; month - (lambda (month) - (for-each ;; dayofmonth - (lambda (dom) - (for-each - (lambda (hr) ;; hour - (for-each - (lambda (minute) ;; minute - (let ((copy-now (apply vector (vector->list now-time)))) - (vector-set! copy-now 0 0) ;; force seconds to zero - (vector-set! copy-now 1 minute) - (vector-set! copy-now 2 hr) - (vector-set! copy-now 3 dom) ;; dom is already corrected for zero referenced - (vector-set! copy-now 4 month) - (let* ((copy-now-secs (local-time->seconds copy-now)) - (new-copy (seconds->local-time copy-now-secs))) ;; remake the time vector - (if (or (not cdayofweek) - (equal? (vector-ref new-copy 6) - cdayofweek)) ;; if the day is specified and a match OR if the day is NOT specified - (if (or (not cdayofmonth) - (equal? (vector-ref new-copy 3) - (+ 1 cdayofmonth))) ;; if the month is specified and a match OR if the month is NOT specified - (hash-table-set! all-times copy-now-secs new-copy)))))) - (if cmin - `(,cmin) ;; if given cmin, have to use it - (list (- nmin 1) nmin (+ nmin 1))))) ;; minute - (if chour - `(,chour) - (list (- nhour 1) nhour (+ nhour 1))))) ;; hour - (if cdayofmonth - `(,cdayofmonth) - (list (- ndayofmonth 1) ndayofmonth (+ ndayofmonth 1))))) - (if cmonth - `(,cmonth) - (list (- nmonth 1) nmonth (+ nmonth 1)))) - (let ((before #f) - (is-in #f)) - (for-each - (lambda (moment) - (if (and before - (<= before now-seconds) - (>= moment now-seconds)) - (begin - ;; (print) - ;; (print "Before: " (time->string (seconds->local-time before))) - ;; (print "Now: " (time->string (seconds->local-time now-seconds))) - ;; (print "After: " (time->string (seconds->local-time moment))) - ;; (print "Last: " (time->string (seconds->local-time last-done))) - (if (< last-done before) - (set! is-in before)) - )) - (set! before moment)) - (sort (hash-table-keys all-times) <)) - is-in))))) - -(define (common:extended-cron cron-str now-seconds-in last-done) - (let ((expanded-cron (common:cron-expand cron-str))) - (if (string? expanded-cron) - (common:cron-event expanded-cron now-seconds-in last-done) - (let loop ((hed (car expanded-cron)) - (tal (cdr expanded-cron))) - (if (common:cron-event hed now-seconds-in last-done) - #t - (if (null? tal) - #f - (loop (car tal)(cdr tal)))))))) - ;;====================================================================== ;; C O L O R S ;;====================================================================== (define (common:name->iup-color name) @@ -3048,10 +2591,11 @@ ((red) "223 33 49") ((grey) "192 192 192") ((orange) "255 172 13") ((purple) "This is unfinished ..."))) +;;====================================================================== ;; (define (common:get-color-for-state-status state status) ;; (case (string->symbol state) ;; ((COMPLETED) ;; (case (string->symbol status) ;; ((PASS) "70 249 73") @@ -3077,10 +2621,11 @@ ;;====================================================================== ;; L O C K I N G M E C H A N I S M S ;;====================================================================== +;;====================================================================== ;; faux-lock is deprecated. Please use simple-lock below ;; (define (common:faux-lock keyname #!key (wait-time 8)(allow-lock-steal #t)) (if (rmt:no-sync-get/default keyname #f) ;; do not be tempted to compare to pid. locking is a one-shot action, if already locked for this pid it doesn't actually count (if (> wait-time 0) @@ -3101,18 +2646,18 @@ (begin (if (rmt:no-sync-get/default keyname #f) (rmt:no-sync-del! keyname)) #t) #f)) +;;====================================================================== ;; simple lock. improve and converge on this one. ;; (define (common:simple-lock keyname) (rmt:no-sync-get-lock keyname)) (define (common:simple-unlock keyname #!key (force #f)) (rmt:no-sync-del! keyname)) - ;;====================================================================== ;; ;;====================================================================== @@ -3128,13 +2673,13 @@ ((equal? status "KILLREQ") "purple") ((equal? status "RUNNING") "blue") ((equal? status "ABORT") "brown") (else "black"))) -;; ;;====================================================================== -;; ;; N A N O M S G C L I E N T -;; ;;====================================================================== +;;====================================================================== +;; N A N O M S G C L I E N T +;;====================================================================== ;; ;; ;; ;; (define (common:send-dboard-main-changed) ;; (let* ((dashboard-ips (mddb:get-dashboards))) @@ -3286,52 +2831,15 @@ (if (null? tal) fallback-launcher (loop (car tal)(cdr tal)))))))) fallback-launcher))) -;;====================================================================== -;; NMSG AND NEW API -;;====================================================================== - -;; nm based server experiment, keep around for now. -;; -(define (nm:start-server dbconn #!key (given-host-name #f)) - (let* ((srvdat (start-raw-server given-host-name: given-host-name)) - (host-name (srvdat-host srvdat)) - (soc (srvdat-soc srvdat))) - - ;; start the queue processor (save for second round of development) - ;; - (thread-start! (make-thread! (lambda ()(queue-processor dbconn) "Queue processor"))) - ;; msg is an alist - ;; 'r host:port <== where to return the data - ;; 'p params <== data to apply the command to - ;; 'e j|s|l <== encoding of the params. default is s (sexp), if not specified is assumed to be default - ;; 'c command <== look up the function to call using this key - ;; - (let loop ((msg-in (nn-recv soc))) - (if (not (equal? msg-in "quit")) - (let* ((dat (decode msg-in)) - (host-port (alist-ref 'r dat)) ;; this is for the reverse req rep where the server is a client of the original client - (params (alist-ref 'p dat)) - (command (let ((c (alist-ref 'c dat)))(if c (string->symbol c) #f))) - (all-good (and host-port params command (hash-table-exists? *commands* command)))) - (if all-good - (let ((cmddat (make-qitem - command: command - host-port: host-port - params: params))) - (queue-push cmddat) ;; put request into the queue - (nn-send soc "queued")) ;; reply with "queued" - (print "ERROR: ["(common:human-time)"] BAD request " dat)) - (loop (nn-recv soc))))) - (nn-close soc))) - ;;====================================================================== ;; D A S H B O A R D U S E R V I E W S ;;====================================================================== +;;====================================================================== ;; first read ~/views.config if it exists, then read $MTRAH/views.config if it exists ;; (define (common:load-views-config) (let* ((view-cfgdat (make-hash-table)) (home-cfgfile (conc (get-environment-variable "HOME") "/.mtviews.config")) @@ -3344,23 +2852,25 @@ view-cfgdat)) ;;====================================================================== ;; H I E R A R C H I C A L H A S H T A B L E S ;;====================================================================== - +;; ;; Every element including top element is a vector: ;; (define (hh:make-hh #!key (ht #f)(value #f)) (vector (or ht (make-hash-table)) value)) +;;====================================================================== ;; used internally (define-inline (hh:set-ht! hh ht) (vector-set! hh 0 ht)) (define-inline (hh:get-ht hh) (vector-ref hh 0)) (define-inline (hh:set-value! hh value) (vector-set! hh 1 value)) (define-inline (hh:get-value hh value) (vector-ref hh 1)) +;;====================================================================== ;; given a hierarchial hash and some keys look up the value ... ;; (define (hh:get hh . keys) (if (null? keys) (vector-ref hh 1) ;; we have reached the end of the line, return the value sought @@ -3370,10 +2880,11 @@ (if sub-hh (apply hh:get sub-hh (cdr keys)) #f)) #f)))) +;;====================================================================== ;; given a hierarchial hash, a value and some keys, add needed hierarcy and insert the value ;; (define (hh:set! hh value . keys) (if (null? keys) (hh:set-value! hh value) ;; we have reached the end of the line, store the value @@ -3386,11 +2897,12 @@ (apply hh:set! new-sub-hh value (cdr keys))) (apply hh:set! sub-hh value (cdr keys)))) ;; call the sub-hierhash with remaining keys (begin (hh:set-ht! hh (make-hash-table)) (apply hh:set! hh value keys)))))) - + +;;====================================================================== ;; Manage pkts, used in servers, tests and likely other contexts so put ;; in common ;;====================================================================== (define common:pkts-spec @@ -3424,13 +2936,14 @@ (pktsdirs (if pktsdirs-str (string-split pktsdirs-str " ") #f))) pktsdirs)) +;;====================================================================== ;; use-lt is use linktree "lt" link to find pkts dir (define (common:save-pkt pktalist-in mtconf use-lt #!key (add-only #f)) ;; add-only saves the pkt only if there is a parent already - (if (or add-only + (if (or (not add-only) (hash-table-exists? *pkts-info* 'last-parent)) (let* ((parent (hash-table-ref/default *pkts-info* 'last-parent #f)) (pktalist (if parent (cons `(parent . ,parent) pktalist-in) @@ -3441,10 +2954,11 @@ (let ((pktsdir (or (hash-table-ref/default *pkts-info* 'pkts-dir #f) (let* ((pktsdirs (common:get-pkts-dirs mtconf use-lt)) (pktsdir (car pktsdirs))) ;; assume it is there (hash-table-set! *pkts-info* 'pkts-dir pktsdir) pktsdir)))) + (debug:print 0 *default-log-port* "pktsdir: "pktsdir) (handle-exceptions exn (debug:print-info 0 "failed to write out packet to " pktsdir ", exn=" exn) ;; don't care if this failed for now but MUST FIX - BUG!! (if (not (file-exists? pktsdir)) (create-directory pktsdir #t)) @@ -3486,11 +3000,17 @@ (debug:print 0 *default-log-port* "ERROR: packets directory path " pktsdir " is not a directory.")) ((not (file-read-access? pktsdir)) (debug:print 0 *default-log-port* "ERROR: packets directory path " pktsdir " is not readable.")) (else (debug:print-info 0 *default-log-port* "Loading packets found in " pktsdir) - (let ((pkts (glob (conc pktsdir "/*.pkt")))) + (let ((pkts (glob (conc pktsdir "/*.pkt"))) + (sqdb (dbi:db-conn pdb)) + ) + ;; Put this in a transaction to avoid issues overloading the db + (sqlite3:with-transaction + sqdb + (lambda () (for-each (lambda (pkt) (let* ((uuid (cadr (string-match ".*/([0-9a-f]+).pkt" pkt))) (exists (lookup-by-uuid pdb uuid #f))) (if (not exists) @@ -3501,19 +3021,20 @@ (ptype (alist-ref 'T apkt))) (add-to-queue pdb pktdat uuid (or ptype 'cmd) #f 0) (debug:print 4 *default-log-port* "Added " uuid " of type " ptype " to queue")) (debug:print 4 *default-log-port* "pkt: " uuid " exists, skipping...") ))) - pkts))))) + pkts))))))) pktsdirs)) use-lt: use-lt)) (define (common:get-pkt-alists pkts) (map (lambda (x) (alist-ref 'apkt x)) ;; 'pkta pulls out the alist from the read pkt pkts)) +;;====================================================================== ;; given list of pkts (alist mode) return list of D cards as Unix epoch, sorted descending ;; also delete duplicates by target i.e. (car pkt) ;; (define (common:get-pkt-times pkts) (delete-duplicates @@ -3522,12 +3043,11 @@ `(,(alist-ref 't x) . ,(string->number (alist-ref 'D x)))) pkts) (lambda (a b)(> (cdr a)(cdr b)))) ;; sort descending (lambda (a b)(equal? (car a)(car b))))) ;; remove duplicates by target - - +;;====================================================================== ;; accept an alist or hash table containing envvar/env value pairs (value of #f causes unset) ;; execute thunk in context of environment modified as per this list ;; restore env to prior state then return value of eval'd thunk. ;; ** this is not thread safe ** (define (common:with-env-vars delta-env-alist-or-hash-table thunk) @@ -3567,11 +3087,10 @@ rv))) (define *common:thread-punchlist* (make-hash-table)) (define (common:send-thunk-to-background-thread thunk #!key (name #f)) ;;(BB> "launched thread " name) - ;; we need a unique name for the thread. (let* ((realname (if name (if (not (hash-table-ref/default *common:thread-punchlist* name #f)) name (conc name"-" (symbol->string (gensym)))) @@ -3598,68 +3117,69 @@ #t) ;; just ignore it, it might have died in the meantime so joining it will throw an exception (thread-join! thread)) ))) (hash-table-keys *common:thread-punchlist*))) -(define *common:telemetry-log-state* 'startup) -(define *common:telemetry-log-socket* #f) - -(define (common:telemetry-log-open) - (if (eq? *common:telemetry-log-state* 'startup) - (let* ((serverhost (configf:lookup *configdat* "telemetry" "host")) - (serverport (configf:lookup-number *configdat* "telemetry" "port")) - (user (or (get-environment-variable "USER") "unknown")) - (host (or (get-environment-variable "HOST") "unknown"))) - (set! *common:telemetry-log-state* - (handle-exceptions - exn - (begin - (debug:print-info 0 *default-log-port* "common-telemetry-log open udp port failure") - 'broken) - (if (and serverhost serverport user host) - (let* ((s (udp-open-socket))) - ;;(udp-bind! s #f 0) - (udp-connect! s serverhost serverport) - (set! *common:telemetry-log-socket* s) - 'open) - 'not-needed)))))) - -(define (common:telemetry-log event #!key (payload '())) - (if (eq? *common:telemetry-log-state* 'startup) - (common:telemetry-log-open)) - - (if (eq? 'open *common:telemetry-log-state*) - (handle-exceptions - exn - (begin - (debug:print-info 0 *default-log-port* "common-telemetry-log comms failure ; disabled (no server?)") - ;;(define *common:telemetry-log-state* 'broken-or-no-server-preclose) - ;;(common:telemetry-log-close) - (define *common:telemetry-log-state* 'broken-or-no-server) - (set! *common:telemetry-log-socket* #f) - ) - (if (and *common:telemetry-log-socket* event) ;; TODO - filter on event against telemetry.want-events - (let* ((user (or (get-environment-variable "USER") "unknown")) - (host (or (get-environment-variable "HOST") "unknown")) - (start (conc "[megatest "event"]")) - (toppath (or *toppath* "/dev/null")) - (payload-serialized - (base64:base64-encode - (z3:encode-buffer - (with-output-to-string (lambda () (pp payload)))))) - (msg (conc user":"host":"start":"(current-process-id)":"(car (argv))":" - toppath":"payload-serialized))) - (udp-send *common:telemetry-log-socket* msg)))))) - -(define (common:telemetry-log-close) - (when (or (member *common:telemetry-log-state* '(broken-or-no-server-preclose open)) *common:telemetry-log-socket*) - (handle-exceptions - exn - (begin - (define *common:telemetry-log-state* 'closed-fail) - (debug:print-info 0 *default-log-port* "common-telemetry-log closure failure") - ) - (begin - (define *common:telemetry-log-state* 'closed) - (udp-close-socket *common:telemetry-log-socket*) - (set! *common:telemetry-log-socket* #f))))) +;;====================================================================== +;; (define *common:telemetry-log-state* 'startup) +;; (define *common:telemetry-log-socket* #f) +;; +;; (define (common:telemetry-log-open) +;; (if (eq? *common:telemetry-log-state* 'startup) +;; (let* ((serverhost (configf:lookup *configdat* "telemetry" "host")) +;; (serverport (configf:lookup-number *configdat* "telemetry" "port")) +;; (user (or (get-environment-variable "USER") "unknown")) +;; (host (or (get-environment-variable "HOST") "unknown"))) +;; (set! *common:telemetry-log-state* +;; (handle-exceptions +;; exn +;; (begin +;; (debug:print-info 0 *default-log-port* "common-telemetry-log open udp port failure") +;; 'broken) +;; (if (and serverhost serverport user host) +;; (let* ((s (udp-open-socket))) +;; ;;(udp-bind! s #f 0) +;; (udp-connect! s serverhost serverport) +;; (set! *common:telemetry-log-socket* s) +;; 'open) +;; 'not-needed)))))) +;; +;; (define (common:telemetry-log event #!key (payload '())) +;; (if (eq? *common:telemetry-log-state* 'startup) +;; (common:telemetry-log-open)) +;; +;; (if (eq? 'open *common:telemetry-log-state*) +;; (handle-exceptions +;; exn +;; (begin +;; (debug:print-info 0 *default-log-port* "common-telemetry-log comms failure ; disabled (no server?)") +;; ;;(define *common:telemetry-log-state* 'broken-or-no-server-preclose) +;; ;;(common:telemetry-log-close) +;; (define *common:telemetry-log-state* 'broken-or-no-server) +;; (set! *common:telemetry-log-socket* #f) +;; ) +;; (if (and *common:telemetry-log-socket* event) ;; TODO - filter on event against telemetry.want-events +;; (let* ((user (or (get-environment-variable "USER") "unknown")) +;; (host (or (get-environment-variable "HOST") "unknown")) +;; (start (conc "[megatest "event"]")) +;; (toppath (or *toppath* "/dev/null")) +;; (payload-serialized +;; (base64:base64-encode +;; (z3:encode-buffer +;; (with-output-to-string (lambda () (pp payload)))))) +;; (msg (conc user":"host":"start":"(current-process-id)":"(car (argv))":" +;; toppath":"payload-serialized))) +;; (udp-send *common:telemetry-log-socket* msg)))))) +;; +;; (define (common:telemetry-log-close) +;; (when (or (member *common:telemetry-log-state* '(broken-or-no-server-preclose open)) *common:telemetry-log-socket*) +;; (handle-exceptions +;; exn +;; (begin +;; (define *common:telemetry-log-state* 'closed-fail) +;; (debug:print-info 0 *default-log-port* "common-telemetry-log closure failure") +;; ) +;; (begin +;; (define *common:telemetry-log-state* 'closed) +;; (udp-close-socket *common:telemetry-log-socket*) +;; (set! *common:telemetry-log-socket* #f))))) Index: common_records.scm ================================================================== --- common_records.scm +++ common_records.scm @@ -81,133 +81,133 @@ ;; 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) - (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))) - (begin - (print "ERROR: Invalid debug value \"" vstr "\"") - #f) - #t)) - -(define (debug:debug-mode n) - (cond - ((and (number? *verbosity*) ;; number number - (number? n)) - (<= n *verbosity*)) - ((and (list? *verbosity*) ;; list number - (number? n)) - (member n *verbosity*)) - ((and (list? *verbosity*) ;; list list - (list? n)) - (not (null? (lset-intersection! eq? *verbosity* n)))) - ((and (number? *verbosity*) - (list? n)) - (member *verbosity* n)))) - -(define (debug:setup) - (let ((debugstr (or (args:get-arg "-debug") - (args:get-arg "-debug-noprop") - (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 (and (not (args:get-arg "-debug-noprop")) - (or (args:get-arg "-debug") - (not (getenv "MT_DEBUG_MODE")))) - (setenv "MT_DEBUG_MODE" (if (list? *verbosity*) - (string-intersperse (map conc *verbosity*) ",") - (conc *verbosity*)))))) - -(define (debug:print n e . params) - (if (debug:debug-mode n) - (with-output-to-port (or e (current-error-port)) - (lambda () - (if *logging* - (db:log-event (apply conc params)) - (apply print params) - ))))) +;; (define (debug:calc-verbosity vstr) +;; (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))) +;; (begin +;; (print "ERROR: Invalid debug value \"" vstr "\"") +;; #f) +;; #t)) +;; +;; (define (debug:debug-mode n) +;; (cond +;; ((and (number? *verbosity*) ;; number number +;; (number? n)) +;; (<= n *verbosity*)) +;; ((and (list? *verbosity*) ;; list number +;; (number? n)) +;; (member n *verbosity*)) +;; ((and (list? *verbosity*) ;; list list +;; (list? n)) +;; (not (null? (lset-intersection! eq? *verbosity* n)))) +;; ((and (number? *verbosity*) +;; (list? n)) +;; (member *verbosity* n)))) +;; +;; (define (debug:setup) +;; (let ((debugstr (or (args:get-arg "-debug") +;; (args:get-arg "-debug-noprop") +;; (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 (and (not (args:get-arg "-debug-noprop")) +;; (or (args:get-arg "-debug") +;; (not (getenv "MT_DEBUG_MODE")))) +;; (setenv "MT_DEBUG_MODE" (if (list? *verbosity*) +;; (string-intersperse (map conc *verbosity*) ",") +;; (conc *verbosity*)))))) +;; +;; (define (debug:print n e . params) +;; (if (debug:debug-mode n) +;; (with-output-to-port (or e (current-error-port)) +;; (lambda () +;; (if *logging* +;; (db:log-event (apply conc params)) +;; (apply print params) +;; ))))) ;; Brandon's debug printer shortcut (indulge me :) -(define *BB-process-starttime* (current-milliseconds)) -(define (BB> . in-args) - (let* ((stack (get-call-chain)) - (location "??")) - (for-each - (lambda (frame) - (let* ((this-loc (vector-ref frame 0)) - (temp (string-split (->string this-loc) " ")) - (this-func (if (and (list? temp) (> (length temp) 1)) (cadr temp) "???"))) - (if (equal? this-func "BB>") - (set! location this-loc)))) - stack) - (let* ((color-on "\x1b[1m") - (color-off "\x1b[0m") - (dp-args - (append - (list 0 *default-log-port* - (conc color-on location "@"(/ (- (current-milliseconds) *BB-process-starttime*) 1000) color-off " ") ) - in-args))) - (apply debug:print dp-args)))) - -(define *BBpp_custom_expanders_list* (make-hash-table)) - - - -;; register hash tables with BBpp. -(hash-table-set! *BBpp_custom_expanders_list* HASH_TABLE: - (cons hash-table? hash-table->alist)) - -;; test name converter -(define (BBpp_custom_converter arg) - (let ((res #f)) - (for-each - (lambda (custom-type-name) - (let* ((custom-type-info (hash-table-ref *BBpp_custom_expanders_list* custom-type-name)) - (custom-type-test (car custom-type-info)) - (custom-type-converter (cdr custom-type-info))) - (when (and (not res) (custom-type-test arg)) - (set! res (custom-type-converter arg))))) - (hash-table-keys *BBpp_custom_expanders_list*)) - (if res (BBpp_ res) arg))) - -(define (BBpp_ arg) - (cond - ;;((SOMESTRUCT? arg) (cons SOMESTRUCT: (SOMESTRUCT->alist arg))) - ;;((dboard:tabdat? arg) (cons dboard:tabdat: (dboard:tabdat->alist arg))) - ((hash-table? arg) - (let ((al (hash-table->alist arg))) - (BBpp_ (cons HASH_TABLE: al)))) - ((null? arg) '()) - ;;((list? arg) (cons (BBpp_ (car arg)) (BBpp_ (cdr arg)))) - ((pair? arg) (cons (BBpp_ (car arg)) (BBpp_ (cdr arg)))) - (else (BBpp_custom_converter arg)))) - -;; Brandon's pretty printer. It expands hashes and custom types in addition to regular pp -(define (BBpp arg) - (pp (BBpp_ arg))) +;; (define *BB-process-starttime* (current-milliseconds)) +;; (define (BB> . in-args) +;; (let* ((stack (get-call-chain)) +;; (location "??")) +;; (for-each +;; (lambda (frame) +;; (let* ((this-loc (vector-ref frame 0)) +;; (temp (string-split (->string this-loc) " ")) +;; (this-func (if (and (list? temp) (> (length temp) 1)) (cadr temp) "???"))) +;; (if (equal? this-func "BB>") +;; (set! location this-loc)))) +;; stack) +;; (let* ((color-on "\x1b[1m") +;; (color-off "\x1b[0m") +;; (dp-args +;; (append +;; (list 0 *default-log-port* +;; (conc color-on location "@"(/ (- (current-milliseconds) *BB-process-starttime*) 1000) color-off " ") ) +;; in-args))) +;; (apply debug:print dp-args)))) +;; +;; (define *BBpp_custom_expanders_list* (make-hash-table)) +;; +;; +;; +;; ;; register hash tables with BBpp. +;; (hash-table-set! *BBpp_custom_expanders_list* HASH_TABLE: +;; (cons hash-table? hash-table->alist)) +;; +;; ;; test name converter +;; (define (BBpp_custom_converter arg) +;; (let ((res #f)) +;; (for-each +;; (lambda (custom-type-name) +;; (let* ((custom-type-info (hash-table-ref *BBpp_custom_expanders_list* custom-type-name)) +;; (custom-type-test (car custom-type-info)) +;; (custom-type-converter (cdr custom-type-info))) +;; (when (and (not res) (custom-type-test arg)) +;; (set! res (custom-type-converter arg))))) +;; (hash-table-keys *BBpp_custom_expanders_list*)) +;; (if res (BBpp_ res) arg))) +;; +;; (define (BBpp_ arg) +;; (cond +;; ;;((SOMESTRUCT? arg) (cons SOMESTRUCT: (SOMESTRUCT->alist arg))) +;; ;;((dboard:tabdat? arg) (cons dboard:tabdat: (dboard:tabdat->alist arg))) +;; ((hash-table? arg) +;; (let ((al (hash-table->alist arg))) +;; (BBpp_ (cons HASH_TABLE: al)))) +;; ((null? arg) '()) +;; ;;((list? arg) (cons (BBpp_ (car arg)) (BBpp_ (cdr arg)))) +;; ((pair? arg) (cons (BBpp_ (car arg)) (BBpp_ (cdr arg)))) +;; (else (BBpp_custom_converter arg)))) +;; +;; ;; Brandon's pretty printer. It expands hashes and custom types in addition to regular pp +;; (define (BBpp arg) +;; (pp (BBpp_ arg))) ;(use define-macro) (define-syntax inspect (syntax-rules () [(_ x) @@ -215,40 +215,40 @@ (printf "~a is: ~a\n" 'x (with-output-to-string (lambda () (BBpp x)))) ;; ) ] [(_ x y ...) (begin (inspect x) (inspect y ...))])) -(define (debug:print-error n e . params) - ;; normal print - (if (debug:debug-mode n) - (with-output-to-port (if (port? e) e (current-error-port)) - (lambda () - (if *logging* - (db:log-event (apply conc params)) - ;; (apply print "pid:" (current-process-id) " " params) - (apply print "ERROR: " params) - )))) - ;; pass important messages to stderr - (if (and (eq? n 0)(not (eq? e (current-error-port)))) - (with-output-to-port (current-error-port) - (lambda () - (apply print "ERROR: " params) - )))) - -(define (debug:print-info n e . params) - (if (debug:debug-mode n) - (with-output-to-port (if (port? e) e (current-error-port)) - (lambda () - (if *logging* - (let ((res (format#format #f "INFO: (~a) ~a" n (apply conc params)))) - (db:log-event res)) - ;; (apply print "pid:" (current-process-id) " " "INFO: (" n ") " params) ;; res) - (apply print "INFO: (" n ") " params) ;; res) - ))))) - +;; (define (debug:print-error n e . params) +;; ;; normal print +;; (if (debug:debug-mode n) +;; (with-output-to-port (if (port? e) e (current-error-port)) +;; (lambda () +;; (if *logging* +;; (db:log-event (apply conc params)) +;; ;; (apply print "pid:" (current-process-id) " " params) +;; (apply print "ERROR: " params) +;; )))) +;; ;; pass important messages to stderr +;; (if (and (eq? n 0)(not (eq? e (current-error-port)))) +;; (with-output-to-port (current-error-port) +;; (lambda () +;; (apply print "ERROR: " params) +;; )))) +;; +;; (define (debug:print-info n e . params) +;; (if (debug:debug-mode n) +;; (with-output-to-port (if (port? e) e (current-error-port)) +;; (lambda () +;; (if *logging* +;; (let ((res (format#format #f "INFO: (~a) ~a" n (apply conc params)))) +;; (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: commonmod.scm ================================================================== --- commonmod.scm +++ commonmod.scm @@ -17,18 +17,80 @@ ;; along with Megatest. If not, see . ;;====================================================================== (declare (unit commonmod)) +(declare (uses debugprint)) + +(use srfi-69) (module commonmod * - -(import scheme chicken data-structures extras files) -(import (prefix sqlite3 sqlite3:) posix typed-records srfi-18 srfi-69 - md5 message-digest - regex srfi-1) + +(import scheme) +(cond-expand + (chicken-4 + + (import chicken + ports + + (prefix sqlite3 sqlite3:) + data-structures + extras + files + matchable + md5 + message-digest + pathname-expand + posix + posix-extras + regex + regex-case + srfi-1 + srfi-18 + srfi-69 + typed-records + + debugprint + ) + (use srfi-69)) + (chicken-5 + (import (prefix sqlite3 sqlite3:) + ;; data-structures + ;; extras + ;; files + ;; posix + ;; posix-extras + chicken.base + chicken.condition + chicken.file + chicken.file.posix + chicken.io + chicken.pathname + chicken.port + chicken.process + chicken.process-context + chicken.process-context.posix + chicken.sort + chicken.string + chicken.time + chicken.time.posix + + matchable + md5 + message-digest + pathname-expand + regex + regex-case + srfi-1 + srfi-18 + srfi-69 + typed-records + system-information + + debugprint + ))) ;;====================================================================== ;; CONTENTS ;; ;; config file utils @@ -38,16 +100,45 @@ ;;====================================================================== (include "megatest-version.scm") (include "megatest-fossil-hash.scm") +;; http - use the old http + in /tmp db +;; tcp - use tcp transport with cachedb db +;; nfs - use direct to disk access (read-only) +;; +(define rmt:transport-mode (make-parameter 'tcp)) + (define (get-full-version) (conc megatest-version "-" megatest-fossil-hash)) (define (version-signature) (conc megatest-version "-" (substring megatest-fossil-hash 0 4))) +(define *common:denoise* (make-hash-table)) ;; for low noise printing + +(define (common:low-noise-print waitval . keys) + (let* ((key (string-intersperse (map conc keys) "-" )) + (lasttime (hash-table-ref/default *common:denoise* key 0)) + (currtime (current-seconds))) + (if (> (- currtime lasttime) waitval) + (begin + (hash-table-set! *common:denoise* key currtime) + #t) + #f))) + +;; KEEP THIS ONE +;; +;; client:get-signature + +(define *my-client-signature* #f) + +(define (client:get-signature) + (if *my-client-signature* *my-client-signature* + (let ((sig (conc (get-host-name) " " (current-process-id)))) + (set! *my-client-signature* sig) + *my-client-signature*))) ;;====================================================================== ;; config file utils ;;====================================================================== @@ -72,15 +163,119 @@ '()))) ;; should it return empty list or #f to indicate not set? (define (get-section cfgdat section) (hash-table-ref/default cfgdat section '())) + +(define (common:make-tmpdir-name areapath tmpadj) + (let* ((area (pathname-file areapath)) + (dname (conc "/tmp/"(current-user-name)"/megatest_localdb/" area "/" (string-translate areapath "/" ".") tmpadj "/.mtdb"))) + (unless (directory-exists? dname) + (create-directory dname #t)) + dname)) + +;; dot-locking egg seems not to work, using this for now +;; if lock is older than expire-time then remove it and try again +;; to get the lock +;; +(define (common:simple-file-lock fname #!key (expire-time 300)) + (let* ((lock-exists (file-exists? fname)) + (fmod-time (if lock-exists + (current-seconds) + (handle-exceptions + ext + (current-seconds) + (file-modification-time fname))))) + (if lock-exists + (if (> (- (current-seconds) fmod-time) expire-time) + (begin + (debug:print-info 1 *default-log-port* "Removing stale lock "fname) + (handle-exceptions exn #f (delete-file* fname)) + (common:simple-file-lock fname expire-time: expire-time)) + #f) + (let ((key-string (conc (get-host-name) "-" (current-process-id)))) + (with-output-to-file fname + (lambda () + (print key-string))) + (thread-sleep! 0.25) + (if (file-exists? fname) ;; (common:file-exists? fname) + (handle-exceptions exn + #f + (with-input-from-file fname + (lambda () + (equal? key-string (read-line))))) + #f))))) + +(define (common:simple-file-lock-and-wait fname #!key (expire-time 300)) + (let ((end-time (+ expire-time (current-seconds)))) + (let loop ((got-lock (common:simple-file-lock fname expire-time: expire-time))) + (if got-lock + #t + (if (> end-time (current-seconds)) + (begin + (thread-sleep! 3) + (loop (common:simple-file-lock fname expire-time: expire-time))) + #f))))) + +(define (common:simple-file-release-lock fname) + (handle-exceptions + exn + #f ;; I don't really care why this failed (at least for now) + (delete-file* fname))) ;;====================================================================== ;; misc conversion, data manipulation functions ;;====================================================================== +;;====================================================================== +;; return first command that exists, else #f +;; +(define (common:which cmds) + (if (null? cmds) + #f + (let loop ((hed (car cmds)) + (tal (cdr cmds))) + (let ((res (with-input-from-pipe (conc "which " hed) read-line))) + (if (and (string? res) + (file-exists? res)) + res + (if (null? tal) + #f + (loop (car tal)(cdr tal)))))))) + +(define (common:get-megatest-exe) + (let* ((mtexe (or (get-environment-variable "MT_MEGATEST") + (common:which '("megatest")) + "megatest"))) + (if (file-exists? mtexe) + (realpath mtexe) + mtexe))) + +(define (common:get-megatest-exe-dir) + (let* ((mtexe (common:get-megatest-exe))) + (pathname-directory mtexe))) + +;; more generic and comprehensive version of get-megatest-exe +;; +(define (common:get-mtexe) + (let* ((mtpathdir (common:get-megatest-exe-dir))) + (or (common:get-megatest-exe) + (if mtpathdir + (conc mtpathdir"/megatest") + #f) + "megatest"))) + +(define (common:get-megatest-exe-path) + (let* ((mtpathdir (common:get-megatest-exe-dir))) + (conc mtpathdir":"(get-environment-variable "PATH") ":."))) + +(cond-expand + (chicken-4 + (define (realpath x) (resolve-pathname (pathname-expand (or x "/dev/null")) ))) + (chicken-5 + (define (realpath x) (normalize-pathname (pathname-expand (or x "/dev/null")))))) + ;; if it looks like a number -> convert it to a number, else return it ;; (define (lazy-convert inval) (let* ((as-num (if (string? inval)(string->number inval) #f))) (or as-num inval))) @@ -102,10 +297,43 @@ (filter (lambda (x) (not (string-match "^\\s*" x))) val-list)) '()))) +(define (commonmod:get-cpu-load) + (let* ((load-info (with-input-from-file "/proc/loadavg" read-lines)) + (res (map string->number (string-split (car load-info))))) + (if (null? res) + #f ;; something is wrong + (car res)))) + +(define *current-host-cores* #f) + +(define (get-current-host-cores) + (or *current-host-cores* + (let ((cpu-info (with-input-from-file "/proc/cpuinfo" read-lines))) + (let loop ((lines cpu-info)) + (if (null? lines) + 1 ;; gotta be at least one! + (let* ((inl (car lines)) + (tail (cdr lines)) + (parts (string-split inl))) + (match parts + (("cpu" "cores" ":" num) (string->number num)) + (else (loop tail))))))))) + +(define (number-of-processes-running processname) + (with-input-from-pipe + (conc "ps -def | egrep \""processname"\" |wc -l") + (lambda () + (string->number (read-line))))) + +;; get the normalized (i.e. load / numcpus) for *this* host +;; +(define (get-normalized-cpu-load) + (/ (commonmod:get-cpu-load)(get-current-host-cores))) + ;;====================================================================== ;; testsuite and area utilites ;;====================================================================== (define (get-testsuite-name toppath configdat) @@ -149,14 +377,386 @@ (let ((adat (get-section cfgdat "areas"))) (map (lambda (entry) `(,(car entry) . ,(val->alist (cadr entry)))) adat))) - -;; (define (debug:print . params) #f) -;; (define (debug:print-info . params) #f) -;; -;; (define (set-functions dbgp dbgpinfo) -;; (set! debug:print dbgp) -;; (set! debug:print-info dbgpinfo)) + +;;====================================================================== +;; time utils +;;====================================================================== + +(define (common:human-time) + (time->string (seconds->local-time (current-seconds)) "%Y-%m-%d %H:%M:%S")) + +;;====================================================================== +;; T I M E A N D D A T E +;;====================================================================== + +;;====================================================================== +;; Convert strings like "5s 2h 3m" => 60x60x2 + 3x60 + 5 +(define (common:hms-string->seconds tstr) + (let ((parts (string-split-fields "\\w+" tstr)) + (time-secs 0) + ;; s=seconds, m=minutes, h=hours, d=days, M=months, y=years, w=weeks + (trx (regexp "^(\\d+)([smhdMyw])$"))) + (for-each (lambda (part) + (let ((match (string-match trx part))) + (if match + (let ((val (string->number (cadr match))) + (unt (caddr match))) + (if val + (set! time-secs (+ time-secs (* val + (case (string->symbol unt) + ((s) 1) + ((m) 60) ;; minutes + ((h) 3600) + ((d) 86400) + ((w) 604800) + ((M) 2628000) ;; aproximately one month + ((y) 31536000) + (else + 0))))) + (debug:print 0 *default-log-port* "ERROR: can't parse timestring "tstr", component "part", string: "(cadr match)))) + (debug:print 0 *default-log-port* "ERROR: can't parse timestring "tstr", component "part)))) + parts) + time-secs)) + +(define (seconds->hr-min-sec secs) + (let* ((hrs (quotient secs 3600)) + (min (quotient (- secs (* hrs 3600)) 60)) + (sec (- secs (* hrs 3600)(* min 60)))) + (conc (if (> hrs 0)(conc hrs "hr ") "") + (if (> min 0)(conc min "m ") "") + sec "s"))) + +(define (seconds->time-string sec) + (time->string + (seconds->local-time sec) "%H:%M:%S")) + +(define (seconds->work-week/day-time sec) + (time->string + (seconds->local-time sec) "ww%V.%u %H:%M")) + +(define (seconds->work-week/day sec) + (time->string + (seconds->local-time sec) "ww%V.%u")) + +(define (seconds->year-work-week/day sec) + (time->string + (seconds->local-time sec) "%yww%V.%w")) + +(define (seconds->year-work-week/day-time sec) + (time->string + (seconds->local-time sec) "%Yww%V.%w %H:%M")) + +(define (seconds->year-week/day-time sec) + (time->string + (seconds->local-time sec) "%Yw%V.%w %H:%M")) + +(define (seconds->quarter sec) + (case (string->number + (time->string + (seconds->local-time sec) + "%m")) + ((1 2 3) 1) + ((4 5 6) 2) + ((7 8 9) 3) + ((10 11 12) 4) + (else #f))) + +;;====================================================================== +;; basic ISO8601 format (e.g. "2017-02-28 06:02:54") date time => Unix epoch +;; +(define (common:date-time->seconds datetime) + (local-time->seconds (string->time datetime "%Y-%m-%d %H:%M:%S"))) + +;;====================================================================== +;; given span of seconds tstart to tend +;; find start time to mark and mark delta +;; +(define (common:find-start-mark-and-mark-delta tstart tend) + (let* ((deltat (- (max tend (+ tend 10)) tstart)) ;; can't handle runs of less than 4 seconds. Pad it to 10 seconds ... + (result #f) + (min 60) + (hr (* 60 60)) + (day (* 24 hr)) + (yr (* 365 day)) ;; year + (mo (/ yr 12)) + (wk (* day 7))) + (for-each + (lambda (max-blks) + (for-each + (lambda (span) ;; 5 2 1 + (if (not result) + (for-each + (lambda (timeunit timesym) ;; year month day hr min sec + (if (not result) + (let* ((time-blk (* span timeunit)) + (num-blks (quotient deltat time-blk))) + (if (and (> num-blks 4)(< num-blks max-blks)) + (let ((first (* (quotient tstart time-blk) time-blk))) + (set! result (list span timeunit time-blk first timesym)) + ))))) + (list yr mo wk day hr min 1) + '( y mo w d h m s)))) + (list 8 6 5 2 1))) + '(5 10 15 20 30 40 50 500)) + (if values + (apply values result) + (values 0 day 1 0 'd)))) + +;;====================================================================== +;; given x y lim return the cron expansion +;; +(define (common:expand-cron-slash x y lim) + (let loop ((curr x) + (res `())) + (if (< curr lim) + (loop (+ curr y) (cons curr res)) + (reverse res)))) + +;;====================================================================== +;; expand a complex cron string to a list of cron strings +;; +;; x/y => x, x+y, x+2y, x+3y while x+Ny a, b ,c +;; +;; NOTE: with flatten a lot of the crud below can be factored down. +;; +(define (common:cron-expand cron-str) + (if (list? cron-str) + (flatten + (fold (lambda (x res) + (if (list? x) + (let ((newres (map common:cron-expand x))) + (append x newres)) + (cons x res))) + '() + cron-str)) ;; (map common:cron-expand cron-str)) + (let ((cron-items (string-split cron-str)) + (slash-rx (regexp "(\\d+)/(\\d+)")) + (comma-rx (regexp ".*,.*")) + (max-vals '((min . 60) + (hour . 24) + (dayofmonth . 28) ;;; BUG!!!! This will be a bug for some combinations + (month . 12) + (dayofweek . 7)))) + (if (< (length cron-items) 5) ;; bad spec + cron-str ;; `(,cron-str) ;; just return the string, something downstream will fix it + (let loop ((hed (car cron-items)) + (tal (cdr cron-items)) + (type 'min) + (type-tal '(hour dayofmonth month dayofweek)) + (res '())) + (regex-case + hed + (slash-rx ( _ base incr ) (let* ((basen (string->number base)) + (incrn (string->number incr)) + (expanded-vals (common:expand-cron-slash basen incrn (alist-ref type max-vals))) + (new-list-crons (fold (lambda (x myres) + (cons (conc (if (null? res) + "" + (conc (string-intersperse res " ") " ")) + x " " (string-intersperse tal " ")) + myres)) + '() expanded-vals))) + ;; (print "new-list-crons: " new-list-crons) + ;; (fold (lambda (x res) + ;; (if (list? x) + ;; (let ((newres (map common:cron-expand x))) + ;; (append x newres)) + ;; (cons x res))) + ;; '() + (flatten (map common:cron-expand new-list-crons)))) + ;; (map common:cron-expand (map common:cron-expand new-list-crons)))) + (else (if (null? tal) + cron-str + (loop (car tal)(cdr tal)(car type-tal)(cdr type-tal)(append res (list hed))))))))))) + +;;====================================================================== +;; given a cron string and the last time event was processed return #t to run or #f to not run +;; +;; min hour dayofmonth month dayofweek +;; 0-59 0-23 1-31 1-12 0-6 ### NOTE: dayofweek does not include 7 +;; +;; #t => yes, run the job +;; #f => no, do not run the job +;; +(define (common:cron-event cron-str now-seconds-in last-done) ;; ref-seconds = #f is NOW. + (let* ((cron-items (map string->number (string-split cron-str))) + (now-seconds (or now-seconds-in (current-seconds))) + (now-time (seconds->local-time now-seconds)) + (last-done-time (seconds->local-time last-done)) + (all-times (make-hash-table))) + ;; (print "cron-items: " cron-items "(length cron-items): " (length cron-items)) + (if (not (eq? (length cron-items) 5)) ;; don't even try to figure out junk strings + #f + (match-let ((( cmin chour cdayofmonth cmonth cdayofweek) + cron-items) + ;; 0 1 2 3 4 5 6 + ((nsec nmin nhour ndayofmonth nmonth nyr ndayofweek n7 n8 n9) + (vector->list now-time)) + ((lsec lmin lhour ldayofmonth lmonth lyr ldayofweek l7 l8 l9) + (vector->list last-done-time))) + ;; create all possible time slots + ;; remove invalid slots due to (for example) day of week + ;; get the start and end entries for the ref-seconds (current) time + ;; if last-done > ref-seconds => this is an ERROR! + ;; does the last-done time fall in the legit region? + ;; yes => #f do not run again this command + ;; no => #t ok to run the command + (for-each ;; month + (lambda (month) + (for-each ;; dayofmonth + (lambda (dom) + (for-each + (lambda (hr) ;; hour + (for-each + (lambda (minute) ;; minute + (let ((copy-now (apply vector (vector->list now-time)))) + (vector-set! copy-now 0 0) ;; force seconds to zero + (vector-set! copy-now 1 minute) + (vector-set! copy-now 2 hr) + (vector-set! copy-now 3 dom) ;; dom is already corrected for zero referenced + (vector-set! copy-now 4 month) + (let* ((copy-now-secs (local-time->seconds copy-now)) + (new-copy (seconds->local-time copy-now-secs))) ;; remake the time vector + (if (or (not cdayofweek) + (equal? (vector-ref new-copy 6) + cdayofweek)) ;; if the day is specified and a match OR if the day is NOT specified + (if (or (not cdayofmonth) + (equal? (vector-ref new-copy 3) + (+ 1 cdayofmonth))) ;; if the month is specified and a match OR if the month is NOT specified + (hash-table-set! all-times copy-now-secs new-copy)))))) + (if cmin + `(,cmin) ;; if given cmin, have to use it + (list (- nmin 1) nmin (+ nmin 1))))) ;; minute + (if chour + `(,chour) + (list (- nhour 1) nhour (+ nhour 1))))) ;; hour + (if cdayofmonth + `(,cdayofmonth) + (list (- ndayofmonth 1) ndayofmonth (+ ndayofmonth 1))))) + (if cmonth + `(,cmonth) + (list (- nmonth 1) nmonth (+ nmonth 1)))) + (let ((before #f) + (is-in #f)) + (for-each + (lambda (moment) + (if (and before + (<= before now-seconds) + (>= moment now-seconds)) + (begin + ;; (print) + ;; (print "Before: " (time->string (seconds->local-time before))) + ;; (print "Now: " (time->string (seconds->local-time now-seconds))) + ;; (print "After: " (time->string (seconds->local-time moment))) + ;; (print "Last: " (time->string (seconds->local-time last-done))) + (if (< last-done before) + (set! is-in before)) + )) + (set! before moment)) + (sort (hash-table-keys all-times) <)) + is-in))))) + +(define (common:extended-cron cron-str now-seconds-in last-done) + (let ((expanded-cron (common:cron-expand cron-str))) + (if (string? expanded-cron) + (common:cron-event expanded-cron now-seconds-in last-done) + (let loop ((hed (car expanded-cron)) + (tal (cdr expanded-cron))) + (if (common:cron-event hed now-seconds-in last-done) + #t + (if (null? tal) + #f + (loop (car tal)(cdr tal)))))))) + + + +;;====================================================================== +;; misc stuff +;;====================================================================== + +(define (common:get-signature str) + (message-digest-string (md5-primitive) str)) + +;;====================================================================== +;; hash of hashs +;;====================================================================== + +(define (db:hoh-set! dat key1 key2 val) + (let* ((subhash (hash-table-ref/default dat key1 #f))) + (if subhash + (hash-table-set! subhash key2 val) + (begin + (hash-table-set! dat key1 (make-hash-table)) + (db:hoh-set! dat key1 key2 val))))) + +(define (db:hoh-get dat key1 key2) + (let* ((subhash (hash-table-ref/default dat key1 #f))) + (and subhash + (hash-table-ref/default subhash key2 #f)))) + +;;====================================================================== +;; when called from a wrapper I need sometimes to find the calling +;; wrapper, this is for dashboard to find the correct megatest. +;; +(define (common:find-local-megatest #!optional (progname "megatest")) + (let ((res (filter file-exists? + (map (lambda (updir) + (let* ((lm (car (argv))) + (dir (pathname-directory lm)) + (exe (pathname-strip-directory lm))) + (conc (if dir (conc dir "/") "") + (case (string->symbol exe) + ((dboard) (conc updir progname)) + ((mtest) (conc updir progname)) + ((dashboard) progname) + (else exe))))) + '("../../" "../"))))) + (if (null? res) + (begin + ;; (debug:print 0 *default-log-port* "Failed to find this executable! Using what can be found on the path") + progname) + (car res)))) + +(define (common:generic-ssh ssh-command proc default #!optional (msg-proc #f)) + (let ((inp #f)) + (handle-exceptions + exn + (begin + (close-input-port inp) + (if msg-proc + (msg-proc) + (debug:print 0 *default-log-port* "Command: \""ssh-command"\" failed. exn="exn)) + default) + (set! inp (open-input-pipe ssh-command)) + (with-input-from-port inp + (lambda () + (let ((res (proc))) + (close-input-port inp) + res)))))) + +;; this is a close duplicate of: +;; process:alist-on-host? +;; process:alive +;; +(define (commonmod:is-test-alive host pid) + (let* ((same-host (equal? host (get-host-name))) + (cmd (conc + (if same-host "" (conc "ssh "host" ")) + "pstree -A "pid))) + (if (and host pid + (not (equal? host "n/a"))) + + (let* ((output (if same-host + (with-input-from-pipe cmd read-lines) + (common:generic-ssh cmd read-lines '())))) ;; (with-input-from-pipe cmd read-lines))) + (debug:print 2 *default-log-port* "Running " cmd " received " output) + (if (eq? (length output) 0) + #f + #t)) + #t))) ;; assuming bad query is about a live test is likely not the right thing to do? + ) Index: configf.scm ================================================================== --- configf.scm +++ configf.scm @@ -25,10 +25,24 @@ (use regex regex-case matchable) ;; directory-utils) (declare (unit configf)) (declare (uses process)) (declare (uses env)) (declare (uses keys)) +(declare (uses debugprint)) +(declare (uses mtargs)) +(declare (uses mtargs.import)) +(declare (uses common)) +(declare (uses commonmod)) +(declare (uses commonmod.import)) +(declare (uses dbfile)) +(declare (uses dbfile.import)) +(declare (uses dbmod)) +(declare (uses dbmod.import)) + +(import commonmod + (prefix mtargs args:) + debugprint) (include "common_records.scm") ;; return list (path fullpath configname) (define (find-config configname #!key (toppath #f)) @@ -46,23 +60,27 @@ (let ((remcwd (take dir (- (length dir) 1)))) (if (null? remcwd) (list #f #f #f) ;; #f #f) (loop remcwd))))))))) -(define (config:assoc-safe-add alist key val #!key (metadata #f)) +(define (configf:assoc-safe-add alist key val #!key (metadata #f)) (let ((newalist (filter (lambda (x)(not (equal? key (car x)))) alist))) (append newalist (list (if metadata (list key val metadata) (list key val)))))) +;; this is used in megatestqa/ext.scm. +;; remove it from here and there by 12/31/21 +;; (define config:assoc-safe-add configf:assoc-safe-add) + (define (configf:section-var-set! cfgdat section-name var value #!key (metadata #f)) (hash-table-set! cfgdat section-name - (config:assoc-safe-add + (configf:assoc-safe-add (hash-table-ref/default cfgdat section-name '()) var value metadata: metadata))) -(define (config:eval-string-in-environment str) +(define (configf:eval-string-in-environment str) ;; (if (or (string-null? str) ;; (equal? "!" (substring str 0 1))) ;; null string or starts with ! are preserved but NOT set in the environment str (handle-exceptions exn @@ -94,10 +112,12 @@ (define (configf:system ht cmd) (system cmd) ) +(define configf:imports "(import commonmod (prefix mtargs args:))") + (define (configf:process-line l ht allow-system #!key (linenum #f)) (let loop ((res l)) (if (string? res) (let ((matchdat (string-search configf:var-expand-regex res))) (if matchdat @@ -107,11 +127,11 @@ (poststr (list-ref matchdat 4)) (result #f) (start-time (current-seconds)) (cmdsym (string->symbol cmdtype)) (fullcmd (case cmdsym - ((scheme scm) (conc "(lambda (ht)" cmd ")")) + ((scheme scm) (conc "(lambda (ht)(begin " configf:imports cmd "))")) ((system) (conc "(lambda (ht)(configf:system ht \"" cmd "\"))")) ((shell sh) (conc "(lambda (ht)(string-translate (shell \"" cmd "\") \"\n\" \" \"))")) ((realpath rp)(conc "(lambda (ht)(common:nice-path \"" cmd "\"))")) ((getenv gv) (conc "(lambda (ht)(get-environment-variable \"" cmd "\"))")) ((mtrah) (conc "(lambda (ht)" @@ -144,11 +164,11 @@ (set! result (conc "#{(" cmdtype ") " cmd "}")))) (case cmdsym ((system shell scheme) (let ((delta (- (current-seconds) start-time))) (if (> delta 2) - (debug:print-info 0 *default-log-port* "for line \"" l "\"\n command: " cmd " took " delta " seconds to run with output:\n " result) + (debug:print-info 2 *default-log-port* "for line \"" l "\"\n command: " cmd " took " delta " seconds to run with output:\n " result) (debug:print-info 9 *default-log-port* "for line \"" l "\"\n command: " cmd " took " delta " seconds to run with output:\n " result))))) (loop (conc prestr result poststr))) res)) res))) @@ -161,11 +181,11 @@ (let ((outres (string-intersperse res "\n"))) (debug:print-info 4 *default-log-port* "shell result:\n" outres) outres) - (begin + (begin ;; why is this printing to error-port and not using debug:print? -mrw- (with-output-to-port (current-error-port) (lambda () (print "ERROR: " cmd " returned bad exit code " status))) "")))) @@ -241,11 +261,11 @@ (lambda (bundle) ;; (print "bundle: " bundle) (let ((key (car bundle)) (val (cadr bundle)) (meta (if (> (length bundle) 2)(caddr bundle) #f))) - (hash-table-set! ht section (config:assoc-safe-add (hash-table-ref ht section) key val metadata: meta)))) + (hash-table-set! ht section (configf:assoc-safe-add (hash-table-ref ht section) key val metadata: meta)))) vars))))) (hash-table-keys ht)))) ht) ;; read a config file, returns hash table of alists @@ -419,11 +439,11 @@ (debug:print-info 9 *default-log-port* "for line \"" inl "\"\n command: " cmd " took " delta " seconds to run with output:\n " res)) (if (null? res) "" (string-intersperse res " ")))))) (hash-table-set! res curr-section-name - (config:assoc-safe-add alist + (configf:assoc-safe-add alist key (case (calc-allow-system allow-system curr-section-name sections) ((return-procs) val-proc) ((return-string) cmd) (else (val-proc))) @@ -438,11 +458,11 @@ (let* ((alist (hash-table-ref/default res curr-section-name '())) (fval (or (if (string? val) val #f) ""))) ;; fval should be either "" or " " (one or more spaces) (debug:print 10 *default-log-port* " setting: [" curr-section-name "] " key " = #t") (safe-setenv key fval) (hash-table-set! res curr-section-name - (config:assoc-safe-add alist key fval metadata: metapath)) + (configf:assoc-safe-add alist key fval metadata: metapath)) (loop (configf:read-line inp res (calc-allow-system allow-system curr-section-name sections) settings) curr-section-name key #f))) @@ -453,17 +473,17 @@ (and (not (string-null? key)) (not (equal? "!" (substring key 0 1)))) ;; ! as leading character is a signature to NOT export to the environment ;; (string-match "^.*:.*:.*$" key) ;; ;; something:something:something reserved for triggers in runconfigs )) (realval (if envar - (config:eval-string-in-environment val) + (configf:eval-string-in-environment val) val))) (debug:print-info 6 *default-log-port* "read-config env setting, envar: " envar " realval: " realval " val: " val " key: " key " curr-section-name: " curr-section-name) (if envar (safe-setenv key realval)) (debug:print 10 *default-log-port* " setting: [" curr-section-name "] " key " = " val) (hash-table-set! res curr-section-name - (config:assoc-safe-add alist key realval metadata: metapath)) + (configf:assoc-safe-add alist key realval metadata: metapath)) (loop (configf:read-line inp res (calc-allow-system allow-system curr-section-name sections) settings) curr-section-name key #f))) ;; if a continued line (configf:cont-ln-rx ( x whsp val ) @@ -476,11 +496,11 @@ (string-substitute (regexp lead) "" whsp) "") val))) ;; (print "val: " val "\nnewval: \"" newval "\"\nvarflag: " var-flag) (hash-table-set! res curr-section-name - (config:assoc-safe-add alist var-flag newval metadata: metapath)) + (configf:assoc-safe-add alist var-flag newval metadata: metapath)) (loop (configf:read-line inp res (calc-allow-system allow-system curr-section-name sections) settings) curr-section-name var-flag (if lead lead whsp))) (loop (configf:read-line inp res (calc-allow-system allow-system curr-section-name sections) settings) curr-section-name #f #f)))) (else (debug:print-error 0 *default-log-port* "problem parsing " path ",\n \"" inl "\"") (set! var-flag #f) (loop (configf:read-line inp res (calc-allow-system allow-system curr-section-name sections) settings) curr-section-name #f #f)))) @@ -524,10 +544,11 @@ ;; (configf:var-is? cfgdat "foo" "var" "yes") => #t ;; (define (configf:var-is? cfgdat section var expected-val) (equal? (configf:lookup cfgdat section var) expected-val)) +;; redefines (define config-lookup configf:lookup) (define configf:read-file read-config) ;; safely look up a value that is expected to be a number, return ;; a default (#f unless provided) @@ -552,14 +573,15 @@ (hash-table-ref/default cfgdat section '())) (define (configf:set-section-var cfgdat section var val) (let ((sectdat (configf:get-section cfgdat section))) (hash-table-set! cfgdat section - (config:assoc-safe-add sectdat var val)))) + (configf:assoc-safe-add sectdat var val)))) - ;;(append (filter (lambda (x)(not (assoc var sectdat))) sectdat) - ;; (list var val)))) +;;====================================================================== +;;(append (filter (lambda (x)(not (assoc var sectdat))) sectdat) +;; (list var val)))) (define (setup) (let* ((configf (find-config "megatest.config")) (config (if configf (read-config configf #f #t) #f))) (if config @@ -781,11 +803,11 @@ ;; if (define (configf:read-alist fname) (handle-exceptions exn (begin - (debug:print-info 0 *default-log-port* "unable to read alist " fname ". exn=" exn) + (debug:print 0 *default-log-port* "read of alist " fname " failed. exn=" exn) #f) (configf:alist->config (with-input-from-file fname read)))) (define (configf:write-alist cdat fname) ADDED configfmod.scm Index: configfmod.scm ================================================================== --- /dev/null +++ configfmod.scm @@ -0,0 +1,75 @@ +;;====================================================================== +;; Copyright 2017, Matthew Welland. +;; +;; This file is part of Megatest. +;; +;; Megatest is free software: you can redistribute it and/or modify +;; it under the terms of the GNU General Public License as published by +;; the Free Software Foundation, either version 3 of the License, or +;; (at your option) any later version. +;; +;; Megatest is distributed in the hope that it will be useful, +;; but WITHOUT ANY WARRANTY; without even the implied warranty of +;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +;; GNU General Public License for more details. +;; +;; You should have received a copy of the GNU General Public License +;; along with Megatest. If not, see . + +;;====================================================================== + +(declare (unit configfmod)) +;; (declare (uses mtargs)) +;; (declare (uses debugprint)) +;; (declare (uses keysmod)) + +(module configfmod +* + +(import srfi-1 + +;; scheme +;; +;; big-chicken ;; more of a reminder than anything ... +;; chicken.base +;; chicken.condition +;; chicken.file +;; chicken.io +;; chicken.pathname +;; chicken.port +;; chicken.pretty-print +;; chicken.process +;; chicken.process-context +;; chicken.process-context.posix +;; chicken.sort +;; chicken.string +;; chicken.time +;; chicken.eval +;; +;; debugprint +;; (prefix mtargs args:) +;; pkts +;; keysmod +;; +;; (prefix base64 base64:) +;; (prefix dbi dbi:) +;; (prefix sqlite3 sqlite3:) +;; (srfi 18) +;; directory-utils +;; format +;; matchable +;; md5 +;; message-digest +;; regex +;; regex-case +;; sparse-vectors +;; srfi-1 +;; srfi-13 +;; srfi-69 +;; stack +;; typed-records +;; z3 + + ) +) + Index: configure ================================================================== --- configure +++ configure @@ -71,11 +71,11 @@ ARCHSTR=$(/usr/bin/sw_vers -productVersion) else ARCHSTR=$(lsb_release -sr) fi -echo "CKPATH=$PREFIX/.$ARCHSTR" >> makefile.inc +echo "CHICKEN_PREFIX=$PREFIX/.$ARCHSTR" >> makefile.inc CHICKEN_PREFIX=$PREFIX/bin/.$ARCHSTR if [[ ! $(type csi) ]];then echo "Chicken build needed." echo "BUILD_CHICKEN=yes" >> makefile.inc Index: dashboard-context-menu.scm ================================================================== --- dashboard-context-menu.scm +++ dashboard-context-menu.scm @@ -21,32 +21,38 @@ ;;====================================================================== ;; implementation of context menu that pops up on ;; right click on test cell in Runs & Runs Summary Tabs ;;====================================================================== +(declare (unit dashboard-context-menu)) +(declare (uses common)) +(declare (uses commonmod)) +(declare (uses db)) +(declare (uses gutils)) +(declare (uses rmt)) +(declare (uses rmtmod)) +(declare (uses ezsteps)) +;; (declare (uses sdb)) +;; (declare (uses filedb)) +(declare (uses subrun)) + (use format fmt) (require-library iup) (import (prefix iup iup:)) (use canvas-draw) (use srfi-1 posix regex regex-case srfi-69) (use (prefix sqlite3 sqlite3:)) -(declare (unit dashboard-context-menu)) -(declare (uses common)) -(declare (uses db)) -(declare (uses gutils)) -(declare (uses rmt)) -(declare (uses ezsteps)) -;; (declare (uses sdb)) -;; (declare (uses filedb)) -(declare (uses subrun)) - (include "common_records.scm") (include "db_records.scm") (include "run_records.scm") + +(import commonmod + rmtmod + debugprint) (define (dboard:launch-testpanel run-id test-id) (let* ((dboardexe (common:find-local-megatest "dashboard")) (cmd (conc dboardexe " -test " run-id "," test-id @@ -319,11 +325,11 @@ (lambda () (if scheme-match (begin (handle-exceptions exn - (print "error with custom menu scheme, exn=" exn) + (debug:print 0 *default-log-port* "error with custom menu scheme, exn=" exn) (begin ;;(BB> "gonna eval it!") (eval (with-input-from-string (cadr scheme-match) read))))) (common:run-a-command command-line with-vars: #t)))))))) #f))) Index: dashboard-guimonitor.scm ================================================================== --- dashboard-guimonitor.scm +++ dashboard-guimonitor.scm @@ -34,10 +34,12 @@ (declare (unit dashboard-guimonitor)) (declare (uses common)) (declare (uses keys)) (declare (uses db)) (declare (uses tasks)) +(declare (uses commonmod)) +(import commonmod) (include "common_records.scm") (include "db_records.scm") (include "run_records.scm") (include "task_records.scm") @@ -74,21 +76,22 @@ (iup:hbox (iup:button "Start" #:expand "HORIZONTAL" #:action (lambda (obj) (tasks:add-from-params tdb "run" keys key-params var-params) - (print "Launch Run"))) + ;; (print "Launch Run") + )) (iup:button "Remove" #:expand "HORIZONTAL" #:action (lambda (obj) - (print "Remove Run") + ;; (print "Remove Run") (tasks:add-from-params tdb "remove" keys key-params var-params) )) (iup:button "Rollup" #:expand "HORIZONTAL" #:action (lambda (obj) - (print "Rollup Run") + ;; (print "Rollup Run") (tasks:add-from-params tdb "rollup" keys key-params var-params))))) (iup:frame #:title "Misc" (iup:hbox (iup:button "Quit" Index: dashboard-tests.scm ================================================================== --- dashboard-tests.scm +++ dashboard-tests.scm @@ -20,28 +20,34 @@ ;;====================================================================== ;; Test info panel ;;====================================================================== +(declare (unit dashboard-tests)) +(declare (uses common)) +(declare (uses commonmod)) +(declare (uses dcommon)) +(declare (uses db)) +(declare (uses gutils)) +(declare (uses rmt)) +(declare (uses ezsteps)) +(declare (uses subrun)) +(declare (uses debugprint)) +(declare (uses rmtmod)) + (use format fmt) (require-library iup) (import (prefix iup iup:)) (use canvas-draw) (use srfi-1 posix regex regex-case srfi-69) (use (prefix sqlite3 sqlite3:)) -(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)) -(declare (uses subrun)) +(import commonmod + rmtmod + debugprint) (include "common_records.scm") (include "db_records.scm") (include "run_records.scm") @@ -89,11 +95,12 @@ "Current state: " "Current status: " "Test comment: " "Test id: " "Test date: ")) - (list (iup:label "" #:expand "VERTICAL")))) + (list (iup:label "" #:expand "VERTICAL" + )))) (apply iup:vbox ; #:expand "YES" (list (store-label "testname" (iup:label (db:test-get-testname testdat) #:expand "HORIZONTAL") (lambda (testdat)(db:test-get-testname testdat))) @@ -157,11 +164,12 @@ (list "Author: " "Owner: " "Reviewed: " "Tags: " "Description: ")) - (list (iup:label "" #:expand "VERTICAL")))) + (list (iup:label "" #:expand "VERTICAL" + )))) (apply iup:vbox ; #:expand "YES" (list (store-meta "author" (iup:label (db:testmeta-get-author testmeta) #:expand "HORIZONTAL") (lambda (testmeta)(db:testmeta-get-author testmeta))) @@ -173,11 +181,12 @@ (lambda (testmeta)(db:testmeta-get-reviewed testmeta))) (store-meta "tags" (iup:label (db:testmeta-get-tags testmeta) #:expand "HORIZONTAL") (lambda (testmeta)(db:testmeta-get-tags testmeta))) (store-meta "description" - (iup:label (test-meta-panel-get-description testmeta) #:size "x50"); #:expand "HORIZONTAL") + (iup:label (test-meta-panel-get-description testmeta) ;; #:wordwrap "YES" ;; #:size "x50" + ) ;; #:expand "HORIZONTAL") (lambda (testmeta) (test-meta-panel-get-description testmeta))) ))))) @@ -201,16 +210,21 @@ (list (iup:label "runname ") (iup:label "run-id") (iup:label "run-date")))) (apply iup:vbox (append (map (lambda (keyval) - (iup:label (cadr keyval) #:expand "HORIZONTAL")) + (iup:vbox + (iup:label (cadr keyval) #:expand "HORIZONTAL") + ;; (iup:label "" #:expand "BOTH") + ) + ) keydat) (list (iup:label runname) (iup:label (conc run-id)) (iup:label (seconds->year-work-week/day-time event_time)) - (iup:label "" #:expand "VERTICAL")))))))) + (iup:label "" ;;#:expand "VERTICAL" + )))))))) ;;====================================================================== ;; Host info panel ;;====================================================================== (define (host-info-panel testdat store-label) @@ -226,11 +240,12 @@ "CPU Load: " "Run duration: " "Logfile: " "Top process id: " "Uname -a: ")) - (iup:label "" #:expand "VERTICAL"))) + (iup:label "" ;; #:expand "VERTICAL" + ))) (apply iup:vbox ; #:expand "YES" (list ;; NOTE: Yes, the host can change! (store-label "HostName" (iup:label ;; (sdb:qry 'getstr @@ -261,34 +276,21 @@ ;; if there is a submegatest create a button to launch dashboard in that area ;; (define (submegatest-panel dbstruct keydat testdat runname testconfig) (let* ((test-run-dir (db:test-get-rundir testdat)) (subarea (subrun:get-runarea test-run-dir)) - (area-exists (and subarea (common:file-exists? subarea silent: #t))) - (target #f) - (runname #f) - (cmd-parts-file (conc test-run-dir "/subrun-command-parts.sexp"))) - (if (file-exists? cmd-parts-file) ;; existance of this file is sufficient to *try* opening a dashboard - (let* ((cmd-parts (if (file-exists? cmd-parts-file) - (with-input-from-file cmd-parts-file - read) - '())) - (target (alist-ref "-target" cmd-parts equal?)) - (runname (alist-ref "-runname" cmd-parts equal?)) - (run-area (alist-ref "-startdir" cmd-parts equal?))) - (iup:frame - #:title "Megatest Run Info" ; #:expand "YES" - (iup:vbox - (iup:button - "Launch Dashboard" - #:action (lambda (obj) - (subrun:launch-dashboard test-run-dir))) - (iup:button - "Launch Dashboard+Filter" - #:action (lambda (obj) - (subrun:launch-dashboard test-run-dir target: target runname: runname)))))) - (iup:vbox )))) + (area-exists (and subarea (common:file-exists? subarea silent: #t)))) + (iup:frame + #:title "Megatest Run Info" ;; #:expand "HORIZONTAL" + (if subarea + (iup:button + "Launch Dashboard" + #:action (lambda (obj) + (subrun:launch-dashboard test-run-dir))) + (iup:vbox + (iup:label "Not a subrun..." #:expand "HORIZONTAL") + ))))) ;; use a global for setting the buttons colors ;; state status teststeps (define *state-status* (vector #f #f #f)) (define (update-state-status-buttons testdat) @@ -339,12 +341,12 @@ (lambda (state color) (for-each (lambda (btn) (let* ((name (iup:attribute btn "TITLE")) (newcolor (if (equal? name state) color "192 192 192"))) - (if (not (colors-similar? newcolor (iup:attribute btn "FGCOLOR"))) - (iup:attribute-set! btn "FGCOLOR" newcolor)))) + (if (not (colors-similar? newcolor (iup:attribute btn "BGCOLOR"))) + (iup:attribute-set! btn "BGCOLOR" newcolor)))) btns))) btns)) (apply iup:hbox (iup:label "STATUS:" #:size "30x") (let* ((btns (map (lambda (status) @@ -373,12 +375,12 @@ (lambda (status color) (for-each (lambda (btn) (let* ((name (iup:attribute btn "TITLE")) (newcolor (if (equal? name status) color "192 192 192"))) - (if (not (colors-similar? newcolor (iup:attribute btn "FGCOLOR"))) - (iup:attribute-set! btn "FGCOLOR" newcolor)))) + (if (not (colors-similar? newcolor (iup:attribute btn "BGCOLOR"))) + (iup:attribute-set! btn "BGCOLOR" newcolor)))) btns))) btns)))))) (define (dashboard-tests:run-a-step info) #t) @@ -473,13 +475,12 @@ ;;====================================================================== ;; ;;====================================================================== (define (dashboard-tests:examine-test run-id test-id) ;; run-id run-key origtest) - (let* ((db-path (db:dbfile-path)) ;; (conc (configf:lookup *configdat* "setup" "linktree") "/db/" run-id ".db")) - (dbstruct #f) ;; NOT ACTUALLY USED (db:setup)) ;; (make-dbr:dbstruct path: (db:dbfile-path #f) ;; (configf:lookup *configdat* "setup" "linktree") - ;; local: #t)) + (let* ((db-path (common:make-tmpdir-name *toppath* "")) ;; (conc (configf:lookup *configdat* "setup" "linktree") "/db/" run-id ".db")) + (dbstruct #f) ;; NOT USED (testdat (rmt:get-test-info-by-id run-id test-id)) ;; (db:get-test-info-by-id dbstruct run-id test-id)) (db-mod-time 0) ;; (file-modification-time db-path)) (last-update 0) ;; (current-seconds)) (request-update #t)) (if (not testdat) @@ -681,10 +682,19 @@ (conc "megatest -target " keystring " -runname " runname " -run -testpatt " (conc testname "/" (if (equal? item-path "") "%" item-path)) " -clean-cache" + )))) + (rerun-clean (lambda (x) + (iup:attribute-set! + command-text-box "VALUE" + (conc "megatest -target " keystring " -runname " runname + " -rerun-clean -testpatt " (conc testname "/" (if (equal? item-path "") + "%" + item-path)) + " -clean-cache" )))) (remove-test (lambda (x) (iup:attribute-set! command-text-box "VALUE" (conc "megatest -remove-runs -target " keystring " -runname " runname @@ -722,38 +732,52 @@ " -archive save-remove -testpatt " (conc testname "/" (if (equal? item-path "") "%" item-path)) ))))) (cond - ((not testdat)(begin (print "ERROR: bad test info for " test-id)(exit 1))) - ((not rundat)(begin (print "ERROR: found test info but there is a problem with the run info for " run-id)(exit 1))) + ((not testdat)(begin (debug:print 0 *default-log-port* "ERROR: bad test info for " test-id)(exit 1))) + ((not rundat)(begin (debug:print 0 *default-log-port* "ERROR: found test info but there is a problem with the run info for " run-id)(exit 1))) (else ;; (test-set-status! db run-id test-name state status itemdat) (set! self ; (iup:dialog #:close_cb (lambda (a)(exit)) ; #:expand "YES" #:title testfullname - (iup:vbox ; #:expand "YES" - ;; The run and test info - (iup:hbox ; #:expand "YES" - (run-info-panel dbstruct keydat testdat runname) - (test-info-panel testdat store-label widgets) - (test-meta-panel testmeta store-meta)) + (iup:vbox (iup:hbox - (host-info-panel testdat store-label) - (submegatest-panel dbstruct keydat testdat runname testconfig)) + (iup:vbox ; #:expand "YES" + ;; The run and test info + (iup:hbox ; #:expand "YES" + (run-info-panel dbstruct keydat testdat runname) + (test-info-panel testdat store-label widgets)) + (host-info-panel testdat store-label)) + (iup:vbox + (test-meta-panel testmeta store-meta) + (submegatest-panel dbstruct keydat testdat runname testconfig))) ;; The controls - (iup:frame #:title "Actions" + (iup:hbox ;; frame #:title "Actions" (iup:vbox - (iup:hbox - (iup:button "View Log" #:action viewlog #:size "80x") - (iup:button "Start Xterm" #:action xterm #:size "80x") - (iup:button "Run Test" #:action run-test #:size "80x") - (iup:button "Clean Test" #:action remove-test #:size "80x") - (iup:button "CleanRunExecute!" #:action clean-run-execute #:size "80x") - (iup:button "Kill All Jobs" #:action kill-jobs #:size "80x") - (iup:button "Archive Test" #:action archive-test #:size "80x") - (iup:button "Close" #:action (lambda (x)(exit)) #:size "80x")) + (iup:hbox + (iup:frame + #:title "Immediate" + (iup:hbox + (iup:button "Start Xterm" #:action xterm #:size "80x") + (iup:button "CleanRunExecute!" #:action clean-run-execute #:size "80x") + (iup:button "View Log" #:action viewlog #:size "80x"))) + (iup:frame + #:title "Command line" + (iup:hbox + (iup:button "Run Test" #:action run-test #:size "80x") + (iup:button "Rerun-clean" #:action rerun-clean #:size "80x") + (iup:button "Clean Test" #:action remove-test #:size "80x") + (iup:button "Kill All Jobs" #:action kill-jobs #:size "80x"))) + (iup:label "" #:expand "HORIZONTAL") + (iup:frame + #:title "Other" + (iup:hbox + ;; (iup:button "Archive Test" #:action archive-test #:size "80x") + (iup:button "Close" #:action (lambda (x)(exit)) #:size "80x") + ))) (apply iup:hbox (list command-text-box command-launch-button)))) (set-fields-panel dbstruct run-id test-id testdat) (let ((tabs @@ -772,11 +796,11 @@ (let* ((mtrx-rc (conc lin ":" 6)) (fname (iup:attribute obj mtrx-rc)) (stepname (iup:attribute obj (conc lin ":" 1))) (comment (iup:attribute obj (conc lin ":" 7)))) (case col - ((7) (print "Comment from step "stepname": "comment)) + ((7) (debug:print 0 *default-log-port* "Comment from step "stepname": "comment)) ((8) (ezsteps:spawn-run-from testdat stepname #t)) ((9) (ezsteps:spawn-run-from testdat stepname #f)) (else (view-a-log fname)))))))) ;; (let loop ((count 0)) ;; (iup:attribute-set! steps-matrix "FITTOTEXT" (conc "L" count)) ADDED dashboard-transport-mode.scm Index: dashboard-transport-mode.scm ================================================================== --- /dev/null +++ dashboard-transport-mode.scm @@ -0,0 +1,22 @@ +;;====================================================================== +;; set up transport, db cache and sync methods +;; +;; sync-method: 'original, 'attach or 'none +;; cache-method: 'tmp or 'none +;; rmt:transport-mode: 'http, 'tcp, 'nfs +;; +;; NOTE: NOT ALL COMBINATIONS WORK +;; +;;====================================================================== + +;; uncomment this block to test without tcp or cachedb +;; (dbfile:sync-method 'none) +;; (dbfile:cache-method 'none) +;; (rmt:transport-mode 'nfs) + +;; uncomment this block to test with tcp and cachedb +(dbfile:sync-method 'none) ;; original was causing crash on start. +(dbfile:cache-method 'none) +(rmt:transport-mode 'nfs) + + ADDED dashboard-transport-mode.scm.template Index: dashboard-transport-mode.scm.template ================================================================== --- /dev/null +++ dashboard-transport-mode.scm.template @@ -0,0 +1,22 @@ +;;====================================================================== +;; set up transport, db cache and sync methods +;; +;; sync-method: 'original, 'attach or 'none +;; cache-method: 'tmp or 'none +;; rmt:transport-mode: 'http, 'tcp, 'nfs +;; +;; NOTE: NOT ALL COMBINATIONS WORK +;; +;;====================================================================== + +;; uncomment this block to test without tcp or cachedb +;; (dbfile:sync-method 'none) +;; (dbfile:cache-method 'none) +;; (rmt:transport-mode 'nfs) + +;; uncomment this block to test with tcp and cachedb +(dbfile:sync-method 'none) ;; original was causing crash on start. +(dbfile:cache-method 'none) +(rmt:transport-mode 'nfs) + + Index: dashboard.scm ================================================================== --- dashboard.scm +++ dashboard.scm @@ -16,224 +16,226 @@ ;; You should have received a copy of the GNU General Public License ;; along with Megatest. If not, see . ;; ;;====================================================================== -(use format) - -(require-library iup) -(import (prefix iup iup:)) - -(use canvas-draw) -(import canvas-draw-iup) -(use ducttape-lib) -(use sqlite3 srfi-1 posix regex regex-case srfi-69 typed-records sparse-vectors) ;; defstruct -(import (prefix sqlite3 sqlite3:)) - (declare (uses common)) -(declare (uses margs)) +(declare (uses mtargs)) +(declare (uses mtargs.import)) (declare (uses keys)) (declare (uses items)) +(declare (uses debugprint)) +(declare (uses debugprint.import)) (declare (uses db)) (declare (uses configf)) (declare (uses process)) (declare (uses launch)) (declare (uses runs)) (declare (uses dashboard-tests)) -(declare (uses dashboard-guimonitor)) (declare (uses tree)) (declare (uses dcommon)) (declare (uses dashboard-context-menu)) (declare (uses vg)) (declare (uses subrun)) -;; (declare (uses dashboard-main)) (declare (uses mt)) +(declare (uses dbmod)) +(declare (uses dbfile)) +(declare (uses dbfile.import)) +(declare (uses rmtmod)) +(declare (uses rmtmod.import)) +(declare (uses commonmod)) +(declare (uses commonmod.import)) + +(use format) + +(require-library iup) +(import (prefix iup iup:)) + +(use canvas-draw) +(import canvas-draw-iup + (prefix sqlite3 sqlite3:)) + +(use ducttape-lib) +(use sqlite3 srfi-1 posix regex regex-case srfi-69 typed-records sparse-vectors) ;; defstruct + +(import commonmod + (prefix mtargs args:) + dbmod + dbfile + rmtmod + debugprint) (include "common_records.scm") (include "db_records.scm") (include "run_records.scm") (include "task_records.scm") (include "megatest-version.scm") (include "megatest-fossil-hash.scm") (include "vg_records.scm") +;; set some parameters here - these need to be put in something that can be loaded from other +;; executables such as dashboard and mtutil +;; +(include "dashboard-transport-mode.scm") +(dbfile:db-init-proc db:initialize-main-db) +(set! rmtmod:send-receive rmt:send-receive) + +(debug:print-info 0 *default-log-port* "transport-mode="(rmt:transport-mode)) + (define help (conc - "Megatest Dashboard, documentation at http://www.kiatoa.com/fossils/megatest - version " megatest-version " - license GPL, Copyright (C) Matt Welland 2012-2017 + "Megatest Dashboard, documentation at http://www.kiatoa.com/fossils/megatest version " megatest-version + " license GPL, Copyright (C) Matt Welland 2012-2017 Usage: dashboard [options] -h : this help - -test run-id,test-id : control test identified by testid + -test run-id test-id : open a test control panel on this test -skip-version-check : skip the version check - -use-db-cache : access database via cache - -target T : prefill target filter with given target pattern - -runname R : prefill runname filter with given runname pattern - -testpatt P : prefill testpatt filter with given testpatt - -Misc -rows R : set number of rows -cols C : set number of columns -")) + -start-dir dir : start dashboard in the given directory + -target target : filter runs tab to given target. + -debug n[,n] : set debug level(s) e.g. -debug 4 or -debug 0,9 + -repl : Start a chicken scheme interpreter + -mode MODE : tcp or nfs +" +)) -;; -server host:port : connect to host:port instead of db access -;; -xterm run-id,test-id : Start a new xterm with specified run-id and test-id -;; -guimonitor : control panel for runs ;; process args (define remargs (args:get-args (argv) + ;; parameters (need arguments) (list "-rows" "-cols" - "-run" - "-test" - "-xterm" - "-debug" - "-host" - "-transport" - "-start-dir" - "-target" ;; use as filter - "-runname" ;; use as filter - "-testpatt" ;; use as filter - ) - (list "-h" - "-use-server" - "-guimonitor" - "-main" - "-v" - "-q" - "-use-db-cache" + "-test" ;; given a run id and test id, open only a test control panel on that test.. + "-debug" + "-start-dir" + "-target" + "-mode" ;; tcp or nfs + ) + ;; switches (don't take arguments) + (list "-h" "-skip-version-check" "-repl" - "-rh5.11" ;; fix to allow running on rh5.11 "-:p" ;; ignore the built in chicken profiling switch ) args:arg-hash 0)) -;; check for MT_* environment variables and exit if found -(if (not (args:get-arg "-test")) - (begin - (display "Checking for MT_ vars: ") - (for-each (lambda (var) - (display " ")(display var) - (if (get-environment-variable var) - (begin - (print "ERROR: environment variable " var " is set in this terminal, this will cause you problems. Exiting now.") - (exit 1)))) - '("MT_RUN_AREA_HOME" "MT_MEGATEST" "MT_CMDINFO" "MT_TEST_RUN_DIR" "MT_LINKTREE" "MT_TESTSUITENAME")) - (print ". Done. All ok."))) - -(if (not (null? remargs)) - (begin - (print "Unrecognised arguments: " (string-intersperse remargs " ")) - (exit))) - -(if (args:get-arg "-h") - (begin - (print help) - (exit))) - -(if (args:get-arg "-start-dir") - (if (directory-exists? (args:get-arg "-start-dir")) - (let ((fullpath (common:real-path (args:get-arg "-start-dir")))) - (setenv "PWD" fullpath) - (change-directory fullpath)) - (begin - (debug:print-error 0 *default-log-port* "non-existant start dir " (args:get-arg "-start-dir") " specified, exiting.") - (exit 1)))) - -;; TODO: Move this inside (main) -;; -(if (not (launch:setup)) - (begin - (print "Failed to find megatest.config, exiting") - (exit 1))) - -;; deal with RH 5.11 gtk lib or iup lib missing detachbox feature -;; first check for the switch -;; -(if (or (args:get-arg "-rh5.11") - (configf:lookup *configdat* "dashboard" "no-detachbox") - (not (file-exists? "/etc/os-release"))) - (set! iup:detachbox iup:vbox)) - -(if (not (common:on-homehost?)) - (begin - (debug:print 0 *default-log-port* "WARNING: Current policy requires running dashboard on homehost: " (common:get-homehost)))) - +(if (args:get-arg "-mode") + (let* ((mode (string->symbol (args:get-arg "-mode")))) + (rmt:transport-mode mode))) +;; (rmt:transport-mode 'tcp)) + +(if (args:get-arg "-test") ;; need to use tcp for test control panel + (rmt:transport-mode 'tcp)) + ;; RA => Might require revert for filters ;; create a watch dog to move changes from lt/.db/*.db to megatest.db ;; ;;;(if (file-write-access? (conc *toppath* "/megatest.db")) ;;(debug:print-info 13 *default-log-port* "Before common:watchdog spawn") -(thread-start! (make-thread common:watchdog "Watchdog thread")) +;; (thread-start! (make-thread common:watchdog "Watchdog thread")) ;;(debug:print-info 13 *default-log-port* "After common:watchdog spawn") ;; (if (not (args:get-arg "-use-db-cache")) ;; (begin ;; (debug:print-info 0 *default-log-port* "Forcing db-cache mode due to read-only access to megatest.db") ;; (hash-table-set! args:arg-hash "-use-db-cache" #t)));;;) ;;) ;; data common to all tabs goes here ;; -(defstruct dboard:commondat - ((curr-tab-num 0) : number) - please-update - tabdats - update-mutex - updaters - updating - uidat ;; needs to move to tabdat at some time - hide-not-hide-tabs - ) - -(define (dboard:commondat-make) - (make-dboard:commondat - curr-tab-num: 0 - tabdats: (make-hash-table) - please-update: #t - update-mutex: (make-mutex) - updaters: (make-hash-table) - updating: #f - hide-not-hide-tabs: #f - )) - -;; RA => returns the tabdat stored at hashkey passed in commondat-tabdats table (e.g. 0 gives summary) -;; -(define (dboard:common-get-tabdat commondat #!key (tab-num #f)) - (let* ((tnum (or tab-num - (dboard:commondat-curr-tab-num commondat) - 0)) ;; tab-num value is curr-tab-num value in passed commondat - (ht (dboard:commondat-tabdats commondat)) - (res (hash-table-ref/default ht tnum #f))) - (or res - (let ((new-tabdat (dboard:tabdat-make-data))) - (hash-table-set! ht tnum new-tabdat) - new-tabdat)))) - -;; RA => sets the tabdat passed to the hashkey at commondat:tabdats hash table -;; -(define (dboard:common-set-tabdat! commondat tabnum tabdat) - (hash-table-set! - (dboard:commondat-tabdats commondat) - tabnum - tabdat)) +;; Moved to dcommon.scm +;; +;; (defstruct dboard:commondat +;; ((curr-tab-num 0) : number) +;; please-update +;; tabdats +;; update-mutex +;; updaters +;; updating +;; uidat ;; needs to move to tabdat at some time +;; hide-not-hide-tabs +;; target +;; ) +;; +;; (define (dboard:commondat-make) +;; (make-dboard:commondat +;; curr-tab-num: 0 +;; tabdats: (make-hash-table) +;; please-update: #t +;; update-mutex: (make-mutex) +;; updaters: (make-hash-table) +;; updating: #f +;; hide-not-hide-tabs: #f +;; target: "" +;; )) + +(set! *journal-stats-enable* #f) + +;;====================================================================== +;; buttons color using image +;;====================================================================== + +(define *images* (make-hash-table)) + +(define (make-image images name color) + (if (hash-table-exists? images name) + name + (let* ((img-bits1 (u8vector->blob (u8vector + 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 + 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 + 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 + 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 + 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 + 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 + 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 + 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 + 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 + 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 + 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 + 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 + 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 + 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 + 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 + 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 + 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 + 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 + 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 + 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 + 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 + 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 + 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 + 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 + ))) + ;; w h + (img1 (iup:image/palette 16 24 img-bits1))) + (iup:handle-name-set! img1 name) + ;; (iup:attribute-set! img1 "0" "0 0 0") + (iup:attribute-set! img1 "1" color) ;; "BGCOLOR") + ;; (iup:attribute-set! img1 "2" "255 0 0") + (hash-table-set! images name img1) + name))) + ;; gets and calls updater list based on curr-tab-num ;; (define (dboard:common-run-curr-updaters commondat #!key (tab-num #f)) + ;; (sync-db-to-tmp (dboard:common-get-tabdat commondat tab-num: tab-num)) ;; no longer applies + + ;; maybe need sleep here? + (if (dboard:common-get-tabdat commondat tab-num: tab-num) ;; only update if there is a tabdat (let* ((tnum (or tab-num (dboard:commondat-curr-tab-num commondat))) (updaters (hash-table-ref/default (dboard:commondat-updaters commondat) tnum '()))) (debug:print 4 *default-log-port* "Found these updaters: " updaters " for tab-num: " tnum) (for-each ;; perform the function calls for the complete updaters list (lambda (updater) - ;; (debug:print 3 *default-log-port* "Running " updater) + ;; (debug:print 3 *default-log-port* "Running " updater) (updater)) updaters)))) ;; if tab-num passed in then use it, otherwise look in commondat at curr-tab-num ;; adds the updater passed in the updaters list at that hashkey @@ -357,18 +359,18 @@ tests-tree ;; used in newdashboard ) ;; register tabdat with BBpp ;; this is used by BBpp (Brandon's pretty printer) to convert dboard:tabdat into a composition of lists that pp will handle -(hash-table-set! *BBpp_custom_expanders_list* TABDAT: - (cons dboard:tabdat? - (lambda (tabdat-item) - (filter - (lambda (alist-entry) - (member (car alist-entry) - '(allruns-by-id allruns))) ;; FIELDS OF INTEREST - (dboard:tabdat->alist tabdat-item))))) +;; (hash-table-set! *BBpp_custom_expanders_list* TABDAT: +;; (cons dboard:tabdat? +;; (lambda (tabdat-item) +;; (filter +;; (lambda (alist-entry) +;; (member (car alist-entry) +;; '(allruns-by-id allruns))) ;; FIELDS OF INTEREST +;; (dboard:tabdat->alist tabdat-item))))) (define (dboard:tabdat-target-string vec) (let ((targ (dboard:tabdat-target vec))) @@ -386,17 +388,17 @@ (dboard:setup-tabdat dat) (dboard:setup-num-rows dat) dat)) (define (dboard:setup-tabdat tabdat) - (dboard:tabdat-dbdir-set! tabdat (db:dbfile-path)) ;; (conc (configf:lookup *configdat* "setup" "linktree") "/.db")) - (dboard:tabdat-dbfpath-set! tabdat (db:dbfile-path)) + (dboard:tabdat-dbdir-set! tabdat (common:make-tmpdir-name *toppath* "")) ;; (conc (configf:lookup *configdat* "setup" "linktree") "/.db")) + (dboard:tabdat-dbfpath-set! tabdat (common:make-tmpdir-name *toppath* "")) (dboard:tabdat-monitor-db-path-set! tabdat (conc (dboard:tabdat-dbdir tabdat) "/monitor.db")) + ;; HACK ALERT: this is a hack, please fix. (dboard:tabdat-ro-set! tabdat (not (file-read-access? (dboard:tabdat-dbfpath tabdat)))) - (dboard:tabdat-keys-set! tabdat (rmt:get-keys)) (dboard:tabdat-dbkeys-set! tabdat (append (dboard:tabdat-keys tabdat) (list "runname"))) (dboard:tabdat-tot-runs-set! tabdat (rmt:get-num-runs "%")) ) @@ -421,27 +423,29 @@ (make-dboard:runsdat runs-index: (make-hash-table) tests-index: (make-hash-table) matrix-dat: (make-sparse-array))) -;; used to keep the rundata from rmt:get-tests-for-run -;; in sync. +;; duplicated in dcommon.scm ;; -(defstruct dboard:rundat - run - tests-drawn ;; list of id's already drawn on screen - tests-notdrawn ;; list of id's NOT already drawn - rowsused ;; hash of lists covering what areas used - replace with quadtree - hierdat ;; put hierarchial sorted list here - tests ;; hash of id => testdat - ((tests-by-name (make-hash-table)) : hash-table) ;; hash of testfullname => testdat - key-vals - ((last-update 0) : number) ;; last query to db got records from before last-update - ((last-db-time 0) : number) ;; last timestamp on megatest.db - ((data-changed #f) : boolean) - ((run-data-offset 0) : number) ;; get only 100 items per call, set back to zero when received less than 100 items - (db-path #f)) +;; ;; used to keep the rundata from rmt:get-tests-for-run +;; ;; in sync. +;; ;; +;; (defstruct dboard:rundat +;; run +;; tests-drawn ;; list of id's already drawn on screen +;; tests-notdrawn ;; list of id's NOT already drawn +;; rowsused ;; hash of lists covering what areas used - replace with quadtree +;; hierdat ;; put hierarchial sorted list here +;; tests ;; hash of id => testdat +;; ((tests-by-name (make-hash-table)) : hash-table) ;; hash of testfullname => testdat +;; key-vals +;; ((last-update 0) : number) ;; last query to db got records from before last-update +;; ((last-db-time 0) : number) ;; last timestamp on main.db +;; ((data-changed #f) : boolean) +;; ((run-data-offset 0) : number) ;; get only 100 items per call, set back to zero when received less than 100 items +;; (db-path #f)) ;; for the new runs view lets build up a few new record types and then consolidate later ;; ;; this is a two level deep pipeline for the incoming data: ;; sql query data ==> filters ==> data for display @@ -507,18 +511,18 @@ duration ) ;; register dboard:rundat with BBpp ;; this is used by BBpp (Brandon's pretty printer) to convert dboard:rundat into a composition of lists that pp will handle -(hash-table-set! *BBpp_custom_expanders_list* RUNDAT: - (cons dboard:rundat? - (lambda (tabdat-item) - (filter - (lambda (alist-entry) - (member (car alist-entry) - '(run run-data-offset ))) ;; FIELDS OF INTEREST - (dboard:rundat->alist tabdat-item))))) +;; (hash-table-set! *BBpp_custom_expanders_list* RUNDAT: +;; (cons dboard:rundat? +;; (lambda (tabdat-item) +;; (filter +;; (lambda (alist-entry) +;; (member (car alist-entry) +;; '(run run-data-offset ))) ;; FIELDS OF INTEREST +;; (dboard:rundat->alist tabdat-item))))) (define (dboard:rundat-make-init #!key (run #f)(key-vals #f)(tests #f));; -100 is before time began @@ -584,10 +588,12 @@ 3))) (define (get-curr-sort) (vector-ref *tests-sort-options* *tests-sort-reverse*)) +;;====================================================================== + (debug:setup) ;; (define uidat #f) (define-inline (dboard:uidat-get-keycol vec)(vector-ref vec 0)) @@ -651,14 +657,14 @@ ;; (define (dboard:get-tests-for-run-duplicate tabdat run-id run testnamepatt key-vals) (let* ((start-time (current-seconds)) (access-mode (dboard:tabdat-access-mode tabdat)) (num-to-get (string->number (or (configf:lookup *configdat* "setup" "num-tests-to-get") - "200"))) + "1000"))) (states (hash-table-keys (dboard:tabdat-state-ignore-hash tabdat))) (statuses (hash-table-keys (dboard:tabdat-status-ignore-hash tabdat))) - (do-not-use-db-file-timestamps #t) ;; (configf:lookup *configdat* "setup" "do-not-use-db-file-timestamps")) ;; this still hosts runs-summary-tab + (do-not-use-db-file-timestamps #f) ;; (configf:lookup *configdat* "setup" "do-not-use-db-file-timestamps")) ;; this still hosts runs-summary-tab (do-not-use-query-timestamps #t) ;; (configf:lookup *configdat* "setup" "do-not-use-query-timestamps")) ;; this no longer troubles runs-summary-tab (sort-info (get-curr-sort)) (sort-by (vector-ref sort-info 1)) (sort-order (vector-ref sort-info 2)) (bubble-type (if (member sort-order '(testname)) @@ -677,13 +683,13 @@ (dboard:rundat-last-update run-dat))) (last-db-time (if do-not-use-db-file-timestamps 0 (dboard:rundat-last-db-time run-dat))) (db-path (or (dboard:rundat-db-path run-dat) - (let* ((db-dir (common:get-db-tmp-area)) - (db-pth (conc db-dir "/megatest.db"))) - (dboard:rundat-db-path-set! run-dat db-pth) + (let* ((db-dir (get-environment-variable "MT_RUN_AREA_HOME")) ;; (common:get-db-tmp-area)) + (db-pth (conc db-dir "/.mtdb/*.db"))) + (dboard:rundat-db-path-set! run-dat db-pth) ;; this is just a cache of the path db-pth))) (db-mod-time (common:lazy-sqlite-db-modification-time db-path)) (db-modified (>= db-mod-time last-db-time)) (multi-get (> (dboard:rundat-run-data-offset run-dat) 0)) ;; multi-get in progress (tmptests (if (or do-not-use-db-file-timestamps @@ -693,11 +699,11 @@ (dboard:rundat-run-data-offset run-dat) ;; query offset num-to-get (dboard:tabdat-hide-not-hide tabdat) ;; no-in sort-by ;; sort-by sort-order ;; sort-order - #f ;; 'shortlist ;; qrytype + 'shortlist ;; qrytype (was #f) last-update ;; last-update *dashboard-mode*) ;; use dashboard mode '())) (use-new (dboard:tabdat-hide-not-hide tabdat)) (tests-ht (if (dboard:tabdat-filters-changed tabdat) @@ -705,15 +711,15 @@ (dboard:rundat-tests-set! run-dat ht) ht) (dboard:rundat-tests run-dat))) (got-all (< (length tmptests) num-to-get)) ;; got all for this round ) - + ;; (debug:print-info 0 *default-log-port* "got-all="got-all", (hash-table-size tests-ht)="(hash-table-size tests-ht)) ;; if we saw the db modified, reset it (the signal has already been used) (if (and got-all ;; (not multi-get) db-modified) - (dboard:rundat-last-db-time-set! run-dat (- start-time 2))) + (dboard:rundat-last-db-time-set! run-dat (- start-time 2))) ;; to limit the amount of data transferred each cycle use limit of num-to-get and offset ;; DO NOT bump time indexes last-update and last-db-time until all the first pass of the ;; data has been read ;; set last-update to 0 if still getting data incrementally ;; NO NEED, handled above @@ -729,16 +735,16 @@ (for-each (lambda (tdat) (let ((test-id (db:test-get-id tdat)) (state (db:test-get-state tdat))) - (dboard:rundat-data-changed-set! run-dat #t) - (if (equal? state "DELETED") - (hash-table-delete! tests-ht test-id) - (hash-table-set! tests-ht test-id tdat)))) - tmptests) - + (dboard:rundat-data-changed-set! run-dat #t) + (if (equal? state "DELETED") + (hash-table-delete! tests-ht test-id) + (hash-table-set! tests-ht test-id tdat)))) + tmptests) + tests-ht)) ;; tmptests - new tests data ;; prev-tests - old tests data ;; @@ -824,19 +830,25 @@ (hash-table-delete! (dboard:tabdat-allruns-by-id tabdat) run-id) (hash-table-set! (dboard:tabdat-allruns-by-id tabdat) run-id run-struct)) (if (or (null? tal) (> elapsed-time 2)) ;; stop loading data after 5 seconds, on the next call more data *should* be loaded since get-tests-for-run uses last update (begin - (if (> elapsed-time 2)(print "WARNING: timed out in update-testdat " elapsed-time "s")) + (if (> elapsed-time 2)(debug:print 0 *default-log-port* "WARNING: timed out in update-testdat " elapsed-time "s")) (dboard:tabdat-allruns-set! tabdat new-res) maxtests) (if (> (dboard:rundat-run-data-offset run-struct) 0) (loop run tal new-res newmaxtests) ;; not done getting data for this run (loop (car tal)(cdr tal) new-res newmaxtests))))))) (dboard:tabdat-filters-changed-set! tabdat #f) (dboard:update-tree tabdat runs-hash header tb))) + +(define *dashboard-last-run-id-update* (make-hash-table)) ;; id => seconds + +(define (dboard:clear-run-id-update-hash) + (hash-table-clear! *dashboard-last-run-id-update*)) + ;; this calls dboard:get-tests-for-run-duplicate for each run ;; ;; create a virtual table of all the tests ;; keypatts: ( (KEY1 "abc%def")(KEY2 "%") ) ;; @@ -869,65 +881,82 @@ (dboard:tabdat-item-test-names-set! tabdat '()) (hash-table-clear! (dboard:tabdat-allruns-by-id tabdat))) (let loop ((run (car runs)) (tal (cdr runs)) (res '()) - (maxtests 0)) + (maxtests 0) + (cont-run #f)) (let* ((run-id (db:get-value-by-header run header "id")) + (recently-done (< (- (current-seconds) + (hash-table-ref/default *dashboard-last-run-id-update* run-id 0)) 1)) (run-struct (hash-table-ref/default (dboard:tabdat-allruns-by-id tabdat) run-id #f)) ;; (last-update (if run-struct (dboard:rundat-last-update run-struct) 0)) (key-vals (rmt:get-key-vals run-id)) - (tests-ht (dboard:get-tests-for-run-duplicate tabdat run-id run testnamepatt key-vals)) + (tests-ht (let* ((tht (if (and recently-done run-struct) + (let ((rht (dboard:rundat-tests run-struct))) ;; (dboard:tabdat-allruns-by-id tabdat))) + (or rht + (dboard:get-tests-for-run-duplicate tabdat run-id run testnamepatt key-vals))) + (dboard:get-tests-for-run-duplicate tabdat run-id run testnamepatt key-vals)))) + (assert (hash-table? tht) "FATAL: But here tht should be a hash-table") + tht)) ;; GET RID OF dboard:get-tests-dat - it is superceded by dboard:get-tests-for-run-duplicate ;; dboard:get-tests-for-run-duplicate - returns a hash table ;; (dboard:get-tests-dat tabdat run-id last-update)) (all-test-ids (hash-table-keys tests-ht)) - (num-tests (length all-test-ids))) - ;; (print "run-struct: " run-struct) - ;; NOTE: bubble-up also sets the global (dboard:tabdat-item-test-names tabdat) - ;; (tests (bubble-up tmptests priority: bubble-type)) - ;; NOTE: 11/01/2013 This routine is *NOT* getting called excessively. - ;; (debug:print 0 *default-log-port* "Getting data for run " run-id " with key-vals=" key-vals) - ;; Not sure this is needed? - (let* ((newmaxtests (max num-tests maxtests)) - ;; (last-update (- (current-seconds) 10)) - (run-struct (or run-struct - (dboard:rundat-make-init - run: run - tests: tests-ht - key-vals: key-vals))) - (new-res (if (null? all-test-ids) - res - (delete-duplicates - (cons run-struct res) - (lambda (a b) - (eq? (db:get-value-by-header (dboard:rundat-run a) header "id") - (db:get-value-by-header (dboard:rundat-run b) header "id")))))) - (elapsed-time (- (current-seconds) start-time))) - (if (null? all-test-ids) + (num-tests (length all-test-ids)) + ;; (print "run-struct: " run-struct) + ;; NOTE: bubble-up also sets the global (dboard:tabdat-item-test-names tabdat) + ;; (tests (bubble-up tmptests priority: bubble-type)) + ;; NOTE: 11/01/2013 This routine is *NOT* getting called excessively. + ;; (debug:print 0 *default-log-port* "Getting data for run " run-id " with key-vals=" key-vals) + ;; Not sure this is needed? + (newmaxtests (max num-tests maxtests)) + ;; (last-update (- (current-seconds) 10)) + (run-struct (or run-struct + (dboard:rundat-make-init + run: run + tests: tests-ht + key-vals: key-vals))) + (new-res (if (null? all-test-ids) + res + (delete-duplicates + (cons run-struct res) + (lambda (a b) + (eq? (db:get-value-by-header (dboard:rundat-run a) header "id") + (db:get-value-by-header (dboard:rundat-run b) header "id")))))) + (elapsed-time (- (current-seconds) start-time))) + (if (null? all-test-ids) (hash-table-delete! (dboard:tabdat-allruns-by-id tabdat) run-id) (hash-table-set! (dboard:tabdat-allruns-by-id tabdat) run-id run-struct)) - (if (or (null? tal) - (> elapsed-time 2)) ;; stop loading data after 5 seconds, on the next call more data *should* be loaded since get-tests-for-run uses last update - (begin - (when (> elapsed-time 2) - (debug:print 0 *default-log-port* "NOTE: updates are taking a long time, " elapsed-time "s elapsed.") - (let* ((old-val (iup:attribute *tim* "TIME")) - (new-val (number->string (inexact->exact (floor (* 2 (string->number old-val))))))) - (if (< (string->number new-val) 5000) - ((debug:print 0 *default-log-port* "NOTE: increasing poll interval from "old-val" to "new-val) - (iup:attribute-set! *tim* "TIME" new-val)))) - - - ) - (dboard:tabdat-allruns-set! tabdat new-res) - maxtests) - (if (> (dboard:rundat-run-data-offset run-struct) 0) - (loop run tal new-res newmaxtests) ;; not done getting data for this run - (loop (car tal)(cdr tal) new-res newmaxtests))))))) - (dboard:tabdat-filters-changed-set! tabdat #f) - (dboard:update-tree tabdat runs-hash header tb))) + + (if (or (null? tal) + (> elapsed-time 2)) ;; stop loading data after 5 + ;; seconds, on the next call + ;; more data *should* be + ;; loaded since + ;; get-tests-for-run uses last + ;; update + (begin + (when (> elapsed-time 2) + (debug:print 2 *default-log-port* "NOTE: updates are taking a long time, " elapsed-time "s elapsed.") + (let* ((old-val (iup:attribute *tim* "TIME")) + (new-val (number->string (inexact->exact (floor (* 2 (string->number old-val))))))) + (if (< (string->number new-val) 5000) + (begin + (debug:print 2 *default-log-port* "NOTE: increasing poll interval from "old-val" to "new-val) + (iup:attribute-set! *tim* "TIME" new-val))))) + (dboard:tabdat-allruns-set! tabdat new-res) + maxtests) + (if (> (dboard:rundat-run-data-offset run-struct) 0) + (begin + (thread-sleep! 0.2) ;; let the gui re-draw + (loop run tal new-res newmaxtests #t)) ;; not done getting data for this run + (begin + (hash-table-set! *dashboard-last-run-id-update* run-id (current-seconds)) + (loop (car tal)(cdr tal) new-res newmaxtests #f))))))) + (dboard:tabdat-filters-changed-set! tabdat #f) + (dboard:update-tree tabdat runs-hash header tb))) (define *collapsed* (make-hash-table)) (define (toggle-hide lnum uidat) ; fulltestname) (let* ((btn (vector-ref (dboard:uidat-get-lftcol uidat) lnum)) @@ -1006,65 +1035,86 @@ (iup:attribute-set! lbl "TITLE" munged-val))) (iup:attribute-set! lbl "FGCOLOR" (if (hash-table-ref/default *collapsed* newval #f) "0 112 112" "0 0 0")) (if (< i maxn) (loop (+ i 1))))))) -;; + (define (get-itemized-tests test-dats) (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 (and (list? tnames) (string? tname) (not (member tname tnames))) - (set! tnames (append tnames (list tname))))))) + (set! tnames (cons tname tnames)))))) test-dats) - tnames)) + (reverse 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 tabdat test-dats #!key (priority 'itempath)) (if (null? test-dats) test-dats (begin (let* ((tnames '()) ;; list of names used to reserve order - (tests (make-hash-table)) ;; hash of lists, used to build as we go + (tests-ht (make-hash-table)) ;; hash of lists, used to build as we go (itemized (get-itemized-tests test-dats))) - (for-each + #;(for-each (lambda (testdat) (let* ((tname (vector-ref testdat 0)) ;; db:test-get-testname testdat)) (ipath (vector-ref testdat 1))) ;; db:test-get-item-path testdat))) - ;; (seen (hash-table-ref/default tests tname #f))) + ;; (seen (hash-table-ref/default tests-th tname #f))) (if (not (member tname tnames)) (if (or (and (eq? priority 'itempath) (not (equal? ipath ""))) (and (eq? priority 'testname) (equal? ipath "")) (not (member tname itemized))) (set! tnames (append tnames (list tname))))) (if (equal? ipath "") ;; This a top level, prepend it - (hash-table-set! tests tname (cons testdat (hash-table-ref/default tests tname '()))) + (hash-table-set! tests-ht tname (cons testdat (hash-table-ref/default tests-ht tname '()))) ;; This is item, append it - (hash-table-set! tests tname (append (hash-table-ref/default tests tname '())(list testdat)))))) + (hash-table-set! tests-ht tname (append (hash-table-ref/default tests-ht tname '())(list testdat)))))) + test-dats) + ;; 1. put all test/items into lists in tests-ht + (for-each + (lambda (testdat) + (let* ((tname (vector-ref testdat 0)) ;; db:test-get-testname testdat)) + (ipath (vector-ref testdat 1))) ;; db:test-get-item-path testdat))) + ;; (seen (hash-table-ref/default tests-ht tname #f))) + (if (not (member tname tnames)) + (if (or (and (eq? priority 'itempath) + (not (equal? ipath ""))) + (and (eq? priority 'testname) + (equal? ipath "")) + (not (member tname itemized))) + (set! tnames (append tnames (list tname))))) + (hash-table-set! tests-ht tname (cons testdat (hash-table-ref/default tests-ht tname '()))))) test-dats) + ;; now bubble up the non-item test in itemized tests + (hash-table-for-each + tests-ht + (lambda (k v) + (if (> (length v) 1) ;; must be itemized, push the no-item to the front + (hash-table-set! tests-ht k (sort v (lambda (a b)(not (equal? (vector-ref b 1) "")))))))) ;; Set all tests with items (dboard:tabdat-item-test-names-set! tabdat (append (if (null? tnames) '() (filter (lambda (tname) - (let ((tlst (hash-table-ref tests tname))) + (let ((tlst (hash-table-ref tests-ht tname))) (and (list tlst) (> (length tlst) 1)))) tnames)) (dboard:tabdat-item-test-names tabdat))) (let loop ((hed (car tnames)) (tal (cdr tnames)) (res '())) - (let ((newres (append res (hash-table-ref tests hed)))) + (let ((newres (append res (hash-table-ref tests-ht hed)))) (if (null? tal) newres (loop (car tal)(cdr tal) newres)))))))) ;; optimized to get runs constrained by what is visible on the screen @@ -1071,16 +1121,18 @@ ;; - not appropriate for where all the runs are needed ;; (define (update-buttons tabdat uidat numruns numtests) (let* ((runs (if (> (length (dboard:tabdat-allruns tabdat)) numruns) (take-right (dboard:tabdat-allruns tabdat) numruns) - (pad-list (dboard:tabdat-allruns tabdat) numruns))) + (pad-list (dboard:tabdat-allruns tabdat) numruns))) (lftcol (dboard:uidat-get-lftcol uidat)) (tableheader (dboard:uidat-get-header uidat)) (table (dboard:uidat-get-runsvec uidat)) (coln 0) - (all-test-names (make-hash-table))) + (all-test-names (make-hash-table)) + (use-bgcolor (equal? (configf:lookup *configdat* "dashboard" "use-bgcolor") "yes")) ;; doesn't work + ) ;; create a concise list of test names ;; (for-each (lambda (rundat) (if rundat @@ -1112,15 +1164,15 @@ (drop (dboard:tabdat-all-test-names tabdat) (dboard:tabdat-start-test-offset tabdat)) '()))) (append xl (make-list (- (dboard:tabdat-num-tests tabdat) (length xl)) "")))) (update-labels uidat (dboard:tabdat-all-test-names tabdat)) - (for-each + (for-each ;;run (lambda (rundat) - ;; if rundat is junk clobber it with a decent placeholder (if (or (not rundat) ;; handle padded runs (not (dboard:rundat-run rundat))) + ;; Need to put an empty column in to erase previous contents. (set! rundat (dboard:rundat-make-init key-vals: (map (lambda (x) "")(dboard:tabdat-keys tabdat))))) (let* ((run (dboard:rundat-run rundat)) (testsdat-by-name (dboard:rundat-tests-by-name rundat)) (key-val-dat (dboard:rundat-key-vals rundat)) @@ -1127,23 +1179,22 @@ (run-id (db:get-value-by-header run (dboard:tabdat-header tabdat) "id")) (key-vals (append key-val-dat (list (let ((x (db:get-value-by-header run (dboard:tabdat-header tabdat) "runname"))) (if (string? x) x ""))))) (run-key (string-intersperse key-vals "\n"))) - + ;; fill in the run header key values ;; - (let ((rown 0) + (let ((rown 0) (headercol (vector-ref tableheader coln))) (for-each (lambda (kval) (let* ((labl (vector-ref headercol rown))) (if (not (equal? kval (iup:attribute labl "TITLE"))) (iup:attribute-set! (vector-ref headercol rown) "TITLE" kval)) (set! rown (+ rown 1)))) key-vals)) - - ;; For this run now fill in the buttons for each test + ;; For this run now fill in the buttons for each test ;; (let ((rown 0) (columndat (vector-ref table coln))) (for-each (lambda (testname) @@ -1156,17 +1207,12 @@ ;; testsdat))) (if (not matching) (vector -1 -1 "" "" "" 0 "" "" 0 "" "" "" 0 "" "") ;; (car matching)))) matching))) - (testname (db:test-get-testname testdat)) - (itempath (db:test-get-item-path testdat)) - (testfullname (test:test-get-fullname testdat)) (teststatus (db:test-get-status testdat)) (teststate (db:test-get-state testdat)) - ;;(teststart (db:test-get-event_time test)) - ;;(runtime (db:test-get-run_duration test)) (buttontxt (cond ((member teststate '("COMPLETED" "ARCHIVED")) teststatus) ((and (equal? teststate "NOT_STARTED") (member teststatus '("ZERO_ITEMS" "BLOCKED" "PREQ_FAIL" "PREQ_DISCARDED" "TIMED_OUT" "KEEP_TRYING" "TEN_STRIKES"))) teststatus) @@ -1175,14 +1221,16 @@ (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)) - #;(iup:attribute-set! button "BGCOLOR" color) - (iup:attribute-set! button "FGCOLOR" color)) - (if (not (equal? curr-title buttontxt)) - (iup:attribute-set! button "TITLE" (conc "" buttontxt ""))) + (if use-bgcolor + (iup:attribute-set! button "BGCOLOR" color) + (iup:attribute-set! button "IMAGE" (make-image *images* buttontxt color)))) + (if (and (not use-bgcolor) ;; bgcolor does not work with text + (not (equal? curr-title buttontxt))) + (iup:attribute-set! button "TITLE" buttontxt)) (vector-set! buttondat 0 run-id) (vector-set! buttondat 1 color) (vector-set! buttondat 2 buttontxt) (vector-set! buttondat 3 testdat) (vector-set! buttondat 4 run-key))) @@ -1359,11 +1407,15 @@ tp))) (states (dboard:tabdat-states tabdat)) (statuses (dboard:tabdat-statuses tabdat)) (target (let ((targ-list (dboard:tabdat-target tabdat))) (if targ-list (string-intersperse targ-list "/") "no-target-selected"))) - (run-name (dboard:tabdat-run-name tabdat)) + (run-name (let ((run-input (dboard:tabdat-run-name tabdat)) + ) + (if (equal? run-input "") + "no-runname-specified" + run-input))) (states-str (if (or (not states) (null? states)) "" (conc " -state " (string-intersperse states ",")))) (statuses-str (if (or (not statuses) @@ -1526,26 +1578,28 @@ ;; (let ((logs-tb (iup:textbox #:expand "YES" ;; #:multiline "YES"))) ;; (dboard:tabdat-logs-textbox-set! tabdat logs-tb) ;; logs-tb)) -(define (dboard:runs-tree-txtbox-change tabdat val a b) - (if b (dboard:tabdat-target-set! tabdat (string-split b "/"))) - (dashboard:update-run-command tabdat)) - ;; browse runs as a tree. Used in both "Runs" tab and ;; in the runs control panel. ;; (define (dboard:runs-tree-browser commondat tabdat) (let* ((txtbox (iup:textbox #:action (lambda (val a b) (debug:catch-and-dump (lambda () - (dboard:runs-tree-txtbox-change tabdat val a b)) + ;; for the Runs view we put the list + ;; of keyvals into tabdat target for + ;; the Run Controls we put then update + ;; the run-command + (if b (dboard:tabdat-target-set! tabdat + (string-split b "/"))) + (dashboard:update-run-command tabdat)) "command-testname-selector tb action")) #:value (dboard:test-patt->lines - (dboard:tabdat-test-patts-use tabdat)) + (dboard:tabdat-test-patts-use tabdat)) #:expand "HORIZONTAL" ;; #:size "10x30" )) (tb (iup:treebox @@ -1586,18 +1640,10 @@ (debug:print-error 5 *default-log-port* "tree-path->run-id returned non-number " run-id)))) "treebox")) ;; (print "path: " (tree:node->path obj id) " run-id: " run-id) ))) (dboard:tabdat-runs-tree-set! tabdat tb) - (if (args:get-arg "-runname") - (let ((runname (args:get-arg "-runname"))) - (update-search commondat tabdat "runname" runname) - #;(hash-table-set! (dboard:tabdat-searchpatts tabdat) "runname" runname))) - (if (args:get-arg "-target") ;; - (let ((target (args:get-arg "-target"))) - (iup:attribute-set! txtbox value: target) - (dboard:runs-tree-txtbox-change tabdat #f #f target))) (iup:detachbox (iup:vbox txtbox tb )))) @@ -1634,11 +1680,11 @@ ;; NAMEid from IupTree to avoid ;; conflict with the common attribute ;; NAME. Use the TITLEid attribute." #:expand "YES" #:addexpanded "YES" - #:size "10x" + ;; #:size "10x" #:selection-cb (lambda (obj id state) (debug:catch-and-dump (lambda () (let* ((run-path (tree:node->path obj id)) @@ -1720,11 +1766,11 @@ #:expand "HORIZONTAL" #:value 1 #:action (lambda (obj tstate) (debug:catch-and-dump (lambda () - (print "tstate: " tstate) + ;; (print "tstate: " tstate) (if (eq? tstate 0) (dboard:tabdat-compact-layout-set! tabdat #f) (dboard:tabdat-compact-layout-set! tabdat #t)) (dboard:tabdat-last-filter-str-set! tabdat "") ) @@ -1913,42 +1959,27 @@ ;; (set! colnum (+ colnum 1)) )))) run-ids))) (define (dashboard:tests-ht->tests-dat tests-ht) - (let ((oldest-item (make-hash-table))) ;; - ;; populate the oldest-item table - (for-each - (lambda (tdat) - (let ((tname (db:test-get-testname tdat)) - (etime (db:test-get-event_time tdat))) - (if (hash-table-exists? oldest-item tname) - (if (< (hash-table-ref oldest-item tname) etime) - (hash-table-set! oldest-item tname etime)) - (hash-table-set! oldest-item tname etime)))) - (hash-table-values tests-ht)) - (reverse - (sort - (hash-table-values tests-ht) - (lambda (a b) - (let ((a-test-name (db:test-get-testname a)) - (a-item-path (db:test-get-item-path a)) - (b-test-name (db:test-get-testname b)) - (b-item-path (db:test-get-item-path b)) - (a-event-time (db:test-get-event_time a)) - (b-event-time (db:test-get-event_time b))) - (if (equal? a-test-name b-test-name) - (> a-event-time b-event-time) - (> (hash-table-ref oldest-item a-test-name) - (hash-table-ref oldest-item b-test-name))))))))) -;; (if (not (equal? a-test-name b-test-name)) -;; (> a-event-time b-event-time) -;; (cond -;; ((< 0 (string-compare3 a-test-name b-test-name)) #t) -;; ((> 0 (string-compare3 a-test-name b-test-name)) #f) -;; ((< 0 (string-compare3 a-item-path b-item-path)) #t) -;; (else #f))))))))) + (reverse + (sort + (hash-table-values tests-ht) + (lambda (a b) + (let ((a-test-name (db:test-get-testname a)) + (a-item-path (db:test-get-item-path a)) + (b-test-name (db:test-get-testname b)) + (b-item-path (db:test-get-item-path b)) + (a-event-time (db:test-get-event_time a)) + (b-event-time (db:test-get-event_time b))) + (if (not (equal? a-test-name b-test-name)) + (> a-event-time b-event-time) + (cond + ((< 0 (string-compare3 a-test-name b-test-name)) #t) + ((> 0 (string-compare3 a-test-name b-test-name)) #f) + ((< 0 (string-compare3 a-item-path b-item-path)) #t) + (else #f)))))))) (define (dashboard:run-id->tests-mindat run-id tabdat runs-hash) (let* ((run (hash-table-ref/default runs-hash run-id #f)) (key-vals (rmt:get-key-vals run-id)) @@ -1974,11 +2005,11 @@ (dashboard:run-id->tests-mindat dest-run-id tabdat runs-hash) hide-clean: hide-clean) #f))) -(define (dashboard:get-runs-hash tabdat) +(define (dashboard:get-runs-hash tabdat) (let* ((access-mode (dboard:tabdat-access-mode tabdat)) (last-runs-update 0);;(dboard:tabdat-last-runs-update tabdat)) (runs-dat (rmt:get-runs-by-patt (dboard:tabdat-keys tabdat) "%" #f #f #f #f last-runs-update)) (runs-header (vector-ref runs-dat 0)) ;; 0 is header, 1 is list of records (runs (vector-ref runs-dat 1)) @@ -2043,12 +2074,10 @@ (iup:attribute-set! run-matrix "NUMCOL" max-col )) (let ((effective-max-row (if (< max-row max-visible) max-visible max-row))) (if (> effective-max-row (string->number (iup:attribute run-matrix "NUMLIN"))) (iup:attribute-set! run-matrix "NUMLIN" effective-max-row ))) - - (iup:attribute-set! run-matrix "WIDTHDEF" 16) ;; Row labels (for-each (lambda (ind) (let* ((name (car ind)) (num (cadr ind)) @@ -2084,20 +2113,20 @@ (iup:attribute-set! run-matrix key (cadr value)) (iup:attribute-set! run-matrix (conc "BGCOLOR" key) (car value)))))) matrix-content) ;; 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) ;; (list->string (intersperse (string->list name) #\newline))) ;; name) - #;(if (<= num max-col) + (iup:attribute-set! run-matrix key name) + (if (<= num max-col) (iup:attribute-set! run-matrix "FITTOTEXT" (conc "C" num))))))) col-indices) (if (and (eq? pass-num 0) changed) (loop 1 #t)) ;; force second pass due to column labels changing @@ -2174,11 +2203,11 @@ (debug:print 0 *default-log-port* " message: " ((condition-property-accessor 'exn 'message) exn) ", exn=" exn) (debug:print 0 *default-log-port* "ERROR: failed call procedure " viewgen ", with; tab-num=" tab-num ", view-name=" view-name ", and views-cfgdat and megatest configdat as parameters. To debug try loading in the repl: megatest -repl") (set! success #f)) - (print "Adding tab " view-name " with proc " viewgen) + (debug:print 0 *default-log-port* "Adding tab " view-name " with proc " viewgen) ;; (iup:child-add! tabs (set! result-child ((eval (string->symbol viewgen)) commondat tabs tab-num view-name views-cfgdat *configdat*)))) ;; and finally set the updater (if success @@ -2296,11 +2325,11 @@ (define (dashboard:runs-summary commondat tabdat #!key (tab-num #f)) (let* ((update-mutex (dboard:commondat-update-mutex commondat)) (tb (iup:treebox #:value 0 ;;#:name "Runs" - #:title "Runs" ;; was #:name -- iup 3.19 changed this... "Changed: [DEPRECATED REMOVED] removed the old attribute NAMEid from IupTree to avoid conflict with the common attribute NAME. Use the TITLEid attribute." + #:title "Runs" #:expand "YES" #:addexpanded "YES" #:selection-cb (lambda (obj id state) (debug:catch-and-dump @@ -2384,20 +2413,21 @@ ) )) "runs-summary-click-callback")))) (runs-summary-updater (lambda () - (mutex-lock! update-mutex) + ;; (mutex-lock! update-mutex) (if (or (dashboard:database-changed? commondat tabdat context-key: 'runs-summary-updater) (dboard:tabdat-view-changed tabdat)) (debug:catch-and-dump (lambda () ;; check that run-matrix is initialized before calling the updater (if run-matrix (dashboard:runs-summary-updater commondat tabdat tb cell-lookup run-matrix))) "dashboard:runs-summary-updater") ) - (mutex-unlock! update-mutex))) + #;(mutex-unlock! update-mutex) + )) (runs-summary-control-panel (dashboard:runs-summary-control-panel tabdat)) ) (dboard:commondat-add-updater commondat runs-summary-updater tab-num: tab-num) (dboard:tabdat-runs-tree-set! tabdat tb) (iup:vbox @@ -2440,11 +2470,11 @@ (iup:vbox (iup:textbox #:size "120x15" #:fontsize "10" #:value "%" #:expand "NO" #:action (lambda (obj unk val) (debug:catch-and-dump - (lambda () + (lambda ()57 (mark-for-update tabdat) (update-search commondat tabdat "test-name" val)) "make-controls"))) (iup:hbox (iup:button "Quit" #:action (lambda (obj) @@ -2459,10 +2489,11 @@ (dboard:tabdat-allruns-by-id-set! tabdat (make-hash-table)) (dboard:tabdat-done-runs-set! tabdat '()) (dboard:tabdat-not-done-runs-set! tabdat '()) (dboard:tabdat-view-changed-set! tabdat #t) (dboard:commondat-please-update-set! commondat #t) + (dboard:clear-run-id-update-hash) (mark-for-update tabdat)) #:expand "NO" #:size "40x15") (iup:button "Collapse" #:action (lambda (obj) (debug:catch-and-dump (lambda () @@ -2513,22 +2544,22 @@ (set! hide (iup:button "Hide" #:expand "NO" #:size "40x15" ;; #:expand "HORIZONTAL" #:action (lambda (obj) (dboard:tabdat-hide-not-hide-set! tabdat #t) ;; (not (dboard:tabdat-hide-not-hide tabdat))) ;; (iup:attribute-set! obj "TITLE" (if (dboard:tabdat-hide-not-hide tabdat) "HideTests" "NotHide")) - (iup:attribute-set! hide "FGCOLOR" sel-color) - (iup:attribute-set! show "FGCOLOR" nonsel-color) + (iup:attribute-set! hide "BGCOLOR" sel-color) + (iup:attribute-set! show "BGCOLOR" nonsel-color) (mark-for-update tabdat)))) (set! show (iup:button "Show" #:expand "NO" #:size "40x15" ;; #:expand "HORIZONTAL" #:action (lambda (obj) (dboard:tabdat-hide-not-hide-set! tabdat #f) ;; (not (dboard:tabdat-hide-not-hide tabdat))) - (iup:attribute-set! show "FGCOLOR" sel-color) - (iup:attribute-set! hide "FGCOLOR" nonsel-color) + (iup:attribute-set! show "BGCOLOR" sel-color) + (iup:attribute-set! hide "BGCOLOR" nonsel-color) (mark-for-update tabdat)))) - (iup:attribute-set! hide "FGCOLOR" sel-color) - (iup:attribute-set! show "FGCOLOR" nonsel-color) + (iup:attribute-set! hide "BGCOLOR" sel-color) + (iup:attribute-set! show "BGCOLOR" nonsel-color) ;; (dboard:tabdat-hide-not-hide-button-set! tabdat hideit) ;; never used, can eliminate ... (iup:vbox (iup:hbox hide show) sort-lb))) ) @@ -2763,11 +2794,12 @@ (dboard:runs-tree-new-browser commondat rdat) (dboard:runs-new-matrix commondat rdat) ))) (define (make-dashboard-buttons commondat) ;; runs-sum-dat new-view-dat) - (let* ((stats-dat (dboard:tabdat-make-data)) + (let* ( + (stats-dat (dboard:tabdat-make-data)) (runs-dat (dboard:tabdat-make-data)) (runs2-dat (make-dboard:rdat)) ;; (dboard:tabdat-make-data)) (onerun-dat (dboard:tabdat-make-data)) ;; name for run-summary structure (runcontrols-dat (dboard:tabdat-make-data)) (runtimes-dat (dboard:tabdat-make-data)) @@ -2785,18 +2817,16 @@ (bdylst '()) (result '()) (i 0) (btn-height (dboard:tabdat-runs-btn-height runs-dat)) (btn-fontsz (dboard:tabdat-runs-btn-fontsz runs-dat)) - (cell-width (dboard:tabdat-runs-cell-width runs-dat))) + (cell-width (dboard:tabdat-runs-cell-width runs-dat)) + (use-bgcolor (equal? (configf:lookup *configdat* "dashboard" "use-bgcolor") "yes"))) ;; controls (along bottom) ;; (set! controls (dboard:make-controls commondat runs-dat)) - - (if (args:get-arg "-runname") - (let ((runname (args:get-arg "-runname"))) - (update-search commondat runs-dat "runname" runname) - #;(hash-table-set! (dboard:tabdat-searchpatts tabdat) "runname" runname))) + + ;; create the left most column for the run key names and the test names (set! lftlst (list (iup:hbox (iup:label) ;; (iup:valuator) @@ -2809,12 +2839,11 @@ #:fontsize btn-fontsz #:expand "NO") ;; "HORIZONTAL") (iup:textbox #:size (conc 35 btn-height) #:fontsize btn-fontsz - #:value (if (and (args:get-arg "-runname")(equal? x "runname")) - (args:get-arg "-runname") "%") + #:value "%" #:expand "NO" ;; "HORIZONTAL" #:action (lambda (obj unk val) ;; each field ;; (field name is "x" var) live updates ;; the search filter as it is typed @@ -2900,14 +2929,13 @@ (set! bdylst (cons (apply iup:vbox (reverse res)) bdylst)) (loop (+ runnum 1) 0 (make-vector ntests) '())) (else (let* ((button-key (mkstr runnum testnum)) (butn (iup:button - "" ;; button-key + (if use-bgcolor #f " ") ;; button-key #:size (conc cell-width btn-height ) #:expand "HORIZONTAL" - #:MARKUP "YES" #:fontsize btn-fontsz #:button-cb (lambda (obj a pressed x y btn . rem) ;; (print "pressed= " pressed " x= " x " y= " y " rem=" rem " btn=" btn " string? " (string? btn)) (if (substring-index "3" btn) @@ -2943,10 +2971,11 @@ (let* ((toolpath (car (argv))) (buttndat (hash-table-ref (dboard:tabdat-buttondat runs-dat) button-key)) (test-id (db:test-get-id (vector-ref buttndat 3))) (run-id (db:test-get-run_id (vector-ref buttndat 3)))) (dboard:launch-testpanel run-id test-id)))))))) + (iup:attribute-set! butn "IMAGE" (make-image *images* "BGCOLOR" "222 222 221")) ;;; "BGCOLOR" "BGCOLOR") (hash-table-set! (dboard:tabdat-buttondat runs-dat) button-key (vector 0 "100 100 100" button-key #f #f)) (vector-set! testvec testnum butn) (loop runnum (+ testnum 1) testvec (cons butn res)))))) ;; now assemble the hdrlst and bdylst and kick off the dialog (iup:show @@ -2954,14 +2983,14 @@ #:title (conc "Megatest dashboard " (current-user-name) ":" *toppath*) #:menu (dcommon:main-menu) (let* ((runs-view (iup:vbox (iup:split #:orientation "VERTICAL" ;; "HORIZONTAL" - #:value 100 + #:value 250 (dboard:runs-tree-browser commondat runs-dat) (iup:split - #:value 100 + #:value 200 ;; left most block, including row names (apply iup:vbox lftlst) ;; right hand block, including cells (iup:vbox #:expand "YES" @@ -3012,20 +3041,22 @@ (let* ((tab-num (dboard:commondat-curr-tab-num commondat)) (tabdat (dboard:common-get-tabdat commondat tab-num: tab-num))) (dboard:commondat-please-update-set! commondat #t) (dboard:tabdat-layout-update-ok-set! tabdat #t))) "tabchangepos")) - (dashboard:summary commondat stats-dat tab-num: 0) runs-view + (dashboard:summary commondat stats-dat tab-num: 1) ;; (make-runs-view commondat runs2-dat 2) (dashboard:runs-summary commondat onerun-dat tab-num: 2) (dashboard:run-controls commondat runcontrols-dat tab-num: 3) (dashboard:run-times commondat runtimes-dat tab-num: 4) - additional-views))) + additional-views)) + (target-run (dboard:commondat-target commondat)) + ) ;; (set! (iup:callback tabs tabchange-cb:) (lambda (a b c)(print "SWITCHED TO TAB: " a " " b " " c))) - (iup:attribute-set! tabs "TABTITLE0" "Summary") - (iup:attribute-set! tabs "TABTITLE1" "Runs") + (iup:attribute-set! tabs "TABTITLE0" "Runs") + (iup:attribute-set! tabs "TABTITLE1" "Summary") ;; (iup:attribute-set! tabs "TABTITLE2" "Runs2") (iup:attribute-set! tabs "TABTITLE2" "Run Summary") (iup:attribute-set! tabs "TABTITLE3" "Run Control") (iup:attribute-set! tabs "TABTITLE4" "Run Times") ;; (iup:attribute-set! tabs "TABTITLE3" "New View") @@ -3039,12 +3070,18 @@ (iup:attribute-set! tabs "BGCOLOR" "190 190 190") ;; make the iup tabs object available (for changing color for example) (dboard:commondat-hide-not-hide-tabs-set! commondat tabs) ;; now set up the tabdat lookup - (dboard:common-set-tabdat! commondat 0 stats-dat) - (dboard:common-set-tabdat! commondat 1 runs-dat) + ;; (dboard:common-set-tabdat! commondat 0 stats-dat) + + (if target-run + (begin + (dboard:tabdat-target-set! runs-dat (string-split target-run "/")) + ) + ) + (dboard:common-set-tabdat! commondat 0 runs-dat) ;;(dboard:common-set-tabdat! commondat 2 runs2-dat) (dboard:common-set-tabdat! commondat 2 onerun-dat) (dboard:common-set-tabdat! commondat 3 runcontrols-dat) (dboard:common-set-tabdat! commondat 4 runtimes-dat) @@ -3086,11 +3123,11 @@ (debug:print 2 *default-log-port* "WARNING: error in accessing databases in get-youngest-run-db-mod-time: " ((condition-property-accessor 'exn 'message) exn) " db-dir="dbdir ", exn=" exn) (current-seconds)) ;; something went wrong - just print an error and return current-seconds (common:max (map (lambda (filen) (file-modification-time filen)) - (glob (conc dbdir "/*.db*")))))) + (cons (conc dbdir "/main.db") (glob (conc dbdir "/?.db"))))))) (define (dashboard:monitor-changed? commondat tabdat) (let* ((run-update-time (current-seconds)) (monitor-db-path (dboard:tabdat-monitor-db-path tabdat)) (monitor-modtime (if (and monitor-db-path (common:file-exists? monitor-db-path)) @@ -3108,21 +3145,18 @@ (hash-table-ref/default (dboard:tabdat-last-db-update tabdat) context 0)) (define (dboard:set-last-db-update! tabdat context newtime) (hash-table-set! (dboard:tabdat-last-db-update tabdat) context newtime)) -;; DOES NOT WORK RELIABLY WITH /tmp WAL mode files. Timestamps only change when the db -;; is closed (I think). If db dir starts with /tmp always return true ;; (define (dashboard:database-changed? commondat tabdat #!key (context-key 'default)) (let* ((run-update-time (current-seconds)) - (dbdir (dboard:tabdat-dbdir tabdat)) + (dbdir (conc *toppath* "/.mtdb")) (modtime (dashboard:get-youngest-run-db-mod-time dbdir)) (recalc (dashboard:recalc modtime (dboard:commondat-please-update commondat) (dboard:get-last-db-update tabdat context-key)))) - ;; (dboard:tabdat-last-db-update tabdat)))) (if recalc (dboard:set-last-db-update! tabdat context-key run-update-time)) (dboard:commondat-please-update-set! commondat #f) recalc)) @@ -3283,11 +3317,10 @@ (filtrstr (conc targpatt "/" runpatt "/" testpatt))) ;; (print "targpatt: " targpatt " runpatt: " runpatt " testpatt: " testpatt) (if (not (equal? (dboard:tabdat-last-filter-str tabdat) filtrstr)) (let ((dwg (dboard:tabdat-drawing tabdat))) - (print "reseting drawing") (dboard:tabdat-layout-update-ok-set! tabdat #f) (vg:drawing-libs-set! dwg (make-hash-table)) (vg:drawing-insts-set! dwg (make-hash-table)) (vg:drawing-cache-set! dwg '()) (dboard:tabdat-allruns-by-id-set! tabdat (make-hash-table)) @@ -3322,14 +3355,14 @@ (vch (dboard:tabdat-view-changed tabdat))) (if (and cnv dwg vch) (begin (vg:drawing-xoff-set! dwg (dboard:tabdat-xadj tabdat)) (vg:drawing-yoff-set! dwg (dboard:tabdat-yadj tabdat)) - (mutex-lock! mtx) + ;; (mutex-lock! mtx) (canvas-clear! cnv) (vg:draw dwg tabdat) - (mutex-unlock! mtx) + ;; (mutex-unlock! mtx) (dboard:tabdat-view-changed-set! tabdat #f))))) ;; doesn't work. ;; ;;(define (gotoescape tabdat escape) @@ -3345,11 +3378,11 @@ (begin (debug:print 0 *default-log-port* "ERROR: I only know sqlite3 databases for now: " dbstr) #f))))) (if (and dbpth (file-read-access? dbpth)) (let ((db (sqlite3:open-database dbpth))) ;; (open-database dbpth))) - (sqlite3:set-busy-handler! db (make-busy-timeout 10000)) + (sqlite3:set-busy-handler! db (sqlite3:make-busy-timeout 10000)) db) #f))) ;; sqlite3:path tablename timefieldname varfieldname field1 field2 ... ;; @@ -3513,11 +3546,11 @@ (vg:add-obj-to-comp cmp ;;(vg:make-rect-obj last-tval lly curr-tval last-yval ;; (- stval 2) lly (+ stval 2)(+ lly (* yval yscale)) (vg:make-line-obj curr-tval last-yval curr-tval next-yval line-color: graph-color))) - (print "ERROR: curr-tval is not > last-tval; curr-tval " curr-tval ", last-tval " last-tval)))) + (debug:print 0 *default-log-port* "ERROR: curr-tval is not > last-tval; curr-tval " curr-tval ", last-tval " last-tval)))) next) #f ;; (vector tstart minval minval) dat) )))))) ;; for each data point in the series (hash-table-keys alldat))))) @@ -3609,17 +3642,17 @@ (graph-uly (- (calc-y 0) canvas-margin)) (sec-per-50pt (/ 50 timescale)) ) ;; (print "timeoffset: " timeoffset " timescale: " timescale " run-duration: " (seconds->hr-min-sec run-duration) " width: " width " sec-per-50pt: " sec-per-50pt) ;; (print "timescale: " timescale " timeoffset: " timeoffset " sizex: " sizex " originx: " originx) - (mutex-lock! mtx) + ;; (mutex-lock! mtx) (vg:add-comp-to-lib runslib run-full-name runcomp) ;; Have to keep moving the instantiated box as it is anchored at the lower left ;; this should have worked for x in next statement? (maptime run-start) ;; add 60 to make room for the graph (vg:instantiate drawing "runslib" run-full-name run-full-name 8 (- (calc-y curr-run-start-row) (+ 5 graph-height run-to-run-margin))) - (mutex-unlock! mtx) + ;; (mutex-unlock! mtx) ;; (set! run-start-row (+ max-row 2)) ;; (dboard:tabdat-start-row-set! tabdat (+ new-run-start-row 1)) ;; get tests in list sorted by event time ascending (let testsloop ((test-ids (car hierdat)) ;; loop on tests (NOTE: not items!) (tests-tal (cdr hierdat)) @@ -3674,11 +3707,11 @@ (cons obj test-objs)))))) ;; (print "event_time: " (db:test-get-event_time testdat) " mapped event_time: " event-time) ;; (print "run-duration: " (db:test-get-run_duration testdat) " mapped run_duration: " run-duration) (if (> item-num 50) (if (eq? 0 (modulo item-num 50)) - (print "processing " run-num " of " num-runs " runs " item-num " of " num-items " of test " test-name ", " test-num " of " num-tests " tests"))) + (debug:print 0 *default-log-port* "processing " run-num " of " num-runs " runs " item-num " of " num-items " of test " test-name ", " test-num " of " num-tests " tests"))) ;; (print "test-name: " test-name " event-time: " event-time " run-duration: " run-duration) (let ((newdoneruns (cons rundat doneruns))) (if (null? tidstal) (if iterated (let* ((xtents (vg:get-extents-for-objs drawing new-test-objs)) @@ -3699,11 +3732,11 @@ (escapeloop #t) ;; (dboard:tabdat-layout-update-ok tabdat) ))))) ;; If it is an iterated test put box around it now. (if (not (null? tests-tal)) (if #f ;; (> (- (current-seconds) update-start-time) 5) - (print "drawing runs taking too long") + (debug:print 0 *default-log-port* "drawing runs taking too long") (if (dboard:tabdat-layout-update-ok tabdat) (testsloop (car tests-tal)(cdr tests-tal)(+ test-num 1)) (escapeloop #t) ;; (dboard:tabdat-layout-update-ok tabdat) ))))) ;; placeholder box @@ -3720,13 +3753,13 @@ (outln (vg:make-rect-obj -5 lly ulx uly text: run-full-name line-color: (vg:rgb->number 255 0 255 a: 128)))) ; (vg:components-get-extents d1 c1))) ;; this is the box around the run - (mutex-lock! mtx) + ;; (mutex-lock! mtx) (vg:add-obj-to-comp runcomp outln) - (mutex-unlock! mtx) + ;; (mutex-unlock! mtx) ;; this is where we have enough info to place the graph (dboard:graph commondat tabdat tab-num -5 (+ uly 10) ulx (+ uly graph-height 3) run-start run-end timescale maptime run-full-name canvas-margin) (dboard:tabdat-max-row-set! tabdat (+ (dboard:tabdat-max-row tabdat)(quotient (+ graph-height 40 3) row-height))) ;; (vg:instance-move drawing run-full-name 0 (dboard:tabdat-max-row tabdat)) )) @@ -3739,11 +3772,11 @@ (dboard:rundat-data-changed-set! rundat #f) (dboard:tabdat-not-done-runs-set! tabdat '()) (dboard:tabdat-done-runs-set! tabdat allruns)) (if #f ;; (> (- (current-seconds) update-start-time) 5) (begin - (print "drawing runs taking too long.... have " (length runtal) " remaining") + (debug:print 0 *default-log-port* "drawing runs taking too long.... have " (length runtal) " remaining") ;; (dboard:tabdat-done-runs-set! tabdat newdoneruns) ;; taking too long? stop here! ;; (time (vg:draw (dboard:tabdat-drawing tabdat) #t)) (dboard:tabdat-not-done-runs-set! tabdat runtal)) (begin (if (dboard:tabdat-layout-update-ok tabdat) @@ -3796,17 +3829,46 @@ ;;====================================================================== ;; The heavy lifting starts here ;;====================================================================== +(stop-the-train) + (define (main) - (let ((mtdb-path (conc *toppath* "/megatest.db"))) ;; + ;; (print "Starting dashboard main") + + (let* ((mtdb-path (conc *toppath* "/.mtdb/main.db")) + (target (args:get-arg "-target")) + (commondat (dboard:commondat-make))) + (if target + (begin + (hash-table-delete! args:arg-hash "-target") ;; workaround for the following commented out function + ;; (args:remove-arg-from-ht "-target") This function is in mtargs/mtargs.scm, but it's in an egg that is not in the current build of chicken 4.10 + (dboard:commondat-target-set! commondat target) + ) + ) + + (if (not (launch:setup)) + (begin + (debug:print 0 *default-log-port* "Failed to find megatest.config, exiting") + (exit 1) + ) + ) + + #;(if (not (common:on-homehost?)) + (begin + (debug:print 0 *default-log-port* "WARNING: You are starting the dashboard on a machine that is not the homehost:" (server:get-homehost)) + (debug:print 0 *default-log-port* "It will be slower.") + )) + + (if (and (common:file-exists? mtdb-path) (file-write-access? mtdb-path)) (if (not (args:get-arg "-skip-version-check")) (common:exit-on-version-changed))) - (let* ((commondat (dboard:commondat-make))) + + (let* () ;; Move this stuff to db.scm? I'm not sure that is the right thing to do... (cond ((args:get-arg "-test") ;; run-id,test-id (let* ((dat (let ((d (map string->number (string-split (args:get-arg "-test") ",")))) (if (> (length d) 1) @@ -3819,56 +3881,136 @@ (>= test-id 0)) (dashboard-tests:examine-test run-id test-id) (begin (debug:print 3 *default-log-port* "INFO: tried to open test with invalid run-id,test-id. " (args:get-arg "-test")) (exit 1))))) - ;; ((args:get-arg "-guimonitor") - ;; (gui-monitor (dboard:tabdat-dblocal tabdat))) (else (dboard:commondat-uidat-set! commondat (make-dashboard-buttons commondat)) (dboard:commondat-curr-tab-num-set! commondat 0) (dboard:commondat-add-updater commondat (lambda () - (dashboard:runs-tab-updater commondat 1)) - tab-num: 1) + (dashboard:runs-tab-updater commondat 0)) + tab-num: 0) ;; may not want this alive (manually merged it from v1.66) - (dboard:commondat-add-updater - commondat - (lambda () - (dashboard:runs-tab-updater commondat 1)) - tab-num: 2) + ;; (dboard:commondat-add-updater + ;; commondat + ;; (lambda () + ;; (dashboard:runs-tab-updater commondat 1)) + ;; tab-num: 2) (iup:callback-set! *tim* "ACTION_CB" (lambda (time-obj) (let ((update-is-running #f)) - (mutex-lock! (dboard:commondat-update-mutex commondat)) - (set! update-is-running (dboard:commondat-updating commondat)) - (if (not update-is-running) - (dboard:commondat-updating-set! commondat #t)) - (mutex-unlock! (dboard:commondat-update-mutex commondat)) - (if (not update-is-running) ;; we know that the update was not running and we now have a lock on doing an update + ;; (mutex-lock! (dboard:commondat-update-mutex commondat)) + (set! update-is-running (dboard:commondat-updating commondat)) + (if (not update-is-running) + (dboard:commondat-updating-set! commondat #t)) + ;; (mutex-unlock! (dboard:commondat-update-mutex commondat)) + (if (not update-is-running) ;; we know that the update was not running and we now have a lock on doing an update (begin (dboard:common-run-curr-updaters commondat) ;; (dashboard:run-update commondat) - (mutex-lock! (dboard:commondat-update-mutex commondat)) + ;; (mutex-lock! (dboard:commondat-update-mutex commondat)) (dboard:commondat-updating-set! commondat #f) - (mutex-unlock! (dboard:commondat-update-mutex commondat))) - )) + ;; (mutex-unlock! (dboard:commondat-update-mutex commondat)) + ))) 1)))) - + ;; (debug:print 0 *default-log-port* "Starting updaters") (let ((th1 (make-thread (lambda () (thread-sleep! 1) (dboard:common-run-curr-updaters commondat 0) ;; force update of summary tab ) "update buttons once")) (th2 (make-thread iup:main-loop "Main loop"))) + ;; (print "Starting main loop") (thread-start! th2) - (thread-join! th2))))) + (thread-join! th2) + ) + ) + ) +) + +(define last-copy-time 0) + + +;; Sync to tmp only if in read-only mode. + +(define (sync-db-to-tmp tabdat) + (let* ((db-file "./.mtdb/main.db")) + (if (and (not (file-write-access? db-file)) ( > (current-seconds) (+ last-copy-time 5))) + (begin + (db:multi-db-sync (db:setup) 'old2new) + (set! last-copy-time (current-seconds)) + ) + ) + ) +) + +;; ########################### top level code ######################## +;; check for MT_* environment variables and exit if found +(if (not (args:get-arg "-test")) + (begin + (for-each (lambda (var) + ;; (display " ")(display var) + (if (get-environment-variable var) + (begin + (debug:print 0 *default-log-port* "ERROR: environment variable " var " is set in this terminal, this will cause you problems. Exiting now.") + (exit 1)))) + '("MT_RUN_AREA_HOME" "MT_MEGATEST" "MT_CMDINFO" "MT_TEST_RUN_DIR" "MT_LINKTREE" "MT_TESTSUITENAME")) + ) +) + +;; This is NOT good +;; (setenv "MT_RUN_AREA_HOME" (get-environment-variable "PWD")) +;; This should be OK but it really should not be necessary +(setenv "MT_RUN_AREA_HOME" (current-directory)) + +(if (not (null? remargs)) + (if remargs + (begin + (debug:print 0 *default-log-port* "Unrecognised arguments: " (string-intersperse remargs " ")) + (exit) + ) + (begin + (print help) + (exit) + ) + ) +) + +(if (args:get-arg "-h") + (begin + (print help) + (exit))) + + + + +(if (args:get-arg "-start-dir") + (if (directory-exists? (args:get-arg "-start-dir")) + (let ((fullpath (common:real-path (args:get-arg "-start-dir")))) + (setenv "PWD" fullpath) + (change-directory fullpath)) + (begin + (debug:print-error 0 *default-log-port* "non-existant start dir " (args:get-arg "-start-dir") " specified, exiting.") + (exit 1)))) + + +;; deal with RH 5.11 gtk lib or iup lib missing detachbox feature +;; first check for the switch +;; +(if (or + (configf:lookup *configdat* "dashboard" "no-detachbox") + (not (file-exists? "/etc/os-release"))) + (set! iup:detachbox iup:vbox)) + + ;; ease debugging by loading ~/.dashboardrc (let ((debugcontrolf (conc (get-environment-variable "HOME") "/.dashboardrc"))) (if (common:file-exists? debugcontrolf) (load debugcontrolf))) + (if (args:get-arg "-repl") (repl) (main)) Index: datashare.scm ================================================================== --- datashare.scm +++ datashare.scm @@ -14,812 +14,811 @@ ;; GNU General Public License for more details. ;; ;; You should have received a copy of the GNU General Public License ;; along with Megatest. If not, see . -(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 (common:file-exists? dbpath)) - (handler (make-busy-timeout 136000))) - (handle-exceptions - exn - (begin - (debug:print 2 *default-log-port* "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 (current-error-port)) - (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 (common: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 - ((common: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 (common: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 (common: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 (common: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) +;; ==> (module datashare +;; ==> (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) +;; ==> +;; ==> (use (prefix iup iup:)) +;; ==> (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 (common:file-exists? dbpath)) +;; ==> (handler (make-busy-timeout 136000))) +;; ==> (handle-exceptions +;; ==> exn +;; ==> (begin +;; ==> (debug:print 2 *default-log-port* "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 (current-error-port)) +;; ==> (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 (common: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 +;; ==> ((common: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 (common: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 (common: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 (common: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 @@ -22,63 +22,74 @@ ;; Database access ;;====================================================================== ;; dbstruct vector containing all the relevant dbs like main.db, megatest.db, run.db etc -(use (srfi 18) extras tcp stack) -(use sqlite3 srfi-1 posix regex regex-case srfi-69 csv-xml s11n md5 message-digest base64 format dot-locking z3 typed-records matchable) -(import (prefix sqlite3 sqlite3:)) -(import (prefix base64 base64:)) - (declare (unit db)) (declare (uses common)) +(declare (uses debugprint)) +(declare (uses dbmod)) +(declare (uses dbfile)) (declare (uses keys)) (declare (uses ods)) -(declare (uses client)) (declare (uses mt)) +(declare (uses commonmod)) +(declare (uses mtargs)) +(declare (uses rmtmod)) + +(import commonmod + (prefix mtargs args:)) + +(use (srfi 18) + extras + ;; tcp + stack + (prefix sqlite3 sqlite3:) + srfi-1 + posix + regex + regex-case + srfi-69 + csv-xml + s11n + md5 + message-digest + (prefix base64 base64:) + format + dot-locking + z3 + typed-records + matchable + files) (include "common_records.scm") (include "db_records.scm") (include "key_records.scm") (include "run_records.scm") (define *number-of-writes* 0) (define *number-non-write-queries* 0) -;;====================================================================== -;; R E C O R D S -;;====================================================================== - -;; each db entry is a pair ( db . dbfilepath ) -;; I propose this record evolves into the area record -;; -(defstruct dbr:dbstruct - (tmpdb #f) - (dbstack #f) ;; stack for tmp db handles, do not initialize with a stack - (mtdb #f) - (refndb #f) - (homehost #f) ;; not used yet - (on-homehost #f) ;; not used yet - (read-only #f) - (stmt-cache (make-hash-table)) - ) ;; goal is to converge on one struct for an area but for now it is too confusing - +(import debugprint) +(import dbfile) +(import dbmod) +(import rmtmod) ;; record for keeping state,status and count for doing roll-ups in ;; iterated tests ;; (defstruct dbr:counts (state #f) (status #f) (count 0)) -;;====================================================================== -;; alist-of-alists -;;====================================================================== -;; -;; (define (db:aa-set! dat key1 key2 val) -;; (let loop (( +;; (define (db:with-db dbstruct run-id r/w proc . params) +;; (case (rmt:transport-mode) +;; ((http)(dbfile:with-db dbstruct run-id r/w proc params)) +;; ((tcp) (dbmod:with-db dbstruct run-id r/w proc params)) +;; ((nfs) (dbmod:with-db dbstruct run-id r/w proc params)) +;; (else (assert #f "FATAL: db:with-db called with non-existant transport mode")))) ;;====================================================================== ;; hash of hashs ;;====================================================================== @@ -94,26 +105,18 @@ (define (db:hoh-get dat key1 key2) (let* ((subhash (hash-table-ref/default dat key1 #f))) (and subhash (hash-table-ref/default subhash key2 #f)))) -(define (db:get-cache-stmth dbstruct db stmt) - (let* ((stmt-cache (dbr:dbstruct-stmt-cache dbstruct)) - (stmth (db:hoh-get stmt-cache db stmt))) - (or stmth - (let* ((newstmth (sqlite3:prepare db stmt))) - (db:hoh-set! stmt-cache db stmt newstmth) - newstmth)))) - ;;====================================================================== ;; SQLITE3 HELPERS ;;====================================================================== (define (db:general-sqlite-error-dump exn stmt . params) (let ((err-status ((condition-property-accessor 'sqlite3 'status #f) exn))) ;; RADT ... how does this work? ;; check for (exn sqlite3) ((condition-property-accessor 'exn 'message) exn) - (print "err-status: " err-status) + ;; (print "err-status: " err-status) (debug:print-error 0 *default-log-port* " query " stmt " failed, params: " params ", error: " ((condition-property-accessor 'exn 'message) exn)) (print-call-chain (current-error-port)))) ;; convert to -inline ;; @@ -127,37 +130,136 @@ (begin (debug:print-error 0 *default-log-port* " query " stmt " failed, params: " params ", error: " ((condition-property-accessor 'exn 'message) exn) ", exn=" exn) (print-call-chain (current-error-port)) default))) (apply sqlite3:first-result db stmt params))) + +(define (db:setup) + (assert *toppath* "FATAL: db:setup called before launch:setup has been run.") + (let* ((tmpdir (common:make-tmpdir-name *toppath* ""))) + (if (not *dbstruct-dbs*) + (dbfile:setup (conc *toppath* "/.mtdb") tmpdir) + *dbstruct-dbs*))) + +;; moved from dbfile +;; +;; ADD run-id SUPPORT +;; +(define (db:create-all-triggers dbstruct) + (db:with-db + dbstruct #f #t + (lambda (dbdat db) + (db:create-triggers db)))) + +(define (db:create-triggers db) + (for-each (lambda (key) + (sqlite3:execute db (cadr key))) + db:trigger-list)) + +(define (db:drop-all-triggers dbstruct) + (db:with-db + dbstruct #f #t + (lambda (dbdat db) + (db:drop-triggers db)))) + +(define (db:have-incompletes? dbstruct run-id ovr-deadtime) + (let* ((incompleted '()) + (oldlaunched '()) + (toplevels '()) + ;; (deadtime-str (configf:lookup *configdat* "setup" "deadtime")) + (deadtime (or ovr-deadtime 72000))) ;; twenty hours + (db:with-db + dbstruct run-id #f + (lambda (dbdat db) + + ;; in RUNNING or REMOTEHOSTSTART for more than 10 minutes + ;; + ;; HOWEVER: this code in run:test seems to work fine + ;; (> (- (current-seconds)(+ (db:test-get-event_time testdat) + ;; (db:test-get-run_duration testdat))) + ;; 600) + ;; (db:delay-if-busy dbdat) + (sqlite3:for-each-row + (lambda (test-id run-dir uname testname item-path) + (if (and (equal? uname "n/a") + (equal? item-path "")) ;; this is a toplevel test + ;; what to do with toplevel? call rollup? + (begin + (set! toplevels (cons (list test-id run-dir uname testname item-path run-id) toplevels))) + ;; (print-info "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:get-cache-stmth dbdat db + "SELECT id,rundir,uname,testname,item_path FROM tests WHERE run_id=? AND (strftime('%s','now') - event_time) > (run_duration + ?) AND state IN ('RUNNING','REMOTEHOSTSTART');") + run-id deadtime) + + ;; in LAUNCHED for more than one day. Could be long due to job queues TODO/BUG: Need override for this in config + ;; + ;; (db:delay-if-busy dbdat) + (sqlite3:for-each-row + (lambda (test-id run-dir uname testname item-path) + (if (and (equal? uname "n/a") + (equal? item-path "")) ;; this is a toplevel test + ;; what to do with toplevel? call rollup? + (set! toplevels (cons (list test-id run-dir uname testname item-path run-id) toplevels)) + (set! oldlaunched (cons (list test-id run-dir uname testname item-path run-id) oldlaunched)))) + (db:get-cache-stmth dbdat 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) + + ;; (print-info "Found " (length oldlaunched) " old LAUNCHED items, " (length toplevels) " old LAUNCHED toplevel tests and " (length incompleted) " tests marked RUNNING but apparently dead.") + (if (and (null? incompleted) + (null? oldlaunched) + (null? toplevels)) + #f + #t))))) + + +;; looks up subdb and returns it, if not found then set up +;; and then return it. +;; +#;(define (db:get-db dbstruct run-id) + (let* ((res (dbfile:get-subdb dbstruct run-id))) + (if res + res + (let* ((newsubdb (make-dbr:subdb))) + (dbfile:set-subdb dbstruct run-id newsubdb) + (db:open-db dbstruct run-id areapath: (dbr:dbstruct-areapath dbstruct) do-sync: #t) + newsubdb)))) ;; Get/open a database ;; if run-id => get run specific db ;; if #f => get main db -;; if db already open - return inmem -;; if db not open, open inmem, rundb and sync then return inmem +;; if run-id is a string treat it as a filename +;; if db already open - return cachedb +;; if db not open, open cachedb, rundb and sync then return cachedb ;; inuse gets set automatically for rundb's ;; -(define (db:get-db dbstruct) ;; run-id) - (if (stack? (dbr:dbstruct-dbstack dbstruct)) - (if (stack-empty? (dbr:dbstruct-dbstack dbstruct)) - (let ((newdb (db:open-megatest-db path: (db:dbfile-path)))) - ;; (stack-push! (dbr:dbstruct-dbstack dbstruct) newdb) - newdb) - (stack-pop! (dbr:dbstruct-dbstack dbstruct))) - (db:open-db dbstruct))) - -;; ;; legacy handling of structure for managing db's. Refactor this into dbr:? -(define (db:dbdat-get-db dbdat) - (if (pair? dbdat) - (car dbdat) - dbdat)) - -(define (db:dbdat-get-path dbdat) - (if (pair? dbdat) - (cdr dbdat) - #f)) +;; (define db:get-db db:get-subdb) + +;; (define (db:get-db subdb #;dbstruct run-id) ;; RENAME TO db:get-dbh +;; ;; (let* ((subdb (dbfile:get-subdb dbstruct run-id))) +;; (if (stack? (dbr:subdb-dbstack subdb)) +;; (if (stack-empty? (dbr:subdb-dbstack subdb)) +;; (let* ((dbname (db:run-id->dbname run-id)) +;; (newdb (db:open-megatest-db path: (db:dbfile-path) +;; name: dbname))) +;; ;; NOTE: pushing on the stack only happens AFTER the handle has been used +;; ;; (stack-push! (dbr:dbstruct-dbstack dbstruct) newdb) +;; newdb) +;; (stack-pop! (dbr:subdb-dbstack subdb))) +;; (db:open-db subdb run-id))) ;; ) + + +#;(define (db:get-db dbstruct run-id) + (let* ((subdb (dbfile:get-subdb dbstruct run-id)) + (dbdat (dbfile:get-dbdat dbstruct run-id))) + (if (dbr:dbdat? dbdat) + dbdat + (dbfile:open-db *dbstruct-dbs* #f db:initialize-main-db) + ) + ) +) (define-inline (db:generic-error-printout exn . message) (print-call-chain (current-error-port)) (apply debug:print-error 0 *default-log-port* message) (debug:print-error 0 *default-log-port* " params: " params @@ -164,448 +266,47 @@ ", error: " ((condition-property-accessor 'exn 'message) exn) ", arguments: " ((condition-property-accessor 'exn 'arguments) exn) ", location: " ((condition-property-accessor 'exn 'location) exn) )) -;; (db:with-db dbstruct run-id sqlite3:exec "select blah fgrom blaz;") -;; r/w is a flag to indicate if the db is modified by this query #t = yes, #f = no -;; -(define (db:with-db dbstruct run-id r/w proc . params) - (let* ((have-struct (dbr:dbstruct? dbstruct)) - (dbdat (if have-struct - (db:get-db dbstruct) - #f)) - (db (if have-struct - (db:dbdat-get-db dbdat) - dbstruct)) - (fname (db:dbdat-get-path dbdat)) - (use-mutex (> *api-process-request-count* 25))) ;; was 25 - (if (and use-mutex - (common:low-noise-print 120 "over-50-parallel-api-requests")) - (debug:print-info 0 *default-log-port* *api-process-request-count* " parallel api requests being processed in process " (current-process-id) ", throttling access")) - (if (common:low-noise-print 600 (conc "parallel-api-requests" *max-api-process-requests*)) - (debug:print-info 2 *default-log-port* "Parallel api request count: " *api-process-request-count* " max parallel requests: " *max-api-process-requests*)) - (condition-case - (begin - (if use-mutex (mutex-lock! *db-with-db-mutex*)) - (let ((res (apply proc db params))) - (if use-mutex (mutex-unlock! *db-with-db-mutex*)) - ;; (if (vector? dbstruct)(db:done-with dbstruct run-id r/w)) - (if dbdat (stack-push! (dbr:dbstruct-dbstack dbstruct) dbdat)) - res)) - (exn (io-error) - (db:generic-error-printout exn "ERROR: i/o error with " fname ". Check permissions, disk space etc. and try again.")) - (exn (corrupt) - (db:generic-error-printout exn "ERROR: database " fname " is corrupt. Repair it to proceed.")) - (exn (busy) - (db:generic-error-printout exn "ERROR: database " fname - " is locked. Try copying to another location, remove original and copy back.")) - (exn (permission)(db:generic-error-printout exn "ERROR: database " fname " has some permissions problem.")) - (exn () - (db:generic-error-printout exn "ERROR: Unknown error with database " fname " message: " - ((condition-property-accessor 'exn 'message) exn)))))) - -;;====================================================================== -;; K E E P F I L E D B I N dbstruct -;;====================================================================== - -;; (define (db:get-filedb dbstruct run-id) -;; (let ((db (vector-ref dbstruct 2))) -;; (if db -;; db -;; (let ((fdb (filedb:open-db (conc *toplevel* "/db/files.db")))) -;; (vector-set! dbstruct 2 fdb) -;; fdb)))) -;; -;; ;; Can also be used to save arbitrary strings -;; ;; -;; (define (db:save-path dbstruct path) -;; (let ((fdb (db:get-filedb dbstruct)))b -;; (filedb:register-path fdb path))) -;; -;; ;; Use to get a path. To get an arbitrary string see next define -;; ;; -;; (define (db:get-path dbstruct id) -;; (let ((fdb (db:get-filedb dbstruct))) -;; (filedb:get-path db id))) - -;; NB// #f => return dbdir only -;; (was planned to be; zeroth db with name=main.db) -;; -;; If run-id is #f return to create and retrieve the path where the db will live. -;; -(define db:dbfile-path common:get-db-tmp-area) (define (db:set-sync db) (let ((syncprag (configf:lookup *configdat* "setup" "sychronous"))) (sqlite3:execute db (conc "PRAGMA synchronous = " (or syncprag 0) ";")))) -;; open an sql database inside a file lock -;; returns: db existed-prior-to-opening -;; RA => Returns a db handler; sets the lock if opened in writable mode -;; -;; (define *db-open-mutex* (make-mutex)) - -(define (db:lock-create-open fname initproc) - (let* ((parent-dir (or (pathname-directory fname)(current-directory))) ;; no parent? go local - (raw-fname (pathname-file fname)) - (dir-writable (file-write-access? parent-dir)) - (file-exists (common:file-exists? fname)) - (file-write (if file-exists - (file-write-access? fname) - dir-writable ))) - ;; (mutex-lock! *db-open-mutex*) ;; tried this mutex, not clear it helped. - (if file-write ;; dir-writable - (condition-case - (let* ((lockfname (conc fname ".lock")) - (readyfname (conc parent-dir "/.ready-" raw-fname)) - (readyexists (common:file-exists? readyfname))) - (if (not readyexists) - (common:simple-file-lock-and-wait lockfname)) - (let ((db (sqlite3:open-database fname))) - (sqlite3:set-busy-handler! db (sqlite3:make-busy-timeout 136000)) - (sqlite3:execute db "PRAGMA synchronous = 0;") - (if (and (configf:lookup *configdat* "setup" "tmp_mode") (string-match "^/tmp/.*" fname)) - (begin - ;;(print "DEBUG: Setting tmp_mode for " fname) - (sqlite3:execute db (configf:lookup *configdat* "setup" "tmp_mode")) - ) - ) - (if (and (configf:lookup *configdat* "setup" "nfs_mode") (not (string-match "^/tmp/.*" fname))) - (begin - ;;(print "DEBUG: Setting nfs_mode for " fname) - (sqlite3:execute db (configf:lookup *configdat* "setup" "nfs_mode")) - ) - ) - (if (and (not (or (configf:lookup *configdat* "setup" "tmp_mode") (configf:lookup *configdat* "setup" "nfs_mode"))) - (configf:lookup *configdat* "setup" "use-wal") - (string-match "^/tmp/.*" fname)) ;; this is a file in /tmp - (sqlite3:execute db "PRAGMA journal_mode=WAL;") - (debug:print 2 *default-log-port* "Creating " fname " in NON-WAL mode.")) - (if (not file-exists) - (initproc db)) - (if (not readyexists) - (begin - (common:simple-file-release-lock lockfname) - (with-output-to-file - readyfname - (lambda () - (print "Ready at " - (seconds->year-work-week/day-time - (current-seconds))))))) - db)) - (exn (io-error) (debug:print 0 *default-log-port* "ERROR: i/o error with " fname ". Check permissions, disk space etc. and try again.")) - (exn (corrupt) (debug:print 0 *default-log-port* "ERROR: database " fname " is corrupt. Repair it to proceed.")) - (exn (busy) (debug:print 0 *default-log-port* "ERROR: database " fname " is locked. Try copying to another location, remove original and copy back.")) - (exn (permission)(debug:print 0 *default-log-port* "ERROR: database " fname " has some permissions problem.")) - (exn () (debug:print 0 *default-log-port* "ERROR: Unknown error with database " fname " message: " ((condition-property-accessor 'exn 'message) exn)))) - - (condition-case - (begin - (debug:print 2 *default-log-port* "WARNING: opening db in non-writable dir " fname) - (let ((db (sqlite3:open-database fname))) - (sqlite3:set-busy-handler! db (sqlite3:make-busy-timeout 136000)) - (sqlite3:execute db "PRAGMA synchronous = 0;") - ;; (mutex-unlock! *db-open-mutex*) - db)) - (exn (io-error) (debug:print 0 *default-log-port* "ERROR: i/o error with " fname ". Check permissions, disk space etc. and try again.")) - (exn (corrupt) (debug:print 0 *default-log-port* "ERROR: database " fname " is corrupt. Repair it to proceed.")) - (exn (busy) (debug:print 0 *default-log-port* "ERROR: database " fname " is locked. Try copying to another location, remove original and copy back.")) - (exn (permission)(debug:print 0 *default-log-port* "ERROR: database " fname " has some permissions problem.")) - (exn () (debug:print 0 *default-log-port* "ERROR: Unknown error with database " fname " message: " ((condition-property-accessor 'exn 'message) exn)))) - ))) - - -;; This routine creates the db if not already present. It is only called if the db is not already opened -;; -(define (db:open-db dbstruct #!key (areapath #f)(do-sync #t)) ;; TODO: actually use areapath - (let ((tmpdb-stack (dbr:dbstruct-dbstack dbstruct))) ;; RA => Returns the first reference in dbstruct - (if (stack? tmpdb-stack) - (db:get-db tmpdb-stack) ;; get previously opened db (will create new db handle if all in the stack are already used - (let* ((max-stale-tmp (configf:lookup-number *configdat* "server" "filling-db-max-stale-seconds" default: 10)) - (dbpath (db:dbfile-path )) ;; path to tmp db area - (dbexists (common:file-exists? dbpath)) - (tmpdbfname (conc dbpath "/megatest.db")) - (dbfexists (common:file-exists? tmpdbfname)) ;; (conc dbpath "/megatest.db"))) - (mtdbexists (common:file-exists? (conc *toppath* "/megatest.db"))) - - (mtdbmodtime (if mtdbexists (common:lazy-sqlite-db-modification-time (conc *toppath* "/megatest.db")) #f)) - (tmpdbmodtime (if dbfexists (common:lazy-sqlite-db-modification-time tmpdbfname) #f)) - (mtdb (db:open-megatest-db)) - (mtdbpath (db:dbdat-get-path mtdb)) - (tmpdb (db:open-megatest-db path: dbpath)) ;; lock-create-open dbpath db:initialize-main-db)) - (refndb (db:open-megatest-db path: dbpath name: "megatest_ref.db")) - (write-access (file-write-access? mtdbpath)) - ;(mtdbmodtime (if mtdbexists (common:lazy-sqlite-db-modification-time mtdbpath) #f)) ; moving this before db:open-megatest-db is called. if wal mode is on -WAL and -shm file get created with causing the tmpdbmodtime timestamp always greater than mtdbmodtime - ;(tmpdbmodtime (if dbfexists (common:lazy-sqlite-db-modification-time tmpdbfname) #f)) - ;if wal mode is on -WAL and -shm file get created when db:open-megatest-db is called. modtimedelta will always be < 10 so db in tmp not get synced - ;(tmpdbmodtime (if dbfexists (db:get-last-update-time (car tmpdb)) #f)) - ;(fmt (file-modification-time tmpdbfname)) - (modtimedelta (and mtdbmodtime tmpdbmodtime (- mtdbmodtime tmpdbmodtime)))) - - (when write-access - (sqlite3:execute (car mtdb) "drop trigger if exists update_tests_trigger") - (sqlite3:execute (car mtdb) "drop trigger if exists update_runs_trigger")) - - ;(print "mtdbmodtime " mtdbmodtime " tmpdbmodtime " tmpdbmodtime " mtdbpath " mtdbpath " " (conc *toppath* "/megatest.db")) - ;;(debug:print-info 13 *default-log-port* "db:open-db>> mtdbpath="mtdbpath" mtdbexists="mtdbexists" and write-access="write-access) - (if (and dbexists (not write-access)) - (begin - (set! *db-write-access* #f) - (dbr:dbstruct-read-only-set! dbstruct #t))) - (dbr:dbstruct-mtdb-set! dbstruct mtdb) - (dbr:dbstruct-tmpdb-set! dbstruct tmpdb) - (dbr:dbstruct-dbstack-set! dbstruct (make-stack)) ;; BB: why a stack? Why would the number of db's be indeterminate? Is this a legacy of 1.db 2.db .. ? - (stack-push! (dbr:dbstruct-dbstack dbstruct) tmpdb) ;; olddb is already a (cons db path) - (dbr:dbstruct-refndb-set! dbstruct refndb) - (if (and (or (not dbfexists) - (and modtimedelta - (> modtimedelta max-stale-tmp))) ;; if db in tmp is over ten seconds older than the file in MTRA then do a sync back - do-sync) - (begin - (debug:print 1 *default-log-port* "filling db " (db:dbdat-get-path tmpdb) " with data \n from " (db:dbdat-get-path mtdb) " mod time delta: " modtimedelta) - (db:sync-tables (db:sync-all-tables-list dbstruct) #f mtdb refndb tmpdb) - ;touch tmp db to avoid wal mode wierdness - (set! (file-modification-time tmpdbfname) (current-seconds)) - (debug:print-info 13 *default-log-port* "db:sync-all-tables-list done.") - ) - (debug:print 4 *default-log-port* " db, " (db:dbdat-get-path tmpdb) " already exists or fresh enough, not propogating data from\n " (db:dbdat-get-path mtdb) " mod time delta: " modtimedelta) ) - ;; (db:multi-db-sync dbstruct 'old2new)) ;; migrate data from megatest.db automatically - tmpdb)))) - (define (db:get-last-update-time db) -; (db:with-db -; dbstruct #f #f -; (lambda (db) - (let ((last-update-time #f)) - (sqlite3:for-each-row - (lambda (lup) - (set! last-update-time lup)) - db - "select max(lup) from ( select max(last_update) as lup from tests union select max(last_update) as lup from runs);") - last-update-time)) -;)) - -;; Make the dbstruct, setup up auxillary db's and call for main db at least once -;; -;; called in http-transport and replicated in rmt.scm for *local* access. -;; -(define (db:setup do-sync #!key (areapath #f)) - ;; - (cond - (*dbstruct-db* *dbstruct-db*);; TODO: when multiple areas are supported, this optimization will be a hazard - (else ;;(common:on-homehost?) - (debug:print-info 13 *default-log-port* "db:setup entered (first time, not cached.)") - (let* ((dbstruct (make-dbr:dbstruct))) - (when (not *toppath*) - (debug:print-info 13 *default-log-port* "in db:setup, *toppath* not set; calling launch:setup") - (launch:setup areapath: areapath)) - (debug:print-info 13 *default-log-port* "Begin db:open-db") - (db:open-db dbstruct areapath: areapath do-sync: do-sync) - (debug:print-info 13 *default-log-port* "Done db:open-db") - (set! *dbstruct-db* dbstruct) - ;;(debug:print-info 13 *default-log-port* "new dbstruct = "(dbr:dbstruct->alist dbstruct)) - dbstruct)))) - ;; (else - ;; (debug:print 0 *default-log-port* "ERROR: attempt to open database when not on homehost. Exiting. Homehost: " (common:get-homehost)) - ;; (exit 1)))) + (let ((last-update-time #f)) + (sqlite3:for-each-row + (lambda (lup) + (set! last-update-time lup)) + db + "select max(lup) from ( select max(last_update) as lup from tests union select max(last_update) as lup from runs);") + last-update-time)) + ;; Open the classic megatest.db file (defaults to open in toppath) ;; ;; NOTE: returns a dbdat not a dbstruct! ;; - -;;(define (db:reopen-megatest-db - -(define (db:open-megatest-db #!key (path #f)(name #f)) - (let* ((dbdir (or path *toppath*)) - (dbpath (conc dbdir "/" (or name "megatest.db"))) - (dbexists (common:file-exists? dbpath)) +(define (db:open-megatest-db dbpath) + (let* ((dbexists (file-exists? dbpath)) (db (db:lock-create-open dbpath (lambda (db) - (db:initialize-main-db db) - ;;(db:initialize-run-id-db db) - ))) + (db:initialize-main-db db)))) (write-access (file-write-access? dbpath))) (debug:print-info 13 *default-log-port* "db:open-megatest-db "dbpath) (if (and dbexists (not write-access)) (set! *db-write-access* #f)) - (cons db dbpath))) - -;; sync run to disk if touched -;; -(define (db:sync-touched dbstruct run-id #!key (force-sync #f)) - (let ((tmpdb (db:get-db dbstruct)) - (mtdb (dbr:dbstruct-mtdb dbstruct)) - (refndb (dbr:dbstruct-refndb dbstruct)) - (start-t (current-seconds))) - (debug:print-info 4 *default-log-port* "Syncing for run-id: " run-id) - (mutex-lock! *db-multi-sync-mutex*) - (let ((update_info (cons (if force-sync 0 *db-last-sync*) "last_update"))) - (mutex-unlock! *db-multi-sync-mutex*) - (db:sync-tables (db:sync-all-tables-list dbstruct) update_info tmpdb refndb mtdb)) - (mutex-lock! *db-multi-sync-mutex*) - (set! *db-last-sync* start-t) - (set! *db-last-access* start-t) - (mutex-unlock! *db-multi-sync-mutex*) - (stack-push! (dbr:dbstruct-dbstack dbstruct) tmpdb))) - -(define (db:safely-close-sqlite3-db db stmt-cache #!key (try-num 3)) - (if (<= try-num 0) - #f - (handle-exceptions - exn - (begin - (print "Attempt to safely close sqlite3 db failed. Trying again. exn=" exn) - (thread-sleep! 3) - (sqlite3:interrupt! db) - (db:safely-close-sqlite3-db db stmtcache try-num: (- try-num 1))) - (if (sqlite3:database? db) - (let* ((stmts (and stmt-cache (hash-table-ref/default stmt-cache db #f)))) - (if stmts (map sqlite3:finalize! (hash-table-values stmts))) - (sqlite3:finalize! db) - #t) - #f)))) - -;; close all opened run-id dbs -(define (db:close-all dbstruct) - (if (dbr:dbstruct? dbstruct) - (handle-exceptions - exn - (begin - (debug:print 0 *default-log-port* "WARNING: Finalizing failed, " ((condition-property-accessor 'exn 'message) exn) ", note - exn=" exn) - (print-call-chain *default-log-port*)) - ;; (db:sync-touched dbstruct 0 force-sync: #t) ;; NO. Do not do this here. Instead we rely on a server to be started when there are writes, even if the server itself is not going to be used as a server. - (let ((tdbs (map db:dbdat-get-db - (stack->list (dbr:dbstruct-dbstack dbstruct)))) - (mdb (db:dbdat-get-db (dbr:dbstruct-mtdb dbstruct))) - (rdb (db:dbdat-get-db (dbr:dbstruct-refndb dbstruct))) - (stmt-cache (dbr:dbstruct-stmt-cache dbstruct))) - (map (lambda (db) - (db:safely-close-sqlite3-db db stmt-cache)) - tdbs) - (db:safely-close-sqlite3-db mdb stmt-cache) ;; (if (sqlite3:database? mdb) (sqlite3:finalize! mdb)) - (db:safely-close-sqlite3-db rdb stmt-cache))))) ;; (if (sqlite3:database? rdb) (sqlite3:finalize! rdb)))))) - -;; (let ((locdbs (dbr:dbstruct-locdbs dbstruct))) -;; (if (hash-table? locdbs) -;; (for-each (lambda (run-id) -;; (db:close-run-db dbstruct run-id)) -;; (hash-table-keys locdbs))))) - -;; (define (db:open-inmem-db) -;; (let* ((db (sqlite3:open-database ":memory:")) -;; (handler (make-busy-timeout 3600))) -;; (sqlite3:set-busy-handler! db handler) -;; (db:initialize-run-id-db db) -;; (cons db #f))) - -;; just tests, test_steps and test_data tables -(define db:sync-tests-only - (list - ;; (list "strs" - ;; '("id" #f) - ;; '("str" #f)) - (list "tests" - '("id" #f) - '("run_id" #f) - '("testname" #f) - '("host" #f) - '("cpuload" #f) - '("diskfree" #f) - '("uname" #f) - '("rundir" #f) - '("shortdir" #f) - '("item_path" #f) - '("state" #f) - '("status" #f) - '("attemptnum" #f) - '("final_logf" #f) - '("logdat" #f) - '("run_duration" #f) - '("comment" #f) - '("event_time" #f) - '("fail_count" #f) - '("pass_count" #f) - '("archived" #f) - '("last_update" #f)) - (list "test_steps" - '("id" #f) - '("test_id" #f) - '("stepname" #f) - '("state" #f) - '("status" #f) - '("event_time" #f) - '("comment" #f) - '("logfile" #f) - '("last_update" #f)) - (list "test_data" - '("id" #f) - '("test_id" #f) - '("category" #f) - '("variable" #f) - '("value" #f) - '("expected" #f) - '("tol" #f) - '("units" #f) - '("comment" #f) - '("status" #f) - '("type" #f) - '("last_update" #f)))) - -;; needs db to get keys, this is for syncing all tables -;; -(define (db:sync-main-list dbstruct) - (let ((keys (db:get-keys dbstruct))) - (list - (list "keys" - '("id" #f) - '("fieldname" #f) - '("fieldtype" #f)) - (list "metadat" '("var" #f) '("val" #f)) - (append (list "runs" - '("id" #f)) - (map (lambda (k)(list k #f)) - (append keys - (list "runname" "state" "status" "owner" "event_time" "comment" "fail_count" "pass_count" "contour" "last_update")))) - (list "archive_disks" - '("id" #f) - '("archive_area_name" #f) - '("disk_path" #f) - '("last_df" #f) - '("last_df_time" #f) - '("creation_time" #f)) - - (list "archive_blocks" - '("id" #f) - '("archive_disk_id" #f) - '("disk_path" #f) - '("last_du" #f) - '("last_du_time" #f) - '("creation_time" #f)) - - (list "test_meta" - '("id" #f) - '("testname" #f) - '("owner" #f) - '("description" #f) - '("reviewed" #f) - '("iterated" #f) - '("avg_runtime" #f) - '("avg_disk" #f) - '("tags" #f) - '("jobgroup" #f))))) - -(define (db:sync-all-tables-list dbstruct) - (append (db:sync-main-list dbstruct) - db:sync-tests-only)) + ;; (cons db dbpath))) + (make-dbr:dbdat dbfile: dbpath dbh: db read-only: (not write-access)))) + ;; use bunch of Unix commands to try to break the lock and recreate the db ;; (define (db:move-and-recreate-db dbdat) - (let* ((dbpath (db:dbdat-get-path dbdat)) + (let* ((dbpath (dbr:dbdat-dbfile dbdat)) (dbdir (pathname-directory dbpath)) (fname (pathname-strip-directory dbpath)) (fnamejnl (conc fname "-journal")) (tmpname (conc fname "." (current-process-id))) (tmpjnl (conc fnamejnl "." (current-process-id)))) @@ -622,11 +323,11 @@ ;; return #f to indicate the dbdat should be closed/reopened ;; else return dbdat ;; (define (db:repair-db dbdat #!key (numtries 1)) - (let* ((dbpath (db:dbdat-get-path dbdat)) + (let* ((dbpath (dbr:dbdat-dbfile dbdat)) (dbdir (pathname-directory dbpath)) (fname (pathname-strip-directory dbpath))) (debug:print-info 0 *default-log-port* "Checking db " dbpath " for errors.") (cond ((not (file-write-access? dbdir)) @@ -639,11 +340,11 @@ ;; (else ;; ((equal? fname "megatest.db") ;; this file can be regenerated if needed (handle-exceptions exn (begin - (print "Problems trying to repair the db, exn=" exn) + (debug:print 0 *default-debug-port* "Problems trying to repair the db, exn=" exn) ;; (db:move-and-recreate-db dbdat) (if (> numtries 0) (db:repair-db dbdat numtries: (- numtries 1)) #f) (debug:print 0 *default-log-port* "FATAL: file " dbpath " was found corrupted, an attempt to fix has been made but you must start over.") @@ -675,289 +376,11 @@ (sqlite3:execute db "vacuum;"))) (sqlite3:finalize! db) #t)))))) -;; tbls is ( ("tablename" ( "field1" [#f|proc1] ) ( "field2" [#f|proc2] ) .... ) ) -;; db's are dbdat's -;; -;; if last-update specified ("field-name" . time-in-seconds) -;; then sync only records where field-name >= time-in-seconds -;; IFF field-name exists -;; -(define (db:sync-tables tbls last-update fromdb todb . slave-dbs) - (handle-exceptions - exn - (begin - (debug:print 0 *default-log-port* "EXCEPTION: database probably overloaded or unreadable in db:sync-tables.") - (print-call-chain (current-error-port)) - (debug:print 0 *default-log-port* " message: " ((condition-property-accessor 'exn 'message) exn)) - (debug:print 5 *default-log-port* "exn=" (condition->list exn)) - (debug:print 0 *default-log-port* " status: " ((condition-property-accessor 'sqlite3 'status) exn)) - (debug:print 0 *default-log-port* " src db: " (db:dbdat-get-path fromdb)) - (for-each (lambda (dbdat) - (let ((dbpath (db:dbdat-get-path dbdat))) - (debug:print 0 *default-log-port* " dbpath: " dbpath) - (if (not (db:repair-db dbdat)) - (begin - (debug:print-error 0 *default-log-port* "Failed to rebuild " dbpath ", exiting now.") - (exit))))) - (cons todb slave-dbs)) - - 0) - ;; this is the work to be done - (cond - ((not fromdb) (debug:print 3 *default-log-port* "WARNING: db:sync-tables called with fromdb missing") - -1) - ((not todb) (debug:print 3 *default-log-port* "WARNING: db:sync-tables called with todb missing") - -2) - ((not (sqlite3:database? (db:dbdat-get-db fromdb))) - (debug:print-error 0 *default-log-port* "db:sync-tables called with fromdb not a database " fromdb) - -3) - ((not (sqlite3:database? (db:dbdat-get-db todb))) - (debug:print-error 0 *default-log-port* "db:sync-tables called with todb not a database " todb) - -4) - - ((not (file-write-access? (db:dbdat-get-path todb))) - (debug:print-error 0 *default-log-port* "db:sync-tables called with todb not a read-only database " todb) - -5) - ((not (null? (let ((readonly-slave-dbs - (filter - (lambda (dbdat) - (not (file-write-access? (db:dbdat-get-path todb)))) - slave-dbs))) - (for-each - (lambda (bad-dbdat) - (debug:print-error - 0 *default-log-port* "db:sync-tables called with todb not a read-only database " bad-dbdat)) - readonly-slave-dbs) - readonly-slave-dbs))) -6) - (else - (let ((stmts (make-hash-table)) ;; table-field => stmt - (all-stmts '()) ;; ( ( stmt1 value1 ) ( stml2 value2 )) - (numrecs (make-hash-table)) - (start-time (current-milliseconds)) - (tot-count 0)) - (for-each ;; table - (lambda (tabledat) - (let* ((tablename (car tabledat)) - (fields (cdr tabledat)) - (has-last-update (member "last_update" fields)) - (use-last-update (cond - ((and has-last-update - (member "last_update" fields)) - #t) ;; if given a number, just use it for all fields - ((number? last-update) #f) ;; if not matched first entry then ignore last-update for this table - ((and (pair? last-update) - (member (car last-update) ;; last-update field name - (map car fields))) - #t) - (last-update - (debug:print 0 *default-log-port* "ERROR: parameter last-update for db:sync-tables must be a pair or a number, received: " last-update);; found in fields - #f) - (else - #f))) - (last-update-value (if use-last-update ;; no need to check for has-last-update - it is already accounted for - (if (number? last-update) - last-update - (cdr last-update)) - #f)) - (last-update-field (if use-last-update - (if (number? last-update) - "last_update" - (car last-update)) - #f)) - (num-fields (length fields)) - (field->num (make-hash-table)) - (num->field (apply vector (map car fields))) ;; BBHERE - (full-sel (conc "SELECT " (string-intersperse (map car fields) ",") - " FROM " tablename (if use-last-update ;; apply last-update criteria - (conc " WHERE " last-update-field " >= " last-update-value) - "") - ";")) - (full-ins (conc "INSERT OR REPLACE INTO " tablename " ( " (string-intersperse (map car fields) ",") " ) " - " VALUES ( " (string-intersperse (make-list num-fields "?") ",") " );")) - (fromdat '()) - (fromdats '()) - (totrecords 0) - (batch-len (string->number (or (configf:lookup *configdat* "sync" "batchsize") "100"))) - (todat (make-hash-table)) - (count 0) - (field-names (map car fields)) - (delay-handicap (string->number (or (configf:lookup *configdat* "sync" "delay-handicap") "0"))) - ) - - ;; set up the field->num table - (for-each - (lambda (field) - (hash-table-set! field->num field count) - (set! count (+ count 1))) - fields) - - ;; read the source table - (sqlite3:for-each-row - (lambda (a . b) - (set! fromdat (cons (apply vector a b) fromdat)) - (if (> (length fromdat) batch-len) - (begin - (set! fromdats (cons fromdat fromdats)) - (set! fromdat '()) - (set! totrecords (+ totrecords 1))))) - (db:dbdat-get-db fromdb) - full-sel) - - ;; tack on remaining records in fromdat - (if (not (null? fromdat)) - (set! fromdats (cons fromdat fromdats))) - - (if (common:low-noise-print 120 "sync-records") - (debug:print-info 4 *default-log-port* "found " totrecords " records to sync")) - - ;; read the target table; BBHERE - (sqlite3:for-each-row - (lambda (a . b) - (hash-table-set! todat a (apply vector a b))) - (db:dbdat-get-db todb) - full-sel) - - (when (and delay-handicap (> delay-handicap 0)) - (debug:print-info 0 *default-log-port* "imposing synthetic sync delay of "delay-handicap" seconds since sync/delay-handicap is configured") - (thread-sleep! delay-handicap) - (debug:print-info 0 *default-log-port* "synthetic sync delay of "delay-handicap" seconds completed") - ) - - ;; first pass implementation, just insert all changed rows - (for-each - (lambda (targdb) - (let* ((db (db:dbdat-get-db targdb)) - (drp-trigger (if (member "last_update" field-names) - (db:drop-trigger db tablename) - #f)) - (is-trigger-dropped (if (member "last_update" field-names) - (db:is-trigger-dropped db tablename) - #f)) - (stmth (sqlite3:prepare db full-ins))) - ;; (db:delay-if-busy targdb) ;; NO WAITING - (if (member "last_update" field-names) - (debug:print-info 3 *default-log-port* "is-trigger-dropped: " is-trigger-dropped)) - (for-each - (lambda (fromdat-lst) - (sqlite3:with-transaction - db - (lambda () - (for-each ;; - (lambda (fromrow) - (let* ((a (vector-ref fromrow 0)) - (curr (hash-table-ref/default todat a #f)) - (same #t)) - (let loop ((i 0)) - (if (or (not curr) - (not (equal? (vector-ref fromrow i)(vector-ref curr i)))) - (set! same #f)) - (if (and same - (< i (- num-fields 1))) - (loop (+ i 1)))) - (if (not same) - (begin - (apply sqlite3:execute stmth (vector->list fromrow)) - (hash-table-set! numrecs tablename (+ 1 (hash-table-ref/default numrecs tablename 0))))))) - fromdat-lst)))) - fromdats) - (sqlite3:finalize! stmth) - (if (member "last_update" field-names) - (db:create-trigger db tablename)))) - (append (list todb) slave-dbs)))) - tbls) - (let* ((runtime (- (current-milliseconds) start-time)) - (should-print (or (debug:debug-mode 12) - (common:low-noise-print 120 "db sync" (> runtime 500))))) ;; low and high sync times treated as separate. - (if should-print (debug:print 3 *default-log-port* "INFO: db sync, total run time " runtime " ms")) - (for-each - (lambda (dat) - (let ((tblname (car dat)) - (count (cdr dat))) - (set! tot-count (+ tot-count count)) - (if (> count 0) - (if should-print (debug:print 0 *default-log-port* (format #f " ~10a ~5a" tblname count)))))) - (sort (hash-table->alist numrecs)(lambda (a b)(> (cdr a)(cdr b)))))) - tot-count))))) - -(define (db:patch-schema-rundb frundb) - ;; - ;; remove this some time after September 2016 (added in version v1.6031 - ;; - (for-each - (lambda (table-name) - (handle-exceptions - exn - (if (string-match ".*duplicate.*" ((condition-property-accessor 'exn 'message) exn)) - (debug:print 0 *default-log-port* "Column last_update already added to " table-name " table") - (db:general-sqlite-error-dump exn "alter table " table-name " ..." #f "none")) - (sqlite3:execute - frundb - (conc "ALTER TABLE " table-name " ADD COLUMN last_update INTEGER DEFAULT 0"))) - (sqlite3:execute - frundb - (conc "DROP TRIGGER IF EXISTS update_" table-name "_trigger;")) - (sqlite3:execute - frundb - (conc "CREATE TRIGGER IF NOT EXISTS update_" table-name "_trigger AFTER UPDATE ON " table-name " - FOR EACH ROW - BEGIN - UPDATE " table-name " SET last_update=(strftime('%s','now')) - WHERE id=old.id; - END;")) - ) - '("tests" "test_steps" "test_data"))) - -(define (db:patch-schema-maindb maindb) - ;; - ;; remove all these some time after september 2016 (added in v1.6031 - ;; - (for-each - (lambda (column type default) - (handle-exceptions - exn - (if (string-match ".*duplicate.*" ((condition-property-accessor 'exn 'message) exn)) - (debug:print 0 *default-log-port* "Column " column " already added to runs table") - (db:general-sqlite-error-dump exn "alter table runs ..." #f "none")) - (sqlite3:execute - maindb - (conc "ALTER TABLE runs ADD COLUMN " column " " type " DEFAULT " default)))) - (list "last_update" "contour") - (list "INTEGER" "TEXT" ) - (list "0" "''" )) - ;; these schema changes don't need exception handling - (sqlite3:execute - maindb - "CREATE TRIGGER IF NOT EXISTS update_runs_trigger AFTER UPDATE ON runs - FOR EACH ROW - BEGIN - UPDATE runs SET last_update=(strftime('%s','now')) - WHERE id=old.id; - END;") - (sqlite3:execute maindb "CREATE TABLE IF NOT EXISTS run_stats ( - id INTEGER PRIMARY KEY, - run_id INTEGER, - state TEXT, - status TEXT, - count INTEGER, - last_update INTEGER DEFAULT (strftime('%s','now')))") - (sqlite3:execute maindb "CREATE TRIGGER IF NOT EXISTS update_run_stats_trigger AFTER UPDATE ON run_stats - FOR EACH ROW - BEGIN - UPDATE run_stats SET last_update=(strftime('%s','now')) - WHERE id=old.id; - END;") - (sqlite3:execute maindb "CREATE TABLE IF NOT EXISTS test_rundat ( - id INTEGER PRIMARY KEY, - test_id INTEGER, - update_time TIMESTAMP, - cpuload INTEGER DEFAULT -1, - diskfree INTEGER DEFAULT -1, - diskusage INTGER DEFAULT -1, - run_duration INTEGER DEFAULT 0);")) + (define (db:adj-target db) (let ((fields (configf:get-section *configdat* "fields")) (field-num 0)) ;; because we will be refreshing the keys table it is best to clear it here @@ -1006,13 +429,15 @@ (define (db:cache-for-read-only source target #!key (use-last-update #f)) (if (and (hash-table-ref/default *global-db-store* target #f) (>= (file-modification-time target)(file-modification-time source))) (hash-table-ref *global-db-store* target) (let* ((toppath (launch:setup)) - (targ-db-last-mod (if (common:file-exists? target) - (file-modification-time target) - 0)) + (targ-db-last-mod (db:get-sqlite3-mod-time target)) +;; (if (common:file-exists? target) +;; BUG: This needs to include wal mode stuff .shm etc. +;; (file-modification-time target) +;; 0)) (cache-db (or (hash-table-ref/default *global-db-store* target #f) (db:open-megatest-db path: target))) (source-db (db:open-megatest-db path: source)) (curr-time (current-seconds)) (res '()) @@ -1020,41 +445,139 @@ (db:sync-tables (db:sync-main-list source-db) last-update source-db cache-db) (db:sync-tables db:sync-tests-only last-update source-db cache-db) (hash-table-set! *global-db-store* target cache-db) cache-db))) -;; ;; call a proc with a cached db -;; ;; -;; (define (db:call-with-cached-db proc . params) -;; ;; first cache the db in /tmp -;; (let* ((cname-part (conc "megatest_cache/" (common:get-testsuite-name))) -;; (fname (conc (common:get-area-path-signature) ".db")) -;; (cache-dir (common:get-create-writeable-dir -;; (list (conc "/tmp/" (current-user-name) "/" cname-part) -;; (conc "/tmp/" (current-user-name) "-" cname-part) -;; (conc "/tmp/" (current-user-name) "_" cname-part)))) -;; (megatest-db (conc *toppath* "/megatest.db"))) -;; ;; (debug:print-info 0 *default-log-port* "Using cache dir " cache-dir) -;; (if (not cache-dir) -;; (begin -;; (debug:print 0 *default-log-port* "ERROR: Failed to find an area to write the cache db") -;; (exit 1)) -;; (let* ((th1 (make-thread -;; (lambda () -;; (if (and (common:file-exists? megatest-db) -;; (file-write-access? megatest-db)) -;; (begin -;; (db:sync-to-megatest.db dbstruct 'timestamps) ;; internally mutexes on *db-local-sync* -;; (debug:print-info 2 *default-log-port* "Done syncing to megatest.db")))) -;; "call-with-cached-db sync-to-megatest.db")) -;; (cache-db (db:cache-for-read-only -;; megatest-db -;; (conc cache-dir "/" fname) -;; use-last-update: #t))) -;; (thread-start! th1) -;; (apply proc cache-db params) -;; )))) +(define (db:get-sqlite3-mod-time fname) + (let* ((wal-file (conc fname "-wal")) + (shm-file (conc fname "-shm")) + (get-mtime (lambda (f) + (if (and (file-exists? f) + (file-read-access? f)) + (file-modification-time f) + 0)))) + (max (get-mtime fname) + (get-mtime wal-file) + (get-mtime shm-file)))) + +;; (define (db:all-db-sync dbstruct) +;; (let* ((dbdat (db:open-db dbstruct #f db:initialize-main-db)) +;; (data-synced 0) ;; count of changed records +;; (tmp-area (common:make-tmpdir-name *toppath*)) +;; (dbfiles (glob (conc tmp-area"/.mtdb/*.db"))) +;; (sync-durations (make-hash-table)) +;; (no-sync-db (db:open-no-sync-db))) +;; (for-each +;; (lambda (file) ;; tmp db file +;; (debug:print-info 3 *default-log-port* "file: " file) +;; (let* ((fname (conc (pathname-file file) ".db")) ;; fname is tmp db file +;; (wal-file (conc fname "-wal")) +;; (shm-file (conc fname "-shm")) +;; (fulln (conc *toppath*"/,mtdb/"fname)) ;; fulln is nfs db name +;; (wal-time (if (file-exists? wal-file) +;; (file-modification-time wal-file) +;; 0)) +;; (shm-time (if (file-exists? shm-file) +;; (file-modification-time shm-file) +;; 0)) +;; (time1 (db:get-sqlite3-mod-time file)) +;; ;; (if (file-exists? file) ;; time1 is the max itime of the tmp db, -wal and -shm files. +;; ;; (max (file-modification-time file) wal-time shm-time) +;; ;; (begin +;; ;; (debug:print-info 2 *default-log-port* "Sync - I do not see file "file) +;; ;; 1))) +;; (time2 (db:get-sqlite3-mod-time fulln)) +;; ;; (if (file-exists? fulln) ;; time2 is nfs file time +;; ;; (file-modification-time fulln) +;; ;; (begin +;; ;; (debug:print-info 2 *default-log-port* "Sync - I do not see file "fulln) +;; ;; 0))) +;; (changed (> (- time1 time2) (+ (random 5) 1))) ;; it has been at some few seconds since last synced +;; (changed10 (> (- time1 time2) 10)) ;; it has been at least ten seconds since sync'd +;; (jfile-exists (file-exists? (conc file"-journal"))) ;; i.e. are we busy? +;; (do-cp (cond +;; ((not (file-exists? fulln)) ;; shouldn't happen, but this might recover +;; (cons #t (conc "File "fulln" not found! Copying "fname" to "fulln))) +;; ((and (not jfile-exists) changed) +;; (cons #t "not busy, changed")) ;; not busy and changed +;; ((and jfile-exists changed10) +;; (cons #t "busy but not synced in a while")) ;; busy but not sync'd in over 10 seconds +;; ((and changed *time-to-exit*) +;; (cons #t "Time to exit, forced final sync")) ;; last sync +;; (else +;; (cons #f "No sync needed"))))) +;; (if (car do-cp) +;; (let* ((start-time (current-milliseconds)) +;; (fname (pathname-file file)) +;; (runid (if (string= fname "main") #f (string->number fname)))) +;; (debug:print-info 3 *default-log-port* "db:all-db-sync: fname: " +;; fname", delta: " (- time1 time2) " seconds, reason: "(cdr do-cp)) +;; (db:lock-and-delta-sync no-sync-db dbstruct fname runid (db:get-keys dbstruct) db:initialize-main-db) +;; (hash-table-set! sync-durations (conc fname".db") +;; (- (current-milliseconds) start-time))) +;; (debug:print-info 3 *default-log-port* "skipping sync. " file " is up to date") +;; ))) +;; dbfiles) +;; ;; WHY does the dbdat need to be added back? +;; (if dbdat (dbfile:add-dbdat dbstruct #f dbdat)) +;; ) +;; #t) + +(define (db:kill-servers) + (let* ((tl (launch:setup)) ;; need this to initialize *toppath* + (servdir (conc *toppath* "/.servinfo")) + (servfiles (glob (conc servdir "/*:*.db"))) + (fmtstr "~10a~22a~10a~25a~25a~8a\n") + (dbfiles (append (glob (conc *toppath* "/.mtdb/main.db")) (glob (conc *toppath* "/.mtdb/?.db"))(glob (conc *toppath* "/.mtdb/??.db")))) + (ttdat (make-tt areapath: *toppath*)) + ) + (format #t fmtstr "DB" "host:port" "PID" "age" "last mod" "state") + (for-each + (lambda (dbfile) + (let* ( + (dbfname (conc (pathname-file dbfile) ".db")) + (sfiles (tt:find-server *toppath* dbfname)) + ) + (for-each + (lambda (sfile) + (let ( + (sinfos (tt:get-server-info-sorted ttdat dbfname)) + ) + (for-each + (lambda (sinfo) + (let* ( + (db (list-ref sinfo 5)) + (pid (list-ref sinfo 4)) + (host (list-ref sinfo 0)) + (port (list-ref sinfo 1)) + (server-id (list-ref sinfo 3)) + (age (seconds->hr-min-sec (- (current-seconds) (list-ref sinfo 2)))) + (last-mod (seconds->string (list-ref sinfo 2))) + (killed (system (conc "ssh " host " kill " pid " > /dev/null"))) + (dummy2 (sleep 1)) + (state (if (> (system (conc "ssh " host " ps " pid " > /dev/null")) 0) "dead" "alive")) + ) + (format #t fmtstr db (conc host ":" port) pid age last-mod state) + (system (conc "rm " sfile)) + ) + ) + sinfos + ) + ) + ) + sfiles + ) + ) + ) + dbfiles + ) + ;; remove this db, because otherwise metadata contains records for old servers, and this causes a problem with db:no-sync-get-lock-with-id. + (if (file-exists? (conc *toppath* "/.mtdb/no-sync.db")) + (delete-file (conc *toppath* "/.mtdb/no-sync.db")) + ) + ) +) ;; options: ;; ;; 'killservers - kills all servers ;; 'dejunk - removes junk records @@ -1064,82 +587,107 @@ ;; 'closeall - close all opened dbs ;; 'schema - attempt to apply schema changes ;; run-ids: '(1 2 3 ...) or #f (for all) ;; (define (db:multi-db-sync dbstruct . options) - ;; (if (not (launch:setup)) - ;; (debug:print 0 *default-log-port* "ERROR: not able to setup up for megatest.") - (let* ((mtdb (dbr:dbstruct-mtdb dbstruct)) - (tmpdb (db:get-db dbstruct)) - (refndb (dbr:dbstruct-refndb dbstruct)) - (allow-cleanup #t) ;; (if run-ids #f #t)) - (servers (server:get-list *toppath*)) ;; (tasks:get-all-servers (db:delay-if-busy tdbdat))) - (data-synced 0)) ;; count of changed records (I hope) - - (for-each - (lambda (option) - - (case option - ;; kill servers - ((killservers) - (for-each - (lambda (server) - (match-let (((mod-time host port start-time pid) server)) - (if (and host pid) - (tasks:kill-server host pid)))) - servers) - - ;; /tmp/bjbarcla/megatest_localdb/fullrun/.nfs.pdx.disks.icf_env_disk001.bjbarcla.gwa.issues.mtdev.matt-bisect.megatest.ext-tests.runs.all.v1.65.1.6524.dev.bb-24-justrollup-f8.rollup.fullrun/megatest.db.lock - (delete-file* (common:get-sync-lock-filepath)) - ) - - ;; clear out junk records - ;; - ((dejunk) - ;; (db:delay-if-busy mtdb) ;; ok to delay on mtdb - (when (file-write-access? (db:dbdat-get-path mtdb)) (db:clean-up mtdb)) - (db:clean-up tmpdb) - (db:clean-up refndb)) - - ;; sync runs, test_meta etc. - ;; - ((old2new) - (set! data-synced - (+ (db:sync-tables (db:sync-all-tables-list dbstruct) #f mtdb tmpdb refndb) - data-synced))) - - ;; now ensure all newdb data are synced to megatest.db - ;; do not use the run-ids list passed in to the function - ;; - ((new2old) - (set! data-synced - (+ (db:sync-tables (db:sync-all-tables-list dbstruct) #f tmpdb refndb mtdb) - data-synced))) - - ((adj-target) - (db:adj-target (db:dbdat-get-db mtdb)) - (db:adj-target (db:dbdat-get-db tmpdb)) - (db:adj-target (db:dbdat-get-db refndb))) - - ((schema) - (db:patch-schema-maindb (db:dbdat-get-db mtdb)) - (db:patch-schema-maindb (db:dbdat-get-db tmpdb)) - (db:patch-schema-maindb (db:dbdat-get-db refndb)) - (db:patch-schema-rundb (db:dbdat-get-db mtdb)) - (db:patch-schema-rundb (db:dbdat-get-db tmpdb)) - (db:patch-schema-rundb (db:dbdat-get-db refndb)))) - - (stack-push! (dbr:dbstruct-dbstack dbstruct) tmpdb)) - options) + (let* (;; (dbdat (db:open-db dbstruct #f dbfile:db-init-proc)) + (data-synced 0) ;; count of changed records + (tmp-area (common:make-tmpdir-name *toppath* "")) + (old2new (member 'old2new options)) + (dejunk (member 'dejunk options)) + (killservers (member 'killservers options)) + (src-area (if old2new *toppath* tmp-area)) + (dest-area (if old2new tmp-area (conc *toppath* "/.mtdb"))) + (dbfiles (if old2new (glob (conc *toppath* "/.mtdb/*.db")) + (glob (conc tmp-area "/*.db")))) + (keys (db:get-keys dbstruct)) + (sync-durations (make-hash-table))) + + ;; kill servers + ;; (if killservers (db:kill-servers)) + + (if (not dbfiles) + (debug:print-error 0 *default-log-port* "no dbfiles found in " (conc *toppath* "/.mtdb")) + (for-each + (lambda (srcfile) + (debug:print-info 3 *default-log-port* "file: " srcfile) + (let* ((fname (conc (pathname-file srcfile) ".db")) + (basename (pathname-file srcfile)) + (run-id (if (string= basename "main") #f (string->number basename))) + (destfile (conc dest-area "/" fname)) + (dest-directory dest-area) + (time1 (file-modification-time srcfile)) + (time2 (if (file-exists? destfile) + (begin + (debug:print-info 2 *default-log-port* "destfile " destfile " exists") + (file-modification-time destfile)) + (begin + (debug:print-info 0 *default-log-port* "Sync - I do not see file " destfile) + 0))) + (changed ( < (- time2 time1) 6.0)) ;; dest db not updated within last 6 seconds + + (do-cp (cond + ((not (file-exists? destfile)) ;; shouldn't happen, but this might recover + (debug:print-info 2 *default-log-port* "File " destfile " not found. Copying "srcfile" to "destfile) + ;; TODO: Need to fix this for WAL mod. Can't just copy. + (system (conc "/bin/mkdir -p " dest-directory)) + (system (conc "/bin/cp " srcfile " " destfile)) + #t) + (changed ;; (and changed + #t) + ((and changed *time-to-exit*) ;; last sync + #t) + (else + #f)))) + + (if (or dejunk do-cp) + (let* ((start-time (current-milliseconds)) + (subdb (or (dbfile:get-subdb dbstruct run-id) (dbfile:init-subdb dbstruct run-id dbfile:db-init-proc))) + (dbdat (or (dbfile:get-dbdat dbstruct run-id) (dbfile:open-db dbstruct run-id dbfile:db-init-proc))) + (mtdb (dbr:subdb-mtdbdat subdb)) + ;; + ;; BUG: -mrw- I think this next line is wrong. run-id should be the path to .mtdb/.db + ;; + (tmpdb (dbfile:open-db dbstruct run-id dbfile:db-init-proc))) + + (if dejunk + (begin + (debug:print 0 *default-log-port* "Cleaning tmp DB") + (db:clean-up run-id tmpdb) + (debug:print 0 *default-log-port* "Cleaning nfs DB") + (db:clean-up run-id mtdb) + ) + ) + (debug:print-info 2 *default-log-port* "delta syncing file: " srcfile ", time diff: " (- time1 time2) " seconds") + (if old2new + (begin + (db:sync-tables (db:sync-all-tables-list + (db:get-keys dbstruct)) + #f mtdb tmpdb)) + (begin + (db:sync-tables (db:sync-all-tables-list (db:get-keys dbstruct)) #f tmpdb mtdb))) + (hash-table-set! sync-durations (conc srcfile ".db") (- (current-milliseconds) start-time))) + (debug:print-info 2 *default-log-port* "skipping delta sync. " srcfile " is up to date")))) + dbfiles)) data-synced)) -(define (db:tmp->megatest.db-sync dbstruct last-update) - (let* ((mtdb (dbr:dbstruct-mtdb dbstruct)) - (tmpdb (db:get-db dbstruct)) - (refndb (dbr:dbstruct-refndb dbstruct)) - (res (db:sync-tables (db:sync-all-tables-list dbstruct) last-update tmpdb refndb mtdb))) - (stack-push! (dbr:dbstruct-dbstack dbstruct) tmpdb) +;; Sync all changed db's +;; +(define (db:tmp->megatest.db-sync dbstruct run-id last-update) + (let* ((subdbs (hash-table-values (dbr:dbstruct-subdbs dbstruct))) + (res '())) + (for-each + (lambda (subdb) + (let* ((mtdb (dbr:subdb-mtdb subdb)) + (tmpdb (db:get-subdb dbstruct run-id)) + (refndb (dbr:subdb-refndb subdb)) + (newres (db:sync-tables (db:sync-all-tables-list (db:get-keys dbstruct)) last-update tmpdb refndb mtdb))) + ;; (stack-push! (dbr:subdb-dbstack subdb) tmpdb) + ;; BUG: verify this is really needed + (dbfile:add-dbdat dbstruct run-id tmpdb) + (set! res (cons newres res)))) + subdbs) res)) ;;;; run-ids ;; if #f use *db-local-sync* : or 'local-sync-flags ;; if #t use timestamps : or 'timestamps @@ -1173,159 +721,27 @@ (if sync-needed (debug:print-info 0 *default-log-port* "Sync of " res " records from newdb to olddb completed in " sync-time " seconds pid="(current-process-id)) (debug:print-info 0 *default-log-port* "No sync needed, last updated " (- start-time last-update) " seconds ago"))) res)) -;; keeping it around for debugging purposes only -#;(define (open-run-close-no-exception-handling proc idb . params) - (debug:print-info 11 *default-log-port* "open-run-close-no-exception-handling START given a db=" (if idb "yes " "no ") ", params=" params) - (print "I don't work anymore. open-run-close-no-exception-handling needs fixing or removing...") - (exit) - (if (or *db-write-access* - (not #t)) ;; was: (member proc * db:all-write-procs *))) - (let* ((db (cond - ((pair? idb) (db:dbdat-get-db idb)) - ((sqlite3:database? idb) idb) - ((not idb) (debug:print-error 0 *default-log-port* "cannot open-run-close with #f anymore")) - ((procedure? idb) (idb)) - (else (debug:print-error 0 *default-log-port* "cannot open-run-close with #f anymore")))) - (res #f)) - (set! res (apply proc db params)) - (if (not idb)(sqlite3:finalize! dbstruct)) - (debug:print-info 11 *default-log-port* "open-run-close-no-exception-handling END" ) - res) - #f)) - -#;(define (open-run-close-exception-handling proc idb . params) - (handle-exceptions - exn - (let ((sleep-time (random 30)) - (err-status ((condition-property-accessor 'sqlite3 'status #f) exn))) - (case err-status - ((busy) - (thread-sleep! sleep-time)) - (else - (debug:print 0 *default-log-port* "EXCEPTION: database probably overloaded or unreadable.") - (debug:print 0 *default-log-port* " message: " ((condition-property-accessor 'exn 'message) exn)) - (debug:print 5 *default-log-port* "exn=" (condition->list exn)) - (debug:print 0 *default-log-port* " status: " ((condition-property-accessor 'sqlite3 'status) exn)) - (print-call-chain (current-error-port)) - (thread-sleep! sleep-time) - (debug:print-info 0 *default-log-port* "trying db call one more time....this may never recover, if necessary kill process " (current-process-id) " on host " (get-host-name) " to clean up"))) - (apply open-run-close-exception-handling proc idb params)) - (apply open-run-close-no-exception-handling proc idb params))) - -;; (define open-run-close -#;(define open-run-close open-run-close-exception-handling) - ;; open-run-close-no-exception-handling -;; open-run-close-exception-handling) -;;) - -(define db:trigger-list - (list (list "update_runs_trigger" "CREATE TRIGGER IF NOT EXISTS update_runs_trigger AFTER UPDATE ON runs - FOR EACH ROW - BEGIN - UPDATE runs SET last_update=(strftime('%s','now')) - WHERE id=old.id; - END;" ) - (list "update_run_stats_trigger" "CREATE TRIGGER IF NOT EXISTS update_run_stats_trigger AFTER UPDATE ON run_stats - FOR EACH ROW - BEGIN - UPDATE run_stats SET last_update=(strftime('%s','now')) - WHERE id=old.id; - END;" ) - (list "update_tests_trigger" "CREATE TRIGGER IF NOT EXISTS update_tests_trigger AFTER UPDATE ON tests - FOR EACH ROW - BEGIN - UPDATE tests SET last_update=(strftime('%s','now')) - WHERE id=old.id; - END;" ) - (list "update_teststeps_trigger" "CREATE TRIGGER IF NOT EXISTS update_teststeps_trigger AFTER UPDATE ON test_steps - FOR EACH ROW - BEGIN - UPDATE test_steps SET last_update=(strftime('%s','now')) - WHERE id=old.id; - END;" ) - (list "update_test_data_trigger" "CREATE TRIGGER IF NOT EXISTS update_test_data_trigger AFTER UPDATE ON test_data - FOR EACH ROW - BEGIN - UPDATE test_data SET last_update=(strftime('%s','now')) - WHERE id=old.id; - END;" ))) - -(define (db:create-all-triggers dbstruct) -(db:with-db - dbstruct #f #f - (lambda (db) -(db:create-triggers db)))) - -(define (db:create-triggers db) - (for-each (lambda (key) - (sqlite3:execute db (cadr key))) - db:trigger-list)) - -(define (db:drop-all-triggers dbstruct) - (db:with-db - dbstruct #f #f - (lambda (db) - (db:drop-triggers db)))) - -(define (db:is-trigger-dropped db tbl-name) - (let* ((trigger-name (if (equal? tbl-name "test_steps") - "update_teststeps_trigger" - (conc "update_" tbl-name "_trigger"))) - (res #f)) - (sqlite3:for-each-row - (lambda (name) - (if (equal? name trigger-name) - (set! res #t))) - db - "SELECT name FROM sqlite_master WHERE type = 'trigger' ;" - ))) - -(define (db:drop-triggers db) - (for-each - (lambda (key) - (sqlite3:execute db (conc "drop trigger if exists " (car key)))) - db:trigger-list)) - -(define (db:drop-trigger db tbl-name) - (let* ((trigger-name (if (equal? tbl-name "test_steps") - "update_teststeps_trigger" - (conc "update_" tbl-name "_trigger")))) - (for-each - (lambda (key) - (if (equal? (car key) trigger-name) - (sqlite3:execute db (conc "drop trigger if exists " trigger-name)))) - db:trigger-list))) - -(define (db:create-trigger db tbl-name) - (let* ((trigger-name (if (equal? tbl-name "test_steps") - "update_teststeps_trigger" - (conc "update_" tbl-name "_trigger")))) - (for-each (lambda (key) - (if (equal? (car key) trigger-name) - (sqlite3:execute db (cadr key)))) - db:trigger-list))) - - -(define (db:initialize-main-db dbdat) + +(define (db:initialize-main-db db) (when (not *configinfo*) (launch:setup)) ;; added because Elena was getting stack dump because *configinfo* below was #f. (let* ((configdat (car *configinfo*)) ;; tut tut, global warning... (keys (keys:config-get-fields configdat)) (havekeys (> (length keys) 0)) (keystr (keys->keystr keys)) (fieldstr (keys:make-key/field-string configdat)) - (db (db:dbdat-get-db dbdat))) + #;(db (dbr:dbdat-dbh dbdat))) (for-each (lambda (key) (let ((keyn key)) (if (member (string-downcase keyn) (list "runname" "state" "status" "owner" "event_time" "comment" "fail_count" "pass_count" "contour")) (begin - (print "ERROR: your key cannot be named " keyn " as this conflicts with the same named field in the runs table, you must remove your megatest.db and /.db before trying again.") + (debug:print 0 *default-log-port* "ERROR: your key cannot be named " keyn " as this conflicts with the same named field in the runs table, you must remove your megatest.db and /.db before trying again.") (exit 1))))) keys) (sqlite3:with-transaction db (lambda () @@ -1333,13 +749,23 @@ ;; exn ;; (begin ;; (debug:print 0 "ERROR: Failed to create tables. Look at your [fields] section, should be: fieldname TEXT DEFAULT 'yourdefault'") ;; (exit)) (sqlite3:execute db "CREATE TABLE IF NOT EXISTS keys (id INTEGER PRIMARY KEY, fieldname TEXT, fieldtype TEXT, CONSTRAINT keyconstraint UNIQUE (fieldname));") - (for-each (lambda (key) - (sqlite3:execute db "INSERT OR REPLACE INTO keys (fieldname,fieldtype) VALUES (?,?);" key "TEXT")) - keys) + (for-each + (lambda (key) + (let* ((fieldname #f) + (fieldtype #f)) + (sqlite3:for-each-row + (lambda (fn ft) + (set! fieldname fn) + (set! fieldtype ft)) + db + "SELECT fieldname,fieldtype FROM keys WHERE fieldname=?" key) + (if (not fieldname) + (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', contour TEXT DEFAULT '', @@ -1430,11 +856,21 @@ (sqlite3:execute db "CREATE TABLE IF NOT EXISTS metadat (id INTEGER PRIMARY KEY, var TEXT, val TEXT, CONSTRAINT metadat_constraint UNIQUE (var));") (sqlite3:execute db "CREATE TABLE IF NOT EXISTS access_log (id INTEGER PRIMARY KEY, user TEXT, accessed TIMESTAMP, args TEXT);") ;; Must do this *after* running patch db !! No more. ;; cannot use db:set-var since it will deadlock, hardwire the code here - (sqlite3:execute db "INSERT OR REPLACE INTO metadat (var,val) VALUES (?,?);" "MEGATEST_VERSION" (common:version-signature)) + (let* ((prev-version #f) + (curr-version (common:version-signature))) + (sqlite3:for-each-row + (lambda (ver) + (set! prev-version ver)) + db + "SELECT val FROM metadat WHERE var='MEGATEST_VERSION';") + (if prev-version + (if (not (equal? prev-version curr-version)) + (sqlite3:execute db "UPDATE metadat SET val=? WHERE var=?;" curr-version "MEGATEST_VERSION")) + (sqlite3:execute db "INSERT OR REPLACE INTO metadat (var,val) VALUES (?,?);" "MEGATEST_VERSION" curr-version) )) (debug:print-info 11 *default-log-port* "db:initialize END") ;; )))) ;;====================================================================== ;; R U N S P E C I F I C D B ;;====================================================================== @@ -1489,11 +925,11 @@ event_time TIMESTAMP, comment TEXT DEFAULT '', logfile TEXT DEFAULT '', last_update INTEGER DEFAULT (strftime('%s','now')), CONSTRAINT test_steps_constraint UNIQUE (test_id,stepname,state));") - (sqlite3:execute db "CREATE INDEX IF NOT EXISTS teststeps_index ON tests (run_id, testname, item_path);") + (sqlite3:execute db "CREATE INDEX IF NOT EXISTS teststeps_index ON test_steps (test_id, stepname, state);") ;; All triggers created at once in end ;;(sqlite3:execute db "CREATE TRIGGER IF NOT EXISTS update_teststeps_trigger AFTER UPDATE ON test_steps ;; FOR EACH ROW ;; BEGIN ;; UPDATE test_steps SET last_update=(strftime('%s','now')) @@ -1525,19 +961,21 @@ test_id INTEGER, update_time TIMESTAMP, cpuload INTEGER DEFAULT -1, diskfree INTEGER DEFAULT -1, diskusage INTGER DEFAULT -1, - run_duration INTEGER DEFAULT 0);") + run_duration INTEGER DEFAULT 0, + last_update INTEGER DEFAULT (strftime('%s','now')));") (sqlite3:execute db "CREATE TABLE IF NOT EXISTS archives ( id INTEGER PRIMARY KEY, test_id INTEGER, state TEXT DEFAULT 'new', status TEXT DEFAULT 'n/a', archive_type TEXT DEFAULT 'bup', du INTEGER, - archive_path TEXT);"))) + archive_path TEXT, + last_update INTEGER DEFAULT (strftime('%s','now')));"))) (db:create-triggers db) db)) ;; ) ;;====================================================================== ;; A R C H I V E S @@ -1546,12 +984,12 @@ ;; dneeded is minimum space needed, scan for existing archives that ;; are on disks with adequate space and already have this test/itempath ;; archived ;; (define (db:archive-get-allocations dbstruct testname itempath dneeded) - (let* ((dbdat (db:get-db dbstruct)) ;; archive tables are in main.db - (db (db:dbdat-get-db dbdat)) + (let* ((dbdat (db:get-subdb dbstruct #f)) ;; archive tables are in main.db + (db (dbr:dbdat-dbh dbdat)) (res '()) (blocks '())) ;; a block is an archive chunck that can be added too if there is space (sqlite3:for-each-row (lambda (id archive-disk-id disk-path last-du last-du-time) (set! res (cons (vector id archive-disk-id disk-path last-du last-du-time) res))) @@ -1571,19 +1009,20 @@ "SELECT d.id,d.archive_area_name,disk_path,last_df,last_df_time FROM archive_disks AS d INNER JOIN archive_blocks AS b ON d.id=b.archive_disk_id WHERE b.id IN (" (string-intersperse (map conc res) ",") ") AND last_df > ?;") dneeded)) - (stack-push! (dbr:dbstruct-dbstack dbstruct) dbdat) + ;; BUG: Verfify this is really needed + (dbfile:add-dbdat dbstruct #f dbdat) blocks)) ;; returns id of the record, register a disk allocated to archiving and record it's last known ;; available space ;; (define (db:archive-register-disk dbstruct bdisk-name bdisk-path df) - (let* ((dbdat (db:get-db dbstruct)) ;; archive tables are in main.db - (db (db:dbdat-get-db dbdat)) + (let* ((dbdat (db:get-subdb dbstruct #f)) ;; archive tables are in main.db + (db (dbr:dbdat-dbh dbdat)) (res #f)) (sqlite3:for-each-row (lambda (id) (set! res id)) db @@ -1592,28 +1031,28 @@ (if res ;; record exists, update df and return id (begin (sqlite3:execute db "UPDATE archive_disks SET last_df=?,last_df_time=(strftime('%s','now')) WHERE archive_area_name=? AND disk_path=?;" df bdisk-name bdisk-path) - (stack-push! (dbr:dbstruct-dbstack dbstruct) dbdat) + (dbfile:add-dbdat dbstruct #f dbdat) res) (begin (sqlite3:execute db "INSERT OR REPLACE INTO archive_disks (archive_area_name,disk_path,last_df) VALUES (?,?,?);" bdisk-name bdisk-path df) - (stack-push! (dbr:dbstruct-dbstack dbstruct) dbdat) + (dbfile:add-dbdat dbstruct #f dbdat) (db:archive-register-disk dbstruct bdisk-name bdisk-path df))))) ;; record an archive path created on a given archive disk (identified by it's bdisk-id) ;; if path starts with / then it is full, otherwise it is relative to the archive disk ;; preference is to store the relative path. ;; (define (db:archive-register-block-name dbstruct bdisk-id archive-path #!key (du #f)) - (let* ((dbdat (db:get-db dbstruct)) ;; archive tables are in main.db - (db (db:dbdat-get-db dbdat)) + (let* ((dbdat (db:get-subdb dbstruct #f)) ;; archive tables are in main.db + (db (dbr:dbdat-dbh dbdat)) (res #f)) ;; first look to see if this path is already registered (sqlite3:for-each-row (lambda (id) (set! res id)) @@ -1627,22 +1066,22 @@ (begin (sqlite3:execute db "INSERT OR REPLACE INTO archive_blocks (archive_disk_id,disk_path,last_du) VALUES (?,?,?);" bdisk-id archive-path (or du 0)) (set! res (db:archive-register-block-name dbstruct bdisk-id archive-path du: du)))) - (stack-push! (dbr:dbstruct-dbstack dbstruct) dbdat) + (dbfile:add-dbdat dbstruct #f dbdat) res)) ;; The "archived" field in tests is overloaded; 0 = not archived, > 0 archived in block with given id ;; (define (db:test-set-archive-block-id dbstruct run-id test-id archive-block-id) (db:with-db dbstruct run-id - #f - (lambda (db) + #t + (lambda (dbdat db) (sqlite3:execute db "UPDATE tests SET archived=? WHERE id=?;" archive-block-id test-id)))) ;; Look up the archive block info given a block-id ;; @@ -1649,11 +1088,11 @@ (define (db:test-get-archive-block-info dbstruct archive-block-id) (db:with-db dbstruct #f #f - (lambda (db) + (lambda (dbdat db) (let ((res #f)) (sqlite3:for-each-row ;; 0 1 2 3 4 5 (lambda (id archive-disk-id disk-path last-du last-du-time creation-time) (set! res (vector id archive-disk-id disk-path last-du last-du-time creation-time))) @@ -1661,297 +1100,108 @@ "SELECT id,archive_disk_id,disk_path,last_du,last_du_time,creation_time FROM archive_blocks WHERE id=?;" archive-block-id) res)))) ;; (define (db:archive-allocate-testsuite/area-to-block block-id testsuite-name areakey) -;; (let* ((dbdat (db:get-db dbstruct #f)) ;; archive tables are in main.db -;; (db (db:dbdat-get-db dbdat)) +;; (let* ((dbdat (db:get-subdb dbstruct #f)) ;; archive tables are in main.db +;; (db (dbr:dbdat-dbh dbdat)) ;; (res '()) ;; (blocks '())) ;; a block is an archive chunck that can be added too if there is space ;; (sqlite3:for-each-row #f) -;;====================================================================== -;; L O G G I N G D B -;;====================================================================== - -(define (open-logging-db) - (let* ((dbpath (conc (if *toppath* (conc *toppath* "/") "") "logging.db")) ;; fname) - (dbexists (common:file-exists? dbpath)) - (db (sqlite3:open-database dbpath)) - (handler (sqlite3:make-busy-timeout (if (args:get-arg "-override-timeout") - (string->number (args:get-arg "-override-timeout")) - 136000)))) ;; 136000))) - (sqlite3:set-busy-handler! db handler) - (if (not dbexists) - (begin - (sqlite3:execute db "CREATE TABLE IF NOT EXISTS log (id INTEGER PRIMARY KEY,event_time TIMESTAMP DEFAULT (strftime('%s','now')),logline TEXT,pwd TEXT,cmdline TEXT,pid INTEGER);") - (db:set-sync db) ;; (sqlite3:execute db (conc "PRAGMA synchronous = 0;")) - )) - db)) - -(define (db:log-local-event . loglst) - (let ((logline (apply conc loglst))) - (db:log-event logline))) - -(define (db:log-event logline) - (let ((db (open-logging-db))) - (sqlite3:execute db "INSERT INTO log (logline,pwd,cmdline,pid) VALUES (?,?,?,?);" - logline - (current-directory) - (string-intersperse (argv) " ") - (current-process-id)) - (sqlite3:finalize! db) - logline)) - ;;====================================================================== ;; D B U T I L S ;;====================================================================== ;;====================================================================== ;; M A I N T E N A N C E ;;====================================================================== -(define (db:have-incompletes? dbstruct run-id ovr-deadtime) - (let* ((incompleted '()) - (oldlaunched '()) - (toplevels '()) - (deadtime-str (configf:lookup *configdat* "setup" "deadtime")) - (deadtime (if (and deadtime-str - (string->number deadtime-str)) - (string->number deadtime-str) - 72000))) ;; twenty hours - (db:with-db - dbstruct #f #f - (lambda (db) - (if (number? ovr-deadtime)(set! deadtime ovr-deadtime)) - - ;; in RUNNING or REMOTEHOSTSTART for more than 10 minutes - ;; - ;; HOWEVER: this code in run:test seems to work fine - ;; (> (- (current-seconds)(+ (db:test-get-event_time testdat) - ;; (db:test-get-run_duration testdat))) - ;; 600) - ;; (db:delay-if-busy dbdat) - (sqlite3:for-each-row - (lambda (test-id run-dir uname testname item-path) - (if (and (equal? uname "n/a") - (equal? item-path "")) ;; this is a toplevel test - ;; what to do with toplevel? call rollup? - (begin - (set! toplevels (cons (list test-id run-dir uname testname item-path run-id) toplevels)) - (debug:print-info 0 *default-log-port* "Found old toplevel test in RUNNING state, test-id=" test-id)) - (set! incompleted (cons (list test-id run-dir uname testname item-path run-id) incompleted)))) - db - "SELECT id,rundir,uname,testname,item_path FROM tests WHERE run_id=? AND (strftime('%s','now') - event_time) > (run_duration + ?) AND state IN ('RUNNING','REMOTEHOSTSTART');" - run-id deadtime) - - ;; in LAUNCHED for more than one day. Could be long due to job queues TODO/BUG: Need override for this in config - ;; - ;; (db:delay-if-busy dbdat) - (sqlite3:for-each-row - (lambda (test-id run-dir uname testname item-path) - (if (and (equal? uname "n/a") - (equal? item-path "")) ;; this is a toplevel test - ;; what to do with toplevel? call rollup? - (set! toplevels (cons (list test-id run-dir uname testname item-path run-id) toplevels)) - (set! oldlaunched (cons (list test-id run-dir uname testname item-path run-id) oldlaunched)))) - db - "SELECT id,rundir,uname,testname,item_path FROM tests WHERE run_id=? AND (strftime('%s','now') - event_time) > 86400 AND state IN ('LAUNCHED');" - run-id) - - (debug:print-info 18 *default-log-port* "Found " (length oldlaunched) " old LAUNCHED items, " (length toplevels) " old LAUNCHED toplevel tests and " (length incompleted) " tests marked RUNNING but apparently dead.") - (if (and (null? incompleted) - (null? oldlaunched) - (null? toplevels)) - #f - #t))))) - -(define (db:get-status-from-final-status-file run-dir) - (let ((infile (conc run-dir "/.final-status"))) - ;; first verify we are able to write the output file - (if (not (file-read-access? infile)) - (begin - (debug:print 0 *default-log-port* "ERROR: cannot read " infile) - (debug:print 0 *default-log-port* "ERROR: run-dir is " run-dir) - #f - ) - (with-input-from-file infile read-lines) - ))) - -;; check duration against test-run.dat file if it exists and update the value in -;; the db if necessary -;; -(define (db:adjust-run-duration dbstruct test-id run-dir event-time run-duration) - (let* ((datf (conc run-dir ".mt_data/test-run.dat")) - (modt (if (and (file-exists? datf) - (file-read-access? datf)) - (file-modification-time datf) - #f)) ;; (+ event-time run-duration)))) - (alt-run-duration (if modt - (- modt event-time) - #f))) - (if (and alt-run-duration - (> alt-run-duration run-duration)) - (begin - (debug:print 0 *default-log-port* "Test " test-id " run duration mismatch. Setting to " alt-run-duration) - (db:with-db - dbstruct #f #f - (lambda (db) - (sqlite3:execute db "UPDATE tests SET run_duration=? WHERE id=?;" alt-run-duration test-id) - #t))) - #f))) ;; #f = we did NOT adjust the time - -;; select end_time-now from -;; (select testname,item_path,event_time+run_duration as -;; end_time,strftime('%s','now') as now from tests where state in -;; ('RUNNING','REMOTEHOSTSTART','LAUNCHED')); - -(define (db:find-and-mark-incomplete dbstruct run-id ovr-deadtime) - (let* ((incompleted '()) - (oldlaunched '()) - (toplevels '()) - ;; The default running-deadtime is 720 seconds = 12 minutes. - ;; "(running-deadtime-default (+ server-start-allowance (* 2 launch-monitor-period)))" = 200 + (2 * (200 + 30 + 30)) - (deadtime-trim (or ovr-deadtime (configf:lookup-number *configdat* "setup" "deadtime"))) - (server-start-allowance 200) - (server-overloaded-budget 200) - (launch-monitor-off-time (or (configf:lookup-number *configdat* "setup" "test-stats-update-period") 30)) - (launch-monitor-on-time-budget 30) - (launch-monitor-period (+ launch-monitor-off-time launch-monitor-on-time-budget server-overloaded-budget)) - (remotehoststart-deadtime-default (+ server-start-allowance server-overloaded-budget 30)) - (remotehoststart-deadtime (or deadtime-trim remotehoststart-deadtime-default)) - (running-deadtime-default (+ server-start-allowance (* 2 launch-monitor-period))) - (running-deadtime (or deadtime-trim running-deadtime-default)) ;; two minutes (30 seconds between updates, this leaves 3x grace period) - ) - (debug:print-info 4 *default-log-port* "running-deadtime = " running-deadtime) - (debug:print-info 4 *default-log-port* "deadtime-trim = " deadtime-trim) - - (db:with-db - dbstruct #f #f - (lambda (db) - (let* ((stmth1 (db:get-cache-stmth - dbstruct db - "SELECT id,rundir,uname,testname,item_path,event_time,run_duration FROM tests - WHERE run_id=? AND (strftime('%s','now') - event_time) > (run_duration + ?) - AND state IN ('RUNNING');")) - (stmth2 (db:get-cache-stmth - dbstruct db - "SELECT id,rundir,uname,testname,item_path,event_time,run_duration FROM tests - WHERE run_id=? AND (strftime('%s','now') - event_time) > (run_duration + ?) - AND state IN ('REMOTEHOSTSTART');")) - (stmth3 (db:get-cache-stmth - dbstruct db - "SELECT id,rundir,uname,testname,item_path FROM tests - WHERE run_id=? AND (strftime('%s','now') - event_time) > 86400 - AND state IN ('LAUNCHED');"))) - ;; in RUNNING or REMOTEHOSTSTART for more than 10 minutes - ;; - ;; HOWEVER: this code in run:test seems to work fine - ;; (> (- (current-seconds)(+ (db:test-get-event_time testdat) - ;; (db:test-get-run_duration testdat))) - ;; 600) - ;; (db:delay-if-busy dbdat) - (sqlite3:for-each-row - (lambda (test-id run-dir uname testname item-path event-time run-duration) - (if (not (db:adjust-run-duration dbstruct test-id run-dir event-time run-duration)) - (if (and (equal? uname "n/a") - (equal? item-path "")) ;; this is a toplevel test - ;; what to do with toplevel? call rollup? - (begin - (set! toplevels (cons (list test-id run-dir uname testname item-path run-id) toplevels)) - (debug:print-info 0 *default-log-port* "Found old toplevel test in RUNNING state, test-id=" test-id)) - (begin - (set! incompleted (cons (list test-id run-dir uname testname item-path run-id) incompleted)) - (debug:print-info 0 *default-log-port* "Found old test in RUNNING state, test-id=" - test-id" exceeded running-deadtime "running-deadtime" now="(current-seconds) - " event-time="event-time" run-duration="run-duration))))) - stmth1 - run-id running-deadtime) ;; default time 720 seconds - - (sqlite3:for-each-row - (lambda (test-id run-dir uname testname item-path event-time run-duration) - (if (not (db:adjust-run-duration dbstruct test-id run-dir event-time run-duration)) - (if (and (equal? uname "n/a") - (equal? item-path "")) ;; this is a toplevel test - ;; what to do with toplevel? call rollup? - (begin - (set! toplevels (cons (list test-id run-dir uname testname item-path run-id) toplevels)) - (debug:print-info 0 *default-log-port* "Found old toplevel test in RUNNING state, test-id=" test-id)) - (begin - (debug:print-info 0 *default-log-port* "Found old test in REMOTEHOSTSTART state, test-id=" test-id - " exceeded running-deadtime "running-deadtime" now="(current-seconds)" event-time="event-time - " run-duration="run-duration) - (set! incompleted (cons (list test-id run-dir uname testname item-path run-id) incompleted)))))) - stmth2 - run-id remotehoststart-deadtime) ;; default time 230 seconds - - ;; in LAUNCHED for more than one day. Could be long due to job queues TODO/BUG: Need override for this in config - ;; - ;; (db:delay-if-busy dbdat) - (sqlite3:for-each-row - (lambda (test-id run-dir uname testname item-path) - (if (and (equal? uname "n/a") - (equal? item-path "")) ;; this is a toplevel test - ;; what to do with toplevel? call rollup? - (set! toplevels (cons (list test-id run-dir uname testname item-path run-id) toplevels)) - (begin - (debug:print-info 0 *default-log-port* "Found old test in LAUNCHED state, test-id=" test-id - " 1 day since event_time marked") - (set! oldlaunched (cons (list test-id run-dir uname testname item-path run-id) oldlaunched))))) - stmth3 - run-id) - - (debug:print-info 18 *default-log-port* "Found " (length oldlaunched) " old LAUNCHED items, " - (length toplevels) " old LAUNCHED toplevel tests and " - (length incompleted) " tests marked RUNNING but apparently dead.")) - - ;; These are defunct tests, do not do all the overhead of set-state-status. Force them to INCOMPLETE. - ;; - ;; (db:delay-if-busy dbdat) - (let* ((min-incompleted-ids (map car incompleted)) ;; do 'em all - (all-ids (append min-incompleted-ids (map car oldlaunched)))) - (if (> (length all-ids) 0) - (begin - ;; (launch:is-test-alive "localhost" 435) - (debug:print 0 *default-log-port* "WARNING: Marking test(s); " (string-intersperse (map conc all-ids) ", ") - " as DEAD") - (for-each - (lambda (test-id) - (let* (;; (run-dir (db:test-get-rundir-from-test-id dbstruct run-id test-id)) - (tinfo (db:get-test-info-by-id dbstruct run-id test-id)) - (run-dir (db:test-get-rundir tinfo)) - (host (db:test-get-host tinfo)) - (pid (db:test-get-process_id tinfo)) - (result (db:get-status-from-final-status-file run-dir))) - (if (and (list? result) (> (length result) 1) (equal? "PASS" (cadr result)) (equal? "COMPLETED" (car result))) - (begin - (debug:print 0 *default-log-port* "INFO: test " test-id " actually passed, so marking PASS not DEAD") - (db:set-state-status-and-roll-up-items - dbstruct run-id test-id 'foo "COMPLETED" "PASS" - "Test stopped responding but it has PASSED; marking it PASS in the DB.")) - (let ((is-alive (and (not (eq? pid 0)) ;; 0 is default in re-used field "attemptnum" where pid stored. - (launch:is-test-alive host pid)))) - (if is-alive - (debug:print 0 *default-log-port* "INFO: test " test-id " on host " host - " has a process on pid " pid ", NOT setting to DEAD.") - (begin - (debug:print 0 *default-log-port* "INFO: test " test-id - " final state/status is not COMPLETED/PASS. It is " result) - (db:set-state-status-and-roll-up-items - dbstruct run-id test-id 'foo "COMPLETED" "DEAD" - "Test stopped responding while in RUNNING or REMOTEHOSTSTART; presumed dead."))))))) - ;; call end of eud of run detection for posthook - from merge, is it needed? - ;; (launch:end-of-run-check run-id) - all-ids) - ;;call end of eud of run detection for posthook - (launch:end-of-run-check run-id) - ))))))) +;; (define (db:have-incompletes? dbstruct run-id ovr-deadtime) +;; (let* ((incompleted '()) +;; (oldlaunched '()) +;; (toplevels '()) +;; (deadtime-str (configf:lookup *configdat* "setup" "deadtime")) +;; (deadtime (if (and deadtime-str +;; (string->number deadtime-str)) +;; (string->number deadtime-str) +;; 72000))) ;; twenty hours +;; (db:with-db +;; dbstruct run-id #f +;; (lambda (dbdat db) +;; (if (number? ovr-deadtime)(set! deadtime ovr-deadtime)) +;; +;; ;; in RUNNING or REMOTEHOSTSTART for more than 10 minutes +;; ;; +;; ;; HOWEVER: this code in run:test seems to work fine +;; ;; (> (- (current-seconds)(+ (db:test-get-event_time testdat) +;; ;; (db:test-get-run_duration testdat))) +;; ;; 600) +;; ;; (db:delay-if-busy dbdat) +;; (sqlite3:for-each-row +;; (lambda (test-id run-dir uname testname item-path) +;; (if (and (equal? uname "n/a") +;; (equal? item-path "")) ;; this is a toplevel test +;; ;; what to do with toplevel? call rollup? +;; (begin +;; (set! toplevels (cons (list test-id run-dir uname testname item-path run-id) toplevels)) +;; (debug:print-info 0 *default-log-port* "Found old toplevel test in RUNNING state, test-id=" test-id)) +;; (set! incompleted (cons (list test-id run-dir uname testname item-path run-id) incompleted)))) +;; (db:get-cache-stmth dbdat db +;; "SELECT id,rundir,uname,testname,item_path FROM tests WHERE run_id=? AND (strftime('%s','now') - event_time) > (run_duration + ?) AND state IN ('RUNNING','REMOTEHOSTSTART');") +;; run-id deadtime) +;; +;; ;; in LAUNCHED for more than one day. Could be long due to job queues TODO/BUG: Need override for this in config +;; ;; +;; ;; (db:delay-if-busy dbdat) +;; (sqlite3:for-each-row +;; (lambda (test-id run-dir uname testname item-path) +;; (if (and (equal? uname "n/a") +;; (equal? item-path "")) ;; this is a toplevel test +;; ;; what to do with toplevel? call rollup? +;; (set! toplevels (cons (list test-id run-dir uname testname item-path run-id) toplevels)) +;; (set! oldlaunched (cons (list test-id run-dir uname testname item-path run-id) oldlaunched)))) +;; (db:get-cache-stmth dbdat db +;; "SELECT id,rundir,uname,testname,item_path FROM tests WHERE run_id=? AND (strftime('%s','now') - event_time) > 86400 AND state IN ('LAUNCHED');") +;; run-id) +;; +;; (debug:print-info 18 *default-log-port* "Found " (length oldlaunched) " old LAUNCHED items, " (length toplevels) " old LAUNCHED toplevel tests and " (length incompleted) " tests marked RUNNING but apparently dead.") +;; (if (and (null? incompleted) +;; (null? oldlaunched) +;; (null? toplevels)) +;; #f +;; #t))))) ;; BUG: Probably broken - does not explicitly use run-id in the query ;; (define (db:top-test-set-per-pf-counts dbstruct run-id test-name) - (db:general-call dbstruct 'top-test-set-per-pf-counts (list test-name test-name test-name test-name test-name test-name test-name test-name test-name test-name test-name test-name test-name test-name test-name test-name test-name))) + (db:general-call dbstruct run-id 'top-test-set-per-pf-counts (list test-name test-name test-name test-name test-name test-name test-name test-name test-name test-name test-name test-name test-name test-name test-name test-name test-name))) + +;; Clean out old junk and vacuum the database +;; +;; Ultimately do something like this: +;; +;; 1. Look at test records either deleted or part of deleted run: +;; a. If test dir exists, set the the test to state='UNKNOWN', Set the run to 'unknown' +;; b. If test dir gone, delete the test record +;; 2. Look at run records +;; a. If have tests that are not deleted, set state='unknown' +;; b. .... +;; +(define (db:clean-up run-id dbdat) + (if run-id + (begin + (debug:print 0 *default-log-port* "Cleaning run DB " run-id) + (db:clean-up-rundb dbdat run-id) + ) + (begin + (debug:print 0 *default-log-port* "Cleaning main DB ") + (db:clean-up-maindb dbdat) + ) + ) +) + ;; Clean out old junk and vacuum the database ;; ;; Ultimately do something like this: ;; @@ -1960,94 +1210,42 @@ ;; b. If test dir gone, delete the test record ;; 2. Look at run records ;; a. If have tests that are not deleted, set state='unknown' ;; b. .... ;; -(define (db:clean-up dbdat) - ;; (debug:print 0 *default-log-port* "WARNING: db clean up not fully ported to v1.60, cleanup action will be on megatest.db") - (let* ((keep-record-age ( - (current-seconds) (common:hms-string->seconds (or (configf:lookup *configdat* "setup" "delete-record-age") "30d")))) - (db (db:dbdat-get-db dbdat)) - (count-stmt (sqlite3:prepare db "SELECT (SELECT count(id) FROM tests)+(SELECT count(id) FROM runs);")) - (statements - (map (lambda (stmt) - (sqlite3:prepare db stmt)) - (list - ;; delete all tests that belong to runs that are 'deleted' - (conc "DELETE FROM tests WHERE run_id in (SELECT id FROM runs WHERE state='deleted') and last_update < " keep-record-age ";") - ;; delete all tests that are 'DELETED' - (conc "DELETE FROM tests WHERE state='DELETED' and last_update < " keep-record-age " ;") - ;; delete all tests that have no run - (conc "DELETE FROM tests WHERE run_id NOT IN (SELECT DISTINCT id FROM runs) and last_update < " keep-record-age "; ") - ;; delete all runs that are state='deleted' - (conc "DELETE FROM runs WHERE state='deleted' and last_update < " keep-record-age ";") - ;; delete empty runs - (conc "DELETE FROM runs WHERE id NOT IN (SELECT DISTINCT r.id FROM runs AS r INNER JOIN tests AS t ON t.run_id=r.id) and last_update < " keep-record-age ";") - ;; remove orphaned test_rundat entries - (conc "DELETE FROM test_rundat where test_id NOT IN (SELECT id FROM tests);") - ;; remove orphaned test_steps entries - (conc "DELETE FROM test_steps WHERE test_id NOT IN (SELECT id FROM tests);") - ;; remove orphaned test_dat entries - (conc "DELETE FROM test_data WHERE test_id NOT IN (SELECT id FROM tests);") - - )))) - ;; (db:delay-if-busy dbdat) - ;(debug:print-info 0 *default-log-port* statements) - (sqlite3:with-transaction - db - (lambda () - (sqlite3:for-each-row (lambda (tot) - (debug:print-info 0 *default-log-port* "Records count before clean: " tot)) - count-stmt) - (map sqlite3:execute statements) - (sqlite3:for-each-row (lambda (tot) - (debug:print-info 0 *default-log-port* "Records count after clean: " tot)) - count-stmt))) - (map sqlite3:finalize! statements) - (sqlite3:finalize! count-stmt) - ;; (db:find-and-mark-incomplete db) - ;; (db:delay-if-busy dbdat) - (sqlite3:execute db "VACUUM;"))) - -;; Clean out old junk and vacuum the database -;; -;; Ultimately do something like this: -;; -;; 1. Look at test records either deleted or part of deleted run: -;; a. If test dir exists, set the the test to state='UNKNOWN', Set the run to 'unknown' -;; b. If test dir gone, delete the test record -;; 2. Look at run records -;; a. If have tests that are not deleted, set state='unknown' -;; b. .... -;; -(define (db:clean-up-rundb dbdat) - ;; (debug:print 0 *default-log-port* "WARNING: db clean up not fully ported to v1.60, cleanup action will be on megatest.db") - (let* ((db (db:dbdat-get-db dbdat)) - (count-stmt (sqlite3:prepare db "SELECT (SELECT count(id) FROM tests);")) - (statements - (map (lambda (stmt) - (sqlite3:prepare db stmt)) - (list - ;; delete all tests that belong to runs that are 'deleted' - ;; (conc "DELETE FROM tests WHERE run_id NOT IN (" (string-intersperse (map conc valid-runs) ",") ");") - ;; delete all tests that are 'DELETED' - "DELETE FROM tests WHERE state='DELETED';" - )))) - ;; (db:delay-if-busy dbdat) - (sqlite3:with-transaction - db - (lambda () - (sqlite3:for-each-row (lambda (tot) - (debug:print-info 0 *default-log-port* "Records count before clean: " tot)) - count-stmt) - (map sqlite3:execute statements) - (sqlite3:for-each-row (lambda (tot) - (debug:print-info 0 *default-log-port* "Records count after clean: " tot)) - count-stmt))) - (map sqlite3:finalize! statements) - (sqlite3:finalize! count-stmt) - ;; (db:find-and-mark-incomplete db) - ;; (db:delay-if-busy dbdat) +(define (db:clean-up-rundb dbdat run-id) + ;; (debug:print 0 *default-log-port* "WARNING: db clean up not fully ported to v1.60, cleanup action will be on megatest.db") + (let* ((db (dbr:dbdat-dbh dbdat)) + (test-count-stmt (sqlite3:prepare db "SELECT (SELECT count(id) FROM tests);")) + (step-count-stmt (sqlite3:prepare db "SELECT (SELECT count(id) FROM test_steps);")) + (statements + (map (lambda (stmt) + (sqlite3:prepare db stmt)) + (list + "DELETE FROM tests WHERE state='DELETED';" + "DELETE FROM test_steps WHERE status = 'DELETED';" + "DELETE FROM tests WHERE run_id IN (SELECT id FROM runs WHERE state = 'deleted');" + )))) + (sqlite3:with-transaction + db + (lambda () + (sqlite3:for-each-row (lambda (tot) + (debug:print-info 0 *default-log-port* "Test records count before clean: " tot)) + test-count-stmt) + (sqlite3:for-each-row (lambda (tot) + (debug:print-info 0 *default-log-port* "Test_step records count before clean: " tot)) + step-count-stmt) + (map sqlite3:execute statements) + (sqlite3:for-each-row (lambda (tot) + (debug:print-info 0 *default-log-port* "Test records count after clean: " tot)) + test-count-stmt) + (sqlite3:for-each-row (lambda (tot) + (debug:print-info 0 *default-log-port* "Test_step records count after clean: " tot)) + step-count-stmt))) + (map sqlite3:finalize! statements) + (sqlite3:finalize! test-count-stmt) + (sqlite3:finalize! step-count-stmt) (sqlite3:execute db "VACUUM;"))) ;; Clean out old junk and vacuum the database ;; ;; Ultimately do something like this: @@ -2059,11 +1257,11 @@ ;; a. If have tests that are not deleted, set state='unknown' ;; b. .... ;; (define (db:clean-up-maindb dbdat) ;; (debug:print 0 *default-log-port* "WARNING: db clean up not fully ported to v1.60, cleanup action will be on megatest.db") - (let* ((db (db:dbdat-get-db dbdat)) + (let* ((db (dbr:dbdat-dbh dbdat)) (count-stmt (sqlite3:prepare db "SELECT (SELECT count(id) FROM runs);")) (statements (map (lambda (stmt) (sqlite3:prepare db stmt)) (list @@ -2081,104 +1279,48 @@ ;; (db:delay-if-busy dbdat) (sqlite3:with-transaction db (lambda () (sqlite3:for-each-row (lambda (tot) - (debug:print-info 0 *default-log-port* "Records count before clean: " tot)) + (debug:print-info 0 *default-log-port* "Run records count before clean: " tot)) count-stmt) (map sqlite3:execute statements) (sqlite3:for-each-row (lambda (tot) - (debug:print-info 0 *default-log-port* "Records count after clean: " tot)) + (debug:print-info 0 *default-log-port* "Run records count after clean: " tot)) count-stmt))) (map sqlite3:finalize! statements) (sqlite3:finalize! count-stmt) ;; (db:find-and-mark-incomplete db) ;; (db:delay-if-busy dbdat) (sqlite3:execute db "VACUUM;") dead-runs)) -;;====================================================================== -;; M E T A G E T A N D S E T V A R S -;;====================================================================== - -;; returns number if string->number is successful, string otherwise -;; also updates *global-delta* -;; -(define (db:get-var dbstruct var) - (let* ((res #f)) - (db:with-db - dbstruct #f #f - (lambda (db) - (sqlite3:for-each-row - (lambda (val) - (set! res val)) - db - "SELECT val FROM metadat WHERE var=?;" var) - ;; convert to number if can - (if (string? res) - (let ((valnum (string->number res))) - (if valnum (set! res valnum)))) - res)))) - -(define (db:inc-var dbstruct var) - (db:with-db dbstruct #f #t - (lambda (db) - (sqlite3:execute db "UPDATE metadat SET val=val+1 WHERE var=?;" var)))) - -(define (db:dec-var dbstruct var) - (db:with-db dbstruct #f #t - (lambda (db) - (sqlite3:execute db "UPDATE metadat SET val=val-1 WHERE var=?;" var)))) - -;; This was part of db:get-var. It was used to estimate the load on -;; the database files. -;; -;; scale by 10, average with current value. -;; (set! *global-delta* (/ (+ *global-delta* (* (- (current-milliseconds) start-ms) -;; (if throttle throttle 0.01))) -;; 2)) -;; (if (> (abs (- *last-global-delta-printed* *global-delta*)) 0.08) ;; don't print all the time, only if it changes a bit -;; (begin -;; (debug:print-info 4 *default-log-port* "launch throttle factor=" *global-delta*) -;; (set! *last-global-delta-printed* *global-delta*))) - -(define (db:set-var dbstruct var val) - (db:with-db dbstruct #f #t - (lambda (db) - (sqlite3:execute db "INSERT OR REPLACE INTO metadat (var,val) VALUES (?,?);" var val)))) - -(define (db:add-var dbstruct var val) - (db:with-db dbstruct #f #t - (lambda (db) - (sqlite3:execute db "UPDATE metadat SET val=val+? WHERE var=?;" val var)))) - -(define (db:del-var dbstruct var) - (db:with-db dbstruct #f #t - (lambda (db) - (sqlite3:execute db "DELETE FROM metadat WHERE var=?;" var)))) - ;;====================================================================== ;; no-sync.db - small bits of data to be shared between servers ;;====================================================================== -(define (db:open-no-sync-db) - (let* ((dbpath (db:dbfile-path)) - (dbname (conc dbpath "/no-sync.db")) - (db-exists (common:file-exists? dbname)) - (db (sqlite3:open-database dbname))) - (sqlite3:set-busy-handler! db (sqlite3:make-busy-timeout 136000)) - (if (not db-exists) - (begin - (sqlite3:execute db "CREATE TABLE IF NOT EXISTS no_sync_metadat (var TEXT,val TEXT, CONSTRAINT no_sync_metadat_constraint UNIQUE (var));") - (sqlite3:execute db "PRAGMA journal_mode=WAL;"))) - ;; MOVE THIS TABLE CREATION TO THE (begin above in about six months (it is Sep 2020 right now). - (sqlite3:execute db "CREATE TABLE IF NOT EXISTS jobs_queue (id INTEGER PRIMARY KEY, host_type TEXT, cores INTEGER, memory TEXT, vars TEXT, exekey TEXT, cmdline TEXT, state TEXT, event_time INTEGER, last_update INTEGER);") - ;; not sure I'll use this next one. I prefer if tests simply append to a file: - ;; last-update-seconds cpuload tmpspace rundirspace - (sqlite3:execute db "CREATE TABLE IF NOT EXISTS test_extra_data (id INTEGER PRIMARY KEY, run_id INTEGER, test_id INTEGER, last_seen_running INTEGER);") - (sqlite3:execute db "PRAGMA synchronous = 0;") - db)) +;; if we are not a server create a db handle. this is not finalized +;; so watch for problems. I'm still not clear if it is needed to manually +;; finalize sqlite3 dbs with the sqlite3 egg. +;; +(define (db:no-sync-db db-in) + (mutex-lock! *db-access-mutex*) + (let ((res (if db-in + db-in + (let ((db (db:open-no-sync-db))) + (set! *no-sync-db* db) + db)))) + (mutex-unlock! *db-access-mutex*) + res)) + + +(define (db:get-dbsync-path) + (case (rmt:transport-mode) + ((http)(common:make-tmpdir-name *toppath* "")) + ((tcp) (conc *toppath*"/.mtdb")) + ((nfs) (conc *toppath*"/.mtdb")) + (else "/tmp/dunno-this-gonna-exist"))) (define (db:no-sync-add-job db-in host-type vars-list exekey cmdline) (sqlite3:execute (db:no-sync-db db-in) "INSERT INTO jobs_queue (host_type,vars,exekey,cmdline,state,event_time,last_update) VALUES (?,?,?,?,?,?,?);" host-type (with-output-to-string @@ -2223,30 +1365,10 @@ ;; (define (db:no-sync-job-records-clean db) (sqlite3:execute (db:no-sync-db db) "DELETE FROM jobs_queue WHERE state='taken' AND event_time < ?;" (- (current-seconds)(* 24 3600)))) -;; if we are not a server create a db handle. this is not finalized -;; so watch for problems. I'm still not clear if it is needed to manually -;; finalize sqlite3 dbs with the sqlite3 egg. -;; -(define (db:no-sync-db db-in) - (mutex-lock! *db-access-mutex*) - (let ((res (if db-in - db-in - (let ((db (db:open-no-sync-db))) - (set! *no-sync-db* db) - db)))) - (mutex-unlock! *db-access-mutex*) - res)) - -(define (db:no-sync-set db var val) - (sqlite3:execute (db:no-sync-db db) "INSERT OR REPLACE INTO no_sync_metadat (var,val) VALUES (?,?);" var val)) - -(define (db:no-sync-del! db var) - (sqlite3:execute (db:no-sync-db db) "DELETE FROM no_sync_metadat WHERE var=?;" var)) - (define (db:no-sync-get/default db-in var default) (let ((db (db:no-sync-db db-in)) (res default)) (sqlite3:for-each-row (lambda (val) @@ -2261,74 +1383,46 @@ (if newres newres res)) res))) -(define (db:no-sync-close-db db stmt-cache) - (db:safely-close-sqlite3-db db stmt-cache)) - -;; transaction protected lock aquisition -;; either: -;; fails returns (#f . lock-creation-time) -;; succeeds (returns (#t . lock-creation-time) -;; use (db:no-sync-del! db keyname) to release the lock -;; -(define (db:no-sync-get-lock db-in keyname) - (let ((db (db:no-sync-db db-in))) - (sqlite3:with-transaction - db - (lambda () - (handle-exceptions - exn - (let ((lock-time (current-seconds))) - (debug:print-info 2 *default-log-port* "db:no-sync-get-lock keyname=" keyname ", lock-time=" lock-time ", exn=" exn) - (sqlite3:execute db "INSERT INTO no_sync_metadat (var,val) VALUES(?,?);" keyname lock-time) - `(#t . ,lock-time)) - `(#f . ,(sqlite3:first-result db "SELECT val FROM no_sync_metadat WHERE var=?;" keyname))))))) - - - -;; use a global for some primitive caching, it is just silly to -;; re-read the db over and over again for the keys since they never -;; change - + +;; This is needed for api.scm +(define (db:open-no-sync-db) + (dbfile:open-no-sync-db (db:get-dbsync-path))) + ;; why get the keys from the db? why not get from the *configdat* ;; using keys:config-get-fields? (define (db:get-keys dbstruct) - (if *db-keys* *db-keys* - (let ((res '())) - (db:with-db dbstruct #f #f - (lambda (db) - (sqlite3:for-each-row - (lambda (key) - (set! res (cons key res))) - db - "SELECT fieldname FROM keys ORDER BY id DESC;"))) - (set! *db-keys* res) - res))) + (keys:config-get-fields *configdat*)) ;; extract index number given a header/data structure (define (db:get-index-by-header header field) (list-index (lambda (x)(equal? x field)) header)) ;; look up values in a header/data structure (define (db:get-value-by-header row header field) - (if (or (null? header) (not row)) - #f - (let loop ((hed (car header)) - (tal (cdr header)) - (n 0)) - (if (equal? hed field) - (handle-exceptions - exn - (begin - (debug:print 0 *default-log-port* "WARNING: attempt to read non-existant field, row=" - row " header=" header " field=" field ", exn=" exn) - #f) - (vector-ref row n)) - (if (null? tal) #f (loop (car tal)(cdr tal)(+ n 1))))))) + (let ((len (if (vector? row) + (vector-length row) + 0))) + (if (or (null? header) (not row)) + #f + (let loop ((hed (car header)) + (tal (cdr header)) + (n 0)) + (if (equal? hed field) + (handle-exceptions + exn + (begin + (debug:print 4 *default-log-port* "WARNING: attempt to read non-existant field, row=" + row " header=" header " field=" field ", exn=" exn) + #f) + (if (>= n len) + #f + (vector-ref row n))) + (if (null? tal) #f (loop (car tal)(cdr tal)(+ n 1)))))))) ;; Accessors for the header/data structure ;; get rows and header from (define (db:get-header vec)(vector-ref vec 0)) (define (db:get-rows vec)(vector-ref vec 1)) @@ -2335,40 +1429,33 @@ ;;====================================================================== ;; R U N S ;;====================================================================== - - - - (define (db:get-run-times dbstruct run-patt target-patt) (let ((res `()) - (qry (conc "select runname, (max(end_time)-min(event_time))/60 as runtime, target from (select runname, run_id,tests.event_time,tests.event_time+run_duration AS end_time, " (string-join (db:get-keys dbstruct) " || '/' || ") " as target from tests inner join runs on tests.run_id = runs.id where runs.runname like ? and target like ?) group by run_id ;"))) -;(print qry) -(db:with-db + (qry (conc "select runname, (max(end_time)-min(event_time))/60 as runtime, target from (select runname, run_id,tests.event_time,tests.event_time+run_duration AS end_time, " (string-join (db:get-keys dbstruct) " || '/' || ") " as target from tests inner join runs on tests.run_id = runs.id where runs.runname like ? and target like ?) group by run_id ;"))) + ;(print qry) + (db:with-db dbstruct #f ;; this is for the main runs db #f ;; does not modify db - (lambda (db) - (sqlite3:for-each-row - (lambda (runname runtime target ) - (set! res (cons (vector runname runtime target) res))) - db - qry - run-patt target-patt) - - res)))) - - + (lambda (dbdat db) + (sqlite3:for-each-row + (lambda (runname runtime target ) + (set! res (cons (vector runname runtime target) res))) + db + qry + run-patt target-patt) + res)))) (define (db:get-run-name-from-id dbstruct run-id) (db:with-db dbstruct #f ;; this is for the main runs db #f ;; does not modify db - (lambda (db) + (lambda (dbdat db) (let ((res #f)) (sqlite3:for-each-row (lambda (runname) (set! res runname)) db @@ -2379,11 +1466,11 @@ (define (db:get-run-key-val dbstruct run-id key) (db:with-db dbstruct #f #f - (lambda (db) + (lambda (dbdat db) (let ((res #f)) (sqlite3:for-each-row (lambda (val) (set! res val)) db @@ -2423,18 +1510,22 @@ (andstr (if (> (length keys) 0) " AND " "")) (valslots (keys->valslots keys)) ;; ?,?,? ... (allvals (append (list runname state status user contour) (map cadr keyvals))) (qryvals (append (list runname) (map cadr keyvals))) (key=?str (string-intersperse (map (lambda (k)(conc k "=?")) keys) " AND "))) + ;; (debug:print 0 *default-log-port* "Got here 0.") (debug:print 3 *default-log-port* "keys: " keys " allvals: " allvals " keyvals: " keyvals " key=?str is " key=?str) (debug:print 2 *default-log-port* "NOTE: using target " (string-intersperse (map cadr keyvals) "/") " for this run") (if (and runname (null? (filter (lambda (x)(not x)) keyvals))) ;; there must be a better way to "apply and" (db:with-db - dbstruct #f #f - (lambda (db) + dbstruct #f #t + (lambda (dbdat db) + ;; (debug:print 0 *default-log-port* "Got here 1.") (let ((res #f)) - (apply sqlite3:execute db (conc "INSERT OR IGNORE INTO runs (runname,state,status,owner,event_time,contour" comma keystr ") VALUES (?,?,?,?,strftime('%s','now'),?" comma valslots ");") + (apply sqlite3:execute db + (conc "INSERT OR IGNORE INTO runs (runname,state,status,owner,event_time,contour" + comma keystr ") VALUES (?,?,?,?,strftime('%s','now'),?" comma valslots ");") allvals) (apply sqlite3:for-each-row (lambda (id) (set! res id)) db @@ -2445,10 +1536,115 @@ res))) (begin (debug:print-error 0 *default-log-port* "Called without all necessary keys") #f)))) +(define (db:get-run-id dbstruct runname target) + (let ((runs (db:simple-get-runs dbstruct runname #f #f target #f))) ;; runpatt count offset target last-update + (if (null? runs) + #f + (simple-run-id (car runs))))) + +;; called with run-id=#f so will operate on main.db +;; +(define (db:insert-run dbstruct run-id target runname run-meta) + (let* ((keys (db:get-keys dbstruct)) + (runs (db:simple-get-runs dbstruct runname #f #f target #f))) ;; runpatt count offset target last-update + ;; need to insert run based on target and runname + (let* ((targvals (string-split target "/")) + (keystr (string-intersperse keys ",")) + (key?str (string-intersperse (make-list (length targvals) "?") ",")) + (qrystr (conc "INSERT INTO runs (id,runname,"keystr") VALUES (?,?,"key?str")")) + (get-var (lambda (db qrystr) + (let* ((res #f)) + (sqlite3:for-each-row + (lambda row + (set res (car row))) + db qrystr run-id runname) + res)))) + (if (null? runs) + (begin + (db:create-initial-run-record dbstruct run-id runname target) + ) + ) + (let* () + ;;(debug:print 0 *default-log-port* "db:insert-run: Calling db:with-db to update the run record") + (debug:print 0 *default-log-port* "db:insert-run: runid = " run-id) +#; (db:with-db + dbstruct + #f #t + (lambda (dbdat db) + (debug:print 0 *default-log-port* "In the lambda proc for " dbdat " " db) + (for-each + (lambda (keyval) + (debug:print 0 *default-log-port* "In the lambda proc for " keyval) + (let* ((fieldname (car keyval)) + (getqry (conc "SELECT "fieldname" FROM runs WHERE id=?;")) + (setqry (conc "UPDATE runs SET "fieldname"=? WHERE id=?;")) + (val (cdr keyval)) + (valnum (if (number? val) + val + (if (string? val) + (string->number val) + #f)))) + (debug:print 0 *default-log-port* "fieldname " fieldname " val " val " valnum " valnum) + (if (not (member fieldname (cons "runname" keys))) ;; don't attempt to tweak these + (let* ((curr-val (get-var db getqry)) + (have-it (or (equal? curr-val val) + (equal? curr-val valnum)))) + (debug:print 0 *default-log-port* "have-it = " have-it) + (if (not have-it) + (begin + (debug:print 0 *default-log-port* "Do sqlite3:execute") + ;; (sqlite3:execute db setqry (or valnum val) run-id) + ) + ) + ) + ) + (debug:print 0 *default-log-port* "Done with update") + ) + (debug:print 0 *default-log-port* "next keyval") + ) + run-meta))) + run-id)))) + +(define (db:create-initial-run-record dbstruct run-id runname target) + (let* ((keys (db:get-keys dbstruct)) + (targvals (string-split target "/")) + (keystr (string-intersperse keys ",")) + (key?str (string-intersperse (make-list (length targvals) "?") ",")) ;; a string with the same length as targvals, where each element is "?" and interspersed with commas. + (qrystr (conc "INSERT INTO runs (id,runname,"keystr") VALUES (?,?,"key?str")"))) + (debug:print 0 *default-log-port* "db:create-initial-run-record") + (debug:print 0 *default-log-port* "qrystr = " qrystr) + + (db:with-db + dbstruct #f #t ;; run-id writable + (lambda (dbdat db) + (debug:print 0 *default-log-port* "lambda proc: dbdat: " dbdat " db: " db) + (apply sqlite3:execute db qrystr run-id runname targvals))))) + +(define (db:insert-test dbstruct run-id test-rec) + (let* ((testname (alist-ref "testname" test-rec equal?)) + (item-path (alist-ref "item_path" test-rec equal?)) + (id (db:get-test-id dbstruct run-id testname item-path)) + (fieldvals (filter (lambda (x)(not (member (car x) '("id" "last_update")))) test-rec)) + (setqry (conc "UPDATE tests SET "(string-intersperse + (map (lambda (dat) + (conc (car dat)"=?")) + fieldvals) + ",")" WHERE id=?;")) + (insqry (conc "INSERT INTO tests ("(string-intersperse (map (lambda (x) (car x)) fieldvals) ",") + ") VALUES ("(string-intersperse (make-list (length fieldvals) "?") ",")");"))) + ;; (debug:print 0 *default-log-port* "id: "id"\nset: "setqry"\ninsqry: "insqry) + (db:with-db + dbstruct + run-id #t + (lambda (dbdat db) + (if id + (apply sqlite3:execute db setqry (append (map cdr fieldvals) (list id))) + (apply sqlite3:execute db insqry (map cdr fieldvals))))))) + ;; replace header and keystr with a call to runs:get-std-run-fields ;; ;; keypatts: ( (KEY1 "abc%def")(KEY2 "%") ) ;; runpatts: patt1,patt2 ... ;; @@ -2478,27 +1674,23 @@ (if (number? offset) (conc " OFFSET " offset) "")))) (debug:print-info 11 *default-log-port* "db:get-runs START qrystr: " qrystr " keypatts: " keypatts " offset: " offset " limit: " count) (db:with-db dbstruct #f #f - (lambda (db) + (lambda (dbdat db) (sqlite3:for-each-row (lambda (a . x) (set! res (cons (apply vector a x) res))) db qrystr ))) (debug:print-info 11 *default-log-port* "db:get-runs END qrystr: " qrystr " keypatts: " keypatts " offset: " offset " limit: " count) (vector header res))) - -(define-record simple-run target id runname state status owner event_time) -(define-record-printer (simple-run x out) - (fprintf out "#,(simple-run ~S ~S ~S ~S)" - (simple-run-target x) (simple-run-id x) (simple-run-runname x) (time->string (seconds->local-time (simple-run-event_time x) )))) - ;; simple get-runs +;; +;; records used defined in dbfile ;; (define (db:simple-get-runs dbstruct runpatt count offset target last-update) (let* ((res '()) (keys (db:get-keys dbstruct)) (runpattstr (db:patt->like "runname" runpatt)) @@ -2521,31 +1713,33 @@ (conc " OFFSET " offset) ""))) ) (debug:print-info 11 *default-log-port* "db:get-runs START qrystr: " qrystr " target: " target " offset: " offset " limit: " count) (db:with-db dbstruct #f #f - (lambda (db) + (lambda (dbdat db) (sqlite3:for-each-row (lambda (target id runname state status owner event_time) (set! res (cons (make-simple-run target id runname state status owner event_time) res))) db qrystr ))) (debug:print-info 11 *default-log-port* "db:get-runs END qrystr: " qrystr " target: " target " offset: " offset " limit: " count) res)) -;; TODO: Switch this to use max(update_time) from each run db? Then if using a server there is no disk traffic (using inmem db) +;; TODO: Switch this to use max(update_time) from each run db? Then if using a server there is no disk traffic (using cachedb db) ??? ;; +;; NOTE: This DOESN'T (necessarily) get the real run ids, but the number of the .db!! + (define (db:get-changed-run-ids since-time) - (let* ((dbdir (db:dbfile-path)) ;; (configf:lookup *configdat* "setup" "dbdir")) - (alldbs (glob (conc dbdir "/[0-9]*.db"))) + (let* ((dbdir (common:make-tmpdir-name *toppath* "")) ;; (configf:lookup *configdat* "setup" "dbdir")) + (alldbs (glob (conc *toppath* "/.mtdb/[0-9]*.db*"))) (changed (filter (lambda (dbfile) (> (file-modification-time dbfile) since-time)) alldbs))) (delete-duplicates (map (lambda (dbfile) - (let* ((res (string-match ".*\\/(\\d)*\\.db" dbfile))) + (let* ((res (string-match ".*\\/(\\d+)\\.db*" dbfile))) (if res (string->number (cadr res)) (begin (debug:print 2 *default-log-port* "WARNING: Failed to process " dbfile " for run-id") 0)))) @@ -2562,11 +1756,11 @@ (seen (make-hash-table))) (db:with-db dbstruct #f #f - (lambda (db) + (lambda (dbdat db) (sqlite3:for-each-row (lambda (a . x) (let ((targ (cons a x))) (if (not (hash-table-ref/default seen targ #f)) (begin @@ -2581,11 +1775,11 @@ (define (db:get-num-runs dbstruct runpatt) (db:with-db dbstruct #f #f - (lambda (db) + (lambda (dbdat db) (let ((numruns 0)) (debug:print-info 11 *default-log-port* "db:get-num-runs START " runpatt) (sqlite3:for-each-row (lambda (count) (set! numruns count)) @@ -2598,11 +1792,11 @@ (define (db:get-runs-cnt-by-patt dbstruct runpatt targetpatt keys) (db:with-db dbstruct #f #f - (lambda (db) + (lambda (dbdat db) (let ((numruns 0) (qry-str #f) (key-patt "") (keyvals (if targetpatt (keys:target->keyval keys targetpatt) '()))) @@ -2636,11 +1830,11 @@ (define (db:get-raw-run-stats dbstruct run-id) (db:with-db dbstruct run-id #f - (lambda (db) + (lambda (dbdat db) (sqlite3:fold-row (lambda (res state status count) (cons (list state status count) res)) '() db @@ -2648,42 +1842,44 @@ run-id)))) ;; Update run_stats for given run_id ;; input data is a list (state status count) ;; -(define (db:update-run-stats dbstruct run-id stats) - ;; (mutex-lock! *db-transaction-mutex*) - (db:with-db - dbstruct - #f - #f - - (lambda (db) - ;; remove previous data - - (let* ((stmt1 (sqlite3:prepare db "DELETE FROM run_stats WHERE run_id=? AND state=? AND status=?;")) - (stmt2 (sqlite3:prepare db "INSERT INTO run_stats (run_id,state,status,count) VALUES (?,?,?,?);")) - (res - (sqlite3:with-transaction - db - (lambda () - (for-each - (lambda (dat) - (sqlite3:execute stmt1 run-id (car dat)(cadr dat)) - (apply sqlite3:execute stmt2 run-id dat)) - stats))))) - (sqlite3:finalize! stmt1) - (sqlite3:finalize! stmt2) - ;; (mutex-unlock! *db-transaction-mutex*) - res)))) +(define (db:update-run-stats dbstruct run-id stats-in) + (let* ((stats (if (list? stats-in) + stats-in + (db:get-raw-run-stats dbstruct run-id)))) + (mutex-lock! *db-transaction-mutex*) + (db:with-db + dbstruct + #f + #t + (lambda (dbdat db) + ;; remove previous data + + (let* ((stmt1 (sqlite3:prepare db "DELETE FROM run_stats WHERE run_id=? AND state=? AND status=?;")) + (stmt2 (sqlite3:prepare db "INSERT INTO run_stats (run_id,state,status,count) VALUES (?,?,?,?);")) + (res + (sqlite3:with-transaction + db + (lambda () + (for-each + (lambda (dat) + (sqlite3:execute stmt1 run-id (car dat)(cadr dat)) + (apply sqlite3:execute stmt2 run-id dat)) + stats))))) + (sqlite3:finalize! stmt1) + (sqlite3:finalize! stmt2) + (mutex-unlock! *db-transaction-mutex*) + res))))) (define (db:get-main-run-stats dbstruct run-id) (db:with-db dbstruct #f ;; this data comes from main #f - (lambda (db) + (lambda (dbdat db) (sqlite3:fold-row (lambda (res state status count) (cons (list state status count) res)) '() db @@ -2712,11 +1908,11 @@ (define (db:get-all-run-ids dbstruct) (db:with-db dbstruct #f #f - (lambda (db) + (lambda (dbdat db) (let ((run-ids '())) (sqlite3:for-each-row (lambda (run-id) (set! run-ids (cons run-id run-ids))) db @@ -2736,11 +1932,11 @@ (res '()) (runs-info '())) ;; First get all the runname/run-ids (db:with-db dbstruct #f #f - (lambda (db) + (lambda (dbdat db) (sqlite3:for-each-row (lambda (run-id runname) (set! runs-info (cons (list run-id runname) runs-info))) db "SELECT id,runname FROM runs WHERE state != 'deleted' ORDER BY event_time DESC;"))) ;; If you change this to the more logical ASC please adjust calls to db:get-run-stats @@ -2752,11 +1948,11 @@ (run-name (cadr run-info))) (db:with-db dbstruct run-id #f - (lambda (db) + (lambda (dbdat db) (sqlite3:for-each-row (lambda (state status count) (let ((netstate (if (equal? state "COMPLETED") status state))) (if (string? netstate) (begin @@ -2813,19 +2009,20 @@ (debug:print-info 4 *default-log-port* "runs:get-runs-by-patt qry=" qry-str " " runnamepatt) ;(print "runs:get-runs-by-patt qry=" qry-str " " runnamepatt) (vector header (reverse - (db:with-db dbstruct #f #f ;; reads db, does not write to it. - (lambda (db) - (sqlite3:fold-row - (lambda (res . r) - (cons (list->vector r) res)) - '() - db - qry-str - runnamepatt))))))) + (db:with-db + dbstruct #f #f ;; reads db, does not write to it. + (lambda (dbdat db) + (sqlite3:fold-row + (lambda (res . r) + (cons (list->vector r) res)) + '() + db + qry-str + runnamepatt))))))) ;; use (get-value-by-header (db:get-header runinfo)(db:get-rows runinfo)) ;; NOTE: Does NOT return a list of rows (or one row) for the first slot of the vector ;; this is inconsistent with get-runs but it makes some sense. ;; @@ -2840,11 +2037,11 @@ (string-intersperse remfields ",")))) (debug:print-info 11 *default-log-port* "db:get-run-info run-id: " run-id " header: " header " keystr: " keystr) (db:with-db dbstruct #f #f - (lambda (db) + (lambda (dbdat db) (sqlite3:for-each-row (lambda (a . x) (set! res (apply vector a x))) db (conc "SELECT " keystr " FROM runs WHERE id=?;") @@ -2855,19 +2052,19 @@ finalres))) (define (db:set-comment-for-run dbstruct run-id comment) (db:with-db dbstruct #f #f - (lambda (db) + (lambda (dbdat db) (sqlite3:execute db "UPDATE runs SET comment=? WHERE id=?;" comment ;; (sdb:qry 'getid comment) run-id)))) ;; does not (obviously!) removed dependent data. But why not!!? (define (db:delete-run dbstruct run-id) (db:with-db - dbstruct #f #f - (lambda (db) + dbstruct #f #t + (lambda (dbdat db) (sqlite3:with-transaction db (lambda () (sqlite3:execute db "DELETE FROM test_steps WHERE test_id IN (SELECT id FROM tests WHERE run_id=?);" run-id) (sqlite3:execute db "DELETE FROM test_data WHERE test_id IN (SELECT id FROM tests WHERE run_id=?);" run-id) @@ -2876,17 +2073,17 @@ (sqlite3:execute db "UPDATE runs SET state='deleted',comment='' WHERE id=?;" run-id)))))) (define (db:update-run-event_time dbstruct run-id) (db:with-db dbstruct #f #t - (lambda (db) + (lambda (dbdat db) (sqlite3:execute db "UPDATE runs SET event_time=strftime('%s','now') WHERE id=?;" run-id)))) (define (db:lock/unlock-run dbstruct run-id lock unlock user) (db:with-db dbstruct #f #t - (lambda (db) + (lambda (dbdat db) (let ((newlockval (if lock "locked" (if unlock "unlocked" "locked")))) ;; semi-failsafe (sqlite3:execute db "UPDATE runs SET state=? WHERE id=?;" newlockval run-id) @@ -2894,47 +2091,66 @@ user (conc newlockval " " run-id)) (debug:print-info 1 *default-log-port* "" newlockval " run number " run-id))))) (define (db:set-run-status dbstruct run-id status msg) (db:with-db - dbstruct #f #f - (lambda (db) + dbstruct #f #t + (lambda (dbdat db) (if msg (sqlite3:execute db "UPDATE runs SET status=?,comment=? WHERE id=?;" status msg run-id) (sqlite3:execute db "UPDATE runs SET status=? WHERE id=?;" status run-id))))) +(define (db:set-run-state-status-db dbdat db run-id state status ) + (sqlite3:execute + (db:get-cache-stmth + dbdat db "UPDATE runs SET status=?,state=? WHERE id=?;") status state run-id)) + (define (db:set-run-state-status dbstruct run-id state status ) (db:with-db - dbstruct #f #f - (lambda (db) - (sqlite3:execute db "UPDATE runs SET status=?,state=? WHERE id=?;" status state run-id)))) - - - + dbstruct #f #t + (lambda (dbdat db) + (db:set-run-state-status-db dbdat db run-id state status)))) + (define (db:get-run-status dbstruct run-id) (let ((res "n/a")) (db:with-db dbstruct #f #f - (lambda (db) + (lambda (dbdat db) (sqlite3:for-each-row (lambda (status) (set! res status)) - db - "SELECT status FROM runs WHERE id=?;" + (db:get-cache-stmth + dbdat db + "SELECT status FROM runs WHERE id=?;" ) run-id) res)))) (define (db:get-run-state dbstruct run-id) (let ((res "n/a")) (db:with-db dbstruct #f #f - (lambda (db) + (lambda (dbdat db) (sqlite3:for-each-row (lambda (status) (set! res status)) - db - "SELECT state FROM runs WHERE id=?;" + (db:get-cache-stmth + dbdat db + "SELECT state FROM runs WHERE id=?;" ) + run-id) + res)))) + +(define (db:get-run-state-status dbstruct run-id) + (let ((res (cons "n/a" "n/a"))) + (db:with-db + dbstruct #f #f + (lambda (dbdat db) + (sqlite3:for-each-row + (lambda (state status) + (set! res (cons state status))) + (db:get-cache-stmth + dbdat db + "SELECT state,status FROM runs WHERE id=?;" ) run-id) res)))) ;;====================================================================== @@ -2946,11 +2162,11 @@ (define (db:get-key-val-pairs dbstruct run-id) (let* ((keys (db:get-keys dbstruct)) (res '())) (db:with-db dbstruct #f #f - (lambda (db) + (lambda (dbdat db) (for-each (lambda (key) (let ((qry (conc "SELECT " key " FROM runs WHERE id=?;"))) (sqlite3:for-each-row (lambda (key-val) @@ -2963,11 +2179,11 @@ (define (db:get-key-vals dbstruct run-id) (let* ((keys (db:get-keys dbstruct)) (res '())) (db:with-db dbstruct #f #f - (lambda (db) + (lambda (dbdat db) (for-each (lambda (key) (let ((qry (conc "SELECT " key " FROM runs WHERE id=?;"))) ;; (db:delay-if-busy dbdat) (sqlite3:for-each-row @@ -2988,18 +2204,18 @@ ;; 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 (db:get-key-val-pairs dbstruct run-id)) (kvalues (map cadr keyvals)) - (keys (rmt:get-keys)) + (keys (db:get-keys dbstruct)) (qrystr (string-intersperse (map (lambda (x)(conc x "=?")) keys) " AND "))) (let ((prev-run-ids '())) (if (null? keyvals) '() (begin (db:with-db dbstruct #f #f ;; #f means work with the zeroth db - i.e. the runs db - (lambda (db) + (lambda (dbdat db) (apply sqlite3:for-each-row (lambda (id) (set! prev-run-ids (cons id prev-run-ids))) db (conc "SELECT id FROM runs WHERE " qrystr " AND state != 'deleted' AND id != ?;") @@ -3090,11 +2306,11 @@ (if offset (conc " OFFSET " offset) " ") ";" ))) (debug:print-info 8 *default-log-port* "db:get-tests-for-run run-id=" run-id ", qry=" qry) (let* ((res (db:with-db dbstruct run-id #f - (lambda (db) + (lambda (dbdat db) ;; (let* ((stmth (db:get-cache-stmth dbstruct db qry))) ;; due to use of last-update we can't efficiently cache this query (reverse (sqlite3:fold-row (lambda (res . row) ;; id run-id testname state status event-time host cpuload @@ -3124,33 +2340,33 @@ ;; ;; 1. cache tests-match-qry ;; 2. compile qry and store in hash ;; 3. convert for-each-row to fold ;; -(define (db:get-tests-for-run-state-status dbstruct run-id testpatt) - (db:with-db - dbstruct run-id #f - (lambda (db) - (let* ((res '()) - (stmt-cache (dbr:dbstruct-stmt-cache dbstruct)) - (stmth (let* ((sh (db:hoh-get stmt-cache db testpatt))) - (or sh - (let* ((tests-match-qry (tests:match->sqlqry testpatt)) - (qry (conc "SELECT id,testname,item_path,state,status FROM tests WHERE run_id=? " - (if tests-match-qry (conc " AND (" tests-match-qry ") ") ""))) - (newsh (sqlite3:prepare db qry))) - (debug:print-info 8 *default-log-port* "db:get-tests-for-run qry=" qry) - (db:hoh-set! stmt-cache db testpatt newsh) - newsh))))) - (reverse - (sqlite3:fold-row - (lambda (res 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 - (cons (vector id run-id testname state status -1 "" -1 -1 "" "-" item-path -1 "-" "-") res)) - '() - stmth - run-id)))))) +;; (define (db:get-tests-for-run-state-status dbstruct run-id testpatt) +;; (db:with-db +;; dbstruct run-id #f +;; (lambda (dbdat db) +;; (let* ((res '()) +;; (stmt-cache (dbr:dbstruct-stmt-cache dbstruct)) +;; (stmth (let* ((sh (db:hoh-get stmt-cache db testpatt))) +;; (or sh +;; (let* ((tests-match-qry (tests:match->sqlqry testpatt)) +;; (qry (conc "SELECT id,testname,item_path,state,status FROM tests WHERE run_id=? " +;; (if tests-match-qry (conc " AND (" tests-match-qry ") ") ""))) +;; (newsh (sqlite3:prepare db qry))) +;; (debug:print-info 8 *default-log-port* "db:get-tests-for-run qry=" qry) +;; (db:hoh-set! stmt-cache db testpatt newsh) +;; newsh))))) +;; (reverse +;; (sqlite3:fold-row +;; (lambda (res 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 +;; (cons (vector id run-id testname state status -1 "" -1 -1 "" "-" item-path -1 "-" "-") res)) +;; '() +;; stmth +;; run-id)))))) (define (db:get-tests-for-run-state-status dbstruct run-id testpatt #!optional (last-update 0)) (let* ((res '()) (tests-match-qry (tests:match->sqlqry testpatt)) (qry (conc "SELECT id,testname,item_path,state,status,event_time,run_duration FROM tests WHERE run_id=? " @@ -3157,11 +2373,11 @@ " AND last_update > ? " (if tests-match-qry (conc " AND (" tests-match-qry ") ") "") ))) (debug:print-info 8 *default-log-port* "db:get-tests-for-run qry=" qry) (db:with-db dbstruct run-id #f - (lambda (db) + (lambda (dbdat db) (sqlite3:fold-row (lambda (res id testname item-path state status event-time run-duration) ;; id,run_id,testname,state,status,event_time,host,cpuload,diskfree,uname,rundir,item_path,run_duration,final_logf,comment (cons (vector id run-id testname state status event-time "" -1 -1 "" "-" item-path run-duration "-" "-") res)) '() @@ -3169,21 +2385,24 @@ qry run-id (or last-update 0)))))) (define (db:get-testinfo-state-status dbstruct run-id test-id) - (let ((res #f)) - (db:with-db dbstruct run-id #f - (lambda (db) - (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)) + (db:with-db + dbstruct run-id #f + (lambda (dbdat db) + (let* ((res #f) + (stmth (db:get-cache-stmth dbdat db "SELECT run_id,testname,item_path,state,status FROM tests WHERE id=? and run_id=?;"))) + (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=? and run_id=?;" + stmth + test-id run-id) + res)))) ;; get a useful subset of the tests data (used in dashboard ;; use db:mintest-get-{id ,run_id,testname ...} ;; (define (db:get-tests-for-run-mindata dbstruct run-id testpatt states statuses not-in) @@ -3206,33 +2425,45 @@ ;; Convert calling routines to get list of run-ids and loop, do not use the get-tests-for-runs ;; (define (db:delete-test-records dbstruct run-id test-id) - (db:general-call dbstruct 'delete-test-step-records (list test-id)) - (db:general-call dbstruct 'delete-test-data-records (list test-id)) + (db:general-call dbstruct run-id 'delete-test-step-records (list test-id)) + (db:general-call dbstruct run-id 'delete-test-data-records (list test-id)) (db:with-db - dbstruct #f #f - (lambda (db) + dbstruct run-id #t + (lambda (dbdat db) (sqlite3:execute db "UPDATE tests SET state='DELETED',status='n/a',comment='' WHERE id=?;" test-id)))) ;; -(define (db:delete-old-deleted-test-records dbstruct) - (let ((targtime (- (current-seconds) - (or (configf:lookup-number *configdat* "setup" "keep-deleted-records") - (* 30 24 60 60))))) ;; one month in the past +(define (db:delete-old-deleted-test-records dbstruct run-id) + (let* ((targtime (- (current-seconds) + (or (configf:lookup-number *configdat* "setup" "keep-deleted-records") + (* 7 24 60 60)))) ;; cleanup if over one week old + (mtdbfile (dbmod:run-id->full-dbfname dbstruct run-id)) + (qry1 "DELETE FROM test_steps WHERE test_id IN (SELECT id FROM tests WHERE state='DELETED' AND event_timenumber "id" db:test-record-fields)))) - (db:adj-test-id (db:dbdat-get-db mtdb) min-test-id test-id))) + (db:adj-test-id (dbr:dbdat-dbh mtdb) min-test-id test-id))) testrecs))) ;; 1. move test ids into the 30k * run_id range ;; 2. move step ids into the 30k * run_id range ;; @@ -3541,29 +2772,49 @@ (define (db:prep-megatest.db-for-migration mtdb) (let* ((run-ids (db:get-all-run-ids mtdb))) (for-each (lambda (run-id) (let ((testrecs (db:get-all-tests-info-by-run-id mtdb run-id))) - (db:prep-megatest.db-adj-test-ids (db:dbdat-get-db mtdb) run-id testrecs))) + (db:prep-megatest.db-adj-test-ids (dbr:dbdat-dbh mtdb) run-id testrecs))) run-ids))) -;; Get test data using test_id, run-id is not used - but it will be! +;; Get test data using test_id ;; (define (db:get-test-info-by-id dbstruct run-id test-id) (db:with-db dbstruct - #f ;; run-id + run-id #f - (lambda (db) + (lambda (dbdat db) (let ((res #f)) (sqlite3:for-each-row ;; attemptnum added to hold pid of top process (not Megatest) controlling a test (lambda (id run-id testname state status event-time host cpuload diskfree uname rundir-id item-path run_duration final-logf-id comment short-dir-id attemptnum archived last-update) ;; 0 1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 (set! res (vector id run-id testname state status event-time host cpuload diskfree uname rundir-id item-path run_duration final-logf-id comment short-dir-id attemptnum archived last-update))) db - (conc "SELECT " db:test-record-qry-selector " FROM tests WHERE id=?;") - test-id) + ;; (db:get-cache-stmth dbdat db + ;; (conc "SELECT " db:test-record-qry-selector " FROM tests WHERE id=? AND run_id=?;")) + (conc "SELECT " db:test-record-qry-selector " FROM tests WHERE id=? AND run_id=?;") + test-id run-id) + res)))) + +;; Get test state, status using test_id +;; +(define (db:get-test-state-status-by-id dbstruct run-id test-id) + (db:with-db + dbstruct + run-id + #f + (lambda (dbdat db) + (let ((res (cons #f #f)) + (stmth (db:get-cache-stmth dbdat db "SELECT state,status FROM tests WHERE id=? AND run_id=?;"))) + (sqlite3:for-each-row ;; attemptnum added to hold pid of top process (not Megatest) controlling a test + (lambda (state status) + (cons state status)) + ;; db + stmth ;;"SELECT state,status FROM tests WHERE id=? AND run_id=?;" ;; stmth try not compiling this one - yes, this fixed the bind issue + test-id run-id) res)))) ;; Use db:test-get* to access ;; Get test data using test_ids. NB// Only works within a single run!! ;; @@ -3570,11 +2821,11 @@ (define (db:get-test-info-by-ids dbstruct run-id test-ids) (db:with-db dbstruct run-id #f - (lambda (db) + (lambda (dbdat db) (let ((res '())) (sqlite3:for-each-row (lambda (a . b) ;; 0 1 2 3 4 5 6 7 8 9 10 11 12 13 14 (set! res (cons (apply vector a b) res))) @@ -3581,63 +2832,65 @@ db (conc "SELECT " db:test-record-qry-selector " FROM tests WHERE id in (" (string-intersperse (map conc test-ids) ",") ");")) res)))) +;; try every second until tries times proc +;; +(define (db:keep-trying-until-true proc params tries) + (let* ((res (apply proc params))) + (if res + res + (if (> tries 0) + (begin + (thread-sleep! 1) + (db:keep-trying-until-true proc params (- tries 1))) + (begin + ;; (debug:print-info 0 *default-log-port* "proc never returned true, params="params) + (print"db:keep-trying-until-true proc never returned true, proc = " proc " params =" params " tries = " tries) + #f))))) + (define (db:get-test-info dbstruct run-id test-name item-path) (db:with-db dbstruct run-id #f - (lambda (db) - (let ((res #f)) - (sqlite3:for-each-row - (lambda (a . b) - (set! res (apply vector a b))) - db - (conc "SELECT " db:test-record-qry-selector " FROM tests WHERE testname=? AND item_path=? AND run_id=?;") - test-name item-path run-id) - res)))) + (lambda (dbdat db) + (db:get-test-info-db db run-id test-name item-path)))) + +(define (db:get-test-info-db db run-id test-name item-path) + (let ((res #f)) + (sqlite3:for-each-row + (lambda (a . b) + (set! res (apply vector a b))) + db + (conc "SELECT " db:test-record-qry-selector " FROM tests WHERE testname=? AND item_path=? AND run_id=?;") + test-name item-path run-id) + res)) (define (db:test-get-rundir-from-test-id dbstruct run-id test-id) (db:with-db dbstruct run-id #f - (lambda (db) - (db:first-result-default - db - "SELECT rundir FROM tests WHERE id=?;" - #f ;; default result - test-id)))) - -(define (db:get-test-times dbstruct run-name target) - (let ((res `()) - (qry (conc "select testname, item_path, run_duration, " (string-join (db:get-keys dbstruct) " || '/' || ") " as target from tests inner join runs on tests.run_id = runs.id where runs.runname = ? and target = ? ;"))) - - (db:with-db - dbstruct - #f ;; this is for the main runs db - #f ;; does not modify db - (lambda (db) - (sqlite3:for-each-row - (lambda (test-name item-path test-time target ) - (set! res (cons (vector test-name item-path test-time) res))) - db - qry - run-name target) - res)))) - -(define (db:get-test-times dbstruct run-name target) - (let ((res `()) - (qry (conc "select testname, item_path, run_duration, " (string-join (db:get-keys dbstruct) " || '/' || ") " as target from tests inner join runs on tests.run_id = runs.id where runs.runname = ? and target = ? ;"))) - - (db:with-db - dbstruct - #f ;; this is for the main runs db - #f ;; does not modify db - (lambda (db) + (lambda (dbdat db) + (db:first-result-default + db + "SELECT rundir FROM tests WHERE id=? AND run_id=?;" + #f ;; default result + test-id run-id)))) + +(define (db:get-test-times dbstruct run-name target) + (let ((res `()) + (qry (conc "select testname, item_path, run_duration, " + (string-join (db:get-keys dbstruct) " || '/' || ") + " as target from tests inner join runs on tests.run_id = runs.id where runs.runname = ? and target = ? ;"))) + (db:with-db + dbstruct + #f ;; this is for the main runs db + #f ;; does not modify db + (lambda (dbdat db) (sqlite3:for-each-row (lambda (test-name item-path test-time target ) (set! res (cons (vector test-name item-path test-time) res))) db qry @@ -3651,11 +2904,11 @@ (define (db:teststep-set-status! dbstruct run-id test-id teststep-name state-in status-in comment logfile) (db:with-db dbstruct run-id #t - (lambda (db) + (lambda (dbdat db) (sqlite3:execute db "INSERT OR REPLACE into test_steps (test_id,stepname,state,status,event_time,comment,logfile) VALUES(?,?,?,?,?,?,?);" test-id teststep-name state-in status-in (current-seconds) (if comment comment "") @@ -3667,11 +2920,11 @@ ;; TODO: figure out why status is the key field rather than state (note: CONSTRAINT test_steps_constraint UNIQUE (test_id,stepname,state) ) (db:with-db dbstruct run-id #t - (lambda (db) + (lambda (dbdat db) (sqlite3:execute db "UPDATE test_steps set status='DELETED' where test_id=?" ;; and run_id=? !! - run_id not in table (bummer) TODO: get run_id into schema for test_steps test-id)))) @@ -3680,26 +2933,26 @@ (define (db:get-steps-for-test dbstruct run-id test-id) (db:with-db dbstruct run-id #f - (lambda (db) + (lambda (dbdat db) (let* ((res '())) (sqlite3:for-each-row (lambda (id test-id stepname state status event-time logfile comment) (set! res (cons (vector id test-id stepname state status event-time (if (string? logfile) logfile "") comment) res))) db "SELECT id,test_id,stepname,state,status,event_time,logfile,comment FROM test_steps WHERE status != 'DELETED' AND test_id=? ORDER BY id ASC;" ;; event_time DESC,id ASC; test-id) (reverse res))))) - (define (db:get-steps-info-by-id dbstruct test-step-id) + (define (db:get-steps-info-by-id dbstruct run-id test-step-id) (db:with-db dbstruct - #f + run-id #f - (lambda (db) + (lambda (dbdat db) (let* ((res (vector #f #f #f #f #f #f #f #f #f))) (sqlite3:for-each-row (lambda (id test-id stepname state status event-time logfile comment last-update) (set! res (vector id test-id stepname state status event-time (if (string? logfile) logfile "") comment last-update))) db @@ -3710,11 +2963,11 @@ (define (db:get-steps-data dbstruct run-id test-id) (db:with-db dbstruct run-id #f - (lambda (db) + (lambda (dbdat db) (let ((res '())) (sqlite3:for-each-row (lambda (id test-id stepname state status event-time logfile) (set! res (cons (vector id test-id stepname state status event-time (if (string? logfile) logfile "")) res))) db @@ -3724,18 +2977,18 @@ ;;====================================================================== ;; T E S T D A T A ;;====================================================================== -(define (db:get-data-info-by-id dbstruct test-data-id) +(define (db:get-data-info-by-id dbstruct run-id test-data-id) (let* ((stmt "SELECT id,test_id, category, variable, value, expected, tol, units, comment, status, type, last_update FROM test_data WHERE id=? ORDER BY id ASC;")) ;; event_time DESC,id ASC; (db:with-db dbstruct - #f + run-id #f - (lambda (db) - (let* ((stmth (db:get-cache-stmth dbstruct db stmt)) + (lambda (dbdat db) + (let* ((stmth (db:get-cache-stmth dbdat db stmt)) (res (sqlite3:fold-row (lambda (res id test-id category variable value expected tol units comment status type last-update) (vector id test-id category variable value expected tol units comment status type last-update)) (vector #f #f #f #f #f #f #f #f #f #f #f #f) stmth @@ -3749,24 +3002,24 @@ ;; if one or more are fail (any case) then set test status to PASS, non "pass" or "fail" are ignored (define (db:test-data-rollup dbstruct run-id test-id status) (let* ((fail-count 0) (pass-count 0)) (db:with-db - dbstruct #f #f - (lambda (db) + dbstruct run-id #t + (lambda (dbdat db) (sqlite3:for-each-row (lambda (fcount pcount) (set! fail-count fcount) (set! pass-count pcount)) db "SELECT (SELECT count(id) FROM test_data WHERE test_id=? AND status like 'fail') AS fail_count, (SELECT count(id) FROM test_data WHERE test_id=? AND status like 'pass') AS pass_count;" test-id test-id) ;; Now rollup the counts to the central megatest.db - (db:general-call dbstruct 'pass-fail-counts (list pass-count fail-count test-id)) + (db:general-call dbstruct run-id 'pass-fail-counts (list pass-count fail-count test-id)) ;; if the test is not FAIL then set status based on the fail and pass counts. - (db:general-call dbstruct 'test_data-pf-rollup (list test-id test-id test-id test-id)))))) + (db:general-call dbstruct run-id 'test_data-pf-rollup (list test-id test-id test-id test-id)))))) ;; each section is a rule except "final" which is the final result ;; ;; [rule-5] ;; operator in @@ -3848,12 +3101,12 @@ ;; EOF (define (db:csv->test-data dbstruct run-id test-id csvdata) (debug:print 4 *default-log-port* "test-id " test-id ", csvdata: " csvdata) (db:with-db - dbstruct #f #f - (lambda (db) + dbstruct #f #t + (lambda (dbdat db) (let* ((csvlist (csv->list (make-csv-reader (open-input-string csvdata) '((strip-leading-whitespace? #t) (strip-trailing-whitespace? #t)))))) ;; (csv->list csvdata))) (for-each @@ -3912,25 +3165,25 @@ ;; (define (db:read-test-data dbstruct run-id test-id categorypatt) (let* ((res '())) (db:with-db dbstruct #f #f - (lambda (db) + (lambda (dbdat db) (sqlite3:for-each-row (lambda (id test_id category variable value expected tol units comment status type) (set! res (cons (vector id test_id category variable value expected tol units comment status type) res))) db "SELECT id,test_id,category,variable,value,expected,tol,units,comment,status,type FROM test_data WHERE test_id=? AND category LIKE ? ORDER BY category,variable;" test-id categorypatt) (reverse res))))) ;; This routine moved from tdb.scm, :read-test-data ;; -(define (db:read-test-data* dbstruct run-id test-id categorypatt varpatt) +(define (db:read-test-data-varpatt dbstruct run-id test-id categorypatt varpatt) (let* ((res '())) (db:with-db dbstruct #f #f - (lambda (db) + (lambda (dbdat db) (sqlite3:for-each-row (lambda (id test_id category variable value expected tol units comment status type) (set! res (cons (vector id test_id category variable value expected tol units comment status type) res))) db "SELECT id,test_id,category,variable,value,expected,tol,units,comment,status,type FROM test_data WHERE test_id=? AND category LIKE ? AND variable LIKE ? ORDER BY category,variable;" test-id categorypatt varpatt) @@ -3942,11 +3195,11 @@ ;;====================================================================== (define (db:get-run-ids-matching-target dbstruct keynames target res runname testpatt statepatt statuspatt) (db:with-db dbstruct #f #f - (lambda (db) + (lambda (dbdat db) (let* ((row-ids '()) (keystr (string-intersperse (map (lambda (key val) (conc key " like '" val "'")) keynames @@ -3969,11 +3222,11 @@ (tstsqry (conc "SELECT rundir FROM tests WHERE run_id=? AND " testqry " AND state LIKE '" statepatt "' AND status LIKE '" statuspatt "' ORDER BY event_time ASC;"))) (db:with-db dbstruct run-id #f - (lambda (db) + (lambda (dbdat db) (sqlite3:for-each-row (lambda (p) (set! res (cons p res))) db tstsqry @@ -3983,11 +3236,11 @@ (define (db:test-toplevel-num-items dbstruct run-id testname) (db:with-db dbstruct run-id #f - (lambda (db) + (lambda (dbdat db) (let ((res 0)) (sqlite3:for-each-row (lambda (num-items) (set! res num-items)) db @@ -4034,11 +3287,11 @@ (else msg))) ;; rpc ;; ; This is to be the big daddy call NOPE: Replaced by db:set-state-status-and-roll-up-items ;; ; ;; define (db:test-set-state-status dbstruct run-id test-id state status msg) -;; (let ((dbdat (db:get-db dbstruct run-id))) +;; (let ((dbdat (db:get-subdb dbstruct run-id))) ;; (if (member state '("LAUNCHED" "REMOTEHOSTSTART")) ;; (db:general-call dbdat 'set-test-start-time (list test-id))) ;; ;; (if msg ;; ;; (db:general-call dbdat 'state-status-msg (list state status msg test-id)) ;; ;; (db:general-call dbdat 'state-status (list state status test-id))) @@ -4049,171 +3302,178 @@ ;; (mt:process-triggers dbstruct run-id test-id state status))) ;; state is the priority rollup of all states ;; status is the priority rollup of all completed statesfu ;; -;; if test-name is an integer work off that instead of test-name test-path +;; if test-name is an integer work off that as test-id instead of test-name test-path ;; (define (db:set-state-status-and-roll-up-items dbstruct run-id test-name item-path state status comment) ;; establish info on incoming test followed by info on top level test ;; BBnote - for mode itemwait, linkage between upstream test & matching item status is propagated to run queue in db:prereqs-not-met (let* ((testdat (if (number? test-name) (db:get-test-info-by-id dbstruct run-id test-name) ;; test-name is actually a test-id - (db:get-test-info dbstruct run-id test-name item-path))) + (db:keep-trying-until-true ;; in our threaded stuff this call could happen before the test is registered (maybe?) + db:get-test-info + (list dbstruct run-id test-name item-path) + 10))) (test-id (db:test-get-id testdat)) (test-name (if (number? test-name) (db:test-get-testname testdat) test-name)) (item-path (db:test-get-item-path testdat)) (tl-testdat (db:get-test-info dbstruct run-id test-name "")) (tl-test-id (if tl-testdat (db:test-get-id tl-testdat) - #f))) + #f)) + (new-state-eh #f) + (new-status-eh #f)) (if (member state '("LAUNCHED" "REMOTEHOSTSTART")) - (db:general-call dbstruct 'set-test-start-time (list test-id))) + (db:general-call dbstruct run-id 'set-test-start-time (list test-id))) (mutex-lock! *db-transaction-mutex*) (db:with-db - dbstruct #f #f - (lambda (db) + dbstruct run-id #t + (lambda (dbdat db) (let ((tr-res (sqlite3:with-transaction db (lambda () ;; NB// Pass the db so it is part fo the transaction - (db:test-set-state-status db run-id test-id state status comment) ;; this call sets the item state/status + (db:test-set-state-status-db db run-id test-id state status comment) ;; this call sets the item state/status (if (not (equal? item-path "")) ;; only roll up IF incoming test is an item - (let* ((state-status-counts (db:get-all-state-status-counts-for-test dbstruct run-id test-name item-path state status)) ;; item-path is used to exclude current state/status of THIS test - (state-stauses (db:roll-up-rules state-status-counts state status)) - (newstate (car state-stauses)) - (newstatus (cadr state-stauses))) + (let* ((state-status-counts (db:get-all-state-status-counts-for-test db run-id test-name item-path state status)) ;; item-path is used to exclude current state/status of THIS test + (state-statuses (db:roll-up-rules state-status-counts state status)) + (newstate (car state-statuses)) + (newstatus (cadr state-statuses))) + (set! new-state-eh newstate) + (set! new-status-eh newstatus) (debug:print 4 *default-log-port* "BB> tl-test-id="tl-test-id" ; "test-name":"item-path" newstate="newstate" newstatus="newstatus" len(sscs)="(length state-status-counts) " state-status-counts: " - (apply conc - (map (lambda (x) - (conc - (with-output-to-string (lambda () (pp (dbr:counts->alist x)))) " | ")) - state-status-counts))); end debug:print - - (if tl-test-id - (db:test-set-state-status db run-id tl-test-id newstate newstatus #f)) ;; we are still in the transaction - must access the db and not the dbstruct + (apply conc + (map (lambda (x) + (conc + (with-output-to-string (lambda () (pp (dbr:counts->alist x)))) " | ")) + state-status-counts))); end debug:print + (if tl-test-id + (db:test-set-state-status-db db run-id tl-test-id newstate newstatus #f)) ;; we are still in the transaction - must access the db and not the dbstruct )))))) (mutex-unlock! *db-transaction-mutex*) (if (and test-id state status (equal? status "AUTO")) (db:test-data-rollup dbstruct run-id test-id status)) + (if new-state-eh ;; moved from db:test-set-state-status + (mt:process-triggers dbstruct run-id test-id new-state-eh new-status-eh)) tr-res))))) (define (db:roll-up-rules state-status-counts state status) - (let* ((running (length (filter (lambda (x) - (member (dbr:counts-state x) *common:running-states*)) - state-status-counts))) - (bad-not-started (length (filter (lambda (x) - (and (equal? (dbr:counts-state x) "NOT_STARTED") - (not (member (dbr:counts-status x) *common:not-started-ok-statuses*)))) - state-status-counts))) - (all-curr-states (common:special-sort ;; worst -> best (sort of) - (delete-duplicates - (if (and state (not (member state *common:dont-roll-up-states*))) - (cons state (map dbr:counts-state state-status-counts)) - (map dbr:counts-state state-status-counts))) - *common:std-states* >)) - (all-curr-statuses (common:special-sort ;; worst -> best - (delete-duplicates - (if (and state status (not (member state *common:dont-roll-up-states*))) - (cons status (map dbr:counts-status state-status-counts)) - (map dbr:counts-status state-status-counts))) - *common:std-statuses* >)) - (non-completes (filter (lambda (x) - (not (member x (cons "COMPLETED" *common:dont-roll-up-states*)))) - all-curr-states)) - (preq-fails (filter (lambda (x) - (equal? x "PREQ_FAIL")) - all-curr-statuses)) - (num-non-completes (length non-completes)) - (newstate (cond - ((> running 0) "RUNNING") ;; anything running, call the situation running - ((> (length preq-fails) 0) "NOT_STARTED") - ((> bad-not-started 0) "COMPLETED") ;; we have an ugly situation, it is completed in the sense we cannot do more. - ((> num-non-completes 0) (car non-completes)) ;; (remove (lambda (x)(equal? "COMPLETED" x)) all-curr-states))) ;; only rollup DELETED if all DELETED - (else (car all-curr-states)))) - (newstatus (cond - ((> (length preq-fails) 0) "PREQ_FAIL") - ((or (> bad-not-started 0) - (and (equal? newstate "NOT_STARTED") - (> num-non-completes 0))) - "STARTED") - (else (car all-curr-statuses))))) - (debug:print-info 2 *default-log-port* - "\n--> probe db:set-state-status-and-roll-up-items: " - "\n--> state-status-counts: "(map dbr:counts->alist state-status-counts) - "\n--> running: "running - "\n--> bad-not-started: "bad-not-started - "\n--> non-non-completes: "num-non-completes - "\n--> non-completes: "non-completes - "\n--> all-curr-states: "all-curr-states - "\n--> all-curr-statuses: "all-curr-statuses - "\n--> newstate "newstate - "\n--> newstatus "newstatus - "\n\n") - - ;; NB// Pass the db so it is part of the transaction - (list newstate newstatus))) + (if (null? state-status-counts) + '(#f #f) + (let* ((running (length (filter (lambda (x) + (member (dbr:counts-state x) *common:running-states*)) + state-status-counts))) + (bad-not-started (length (filter (lambda (x) + (and (equal? (dbr:counts-state x) "NOT_STARTED") + (not (member (dbr:counts-status x) *common:not-started-ok-statuses*)))) + state-status-counts))) + (all-curr-states (common:special-sort ;; worst -> best (sort of) + (delete-duplicates + (if (and state (not (member state *common:dont-roll-up-states*))) + (cons state (map dbr:counts-state state-status-counts)) + (map dbr:counts-state state-status-counts))) + *common:std-states* >)) + (all-curr-statuses (common:special-sort ;; worst -> best + (delete-duplicates + (if (and state status (not (member state *common:dont-roll-up-states*))) + (cons status (map dbr:counts-status state-status-counts)) + (map dbr:counts-status state-status-counts))) + *common:std-statuses* >)) + (non-completes (filter (lambda (x) + (not (member x (cons "COMPLETED" *common:dont-roll-up-states*)))) + all-curr-states)) + (preq-fails (filter (lambda (x) + (equal? x "PREQ_FAIL")) + all-curr-statuses)) + (num-non-completes (length non-completes)) + (newstate (cond + ((> running 0) "RUNNING") ;; anything running, call the situation running + ((> (length preq-fails) 0) "NOT_STARTED") + ((> bad-not-started 0) "COMPLETED") ;; we have an ugly situation, it is completed in the sense we cannot do more. + ((> num-non-completes 0) (car non-completes)) ;; (remove (lambda (x)(equal? "COMPLETED" x)) all-curr-states))) ;; only rollup DELETED if all DELETED + (else (car all-curr-states)))) + (newstatus (cond + ((> (length preq-fails) 0) "PREQ_FAIL") + ((or (> bad-not-started 0) + (and (equal? newstate "NOT_STARTED") + (> num-non-completes 0))) + "STARTED") + (else (car all-curr-statuses))))) + (debug:print-info 2 *default-log-port* + "\n--> probe db:set-state-status-and-roll-up-items: " + "\n--> state-status-counts: "(map dbr:counts->alist state-status-counts) + "\n--> running: "running + "\n--> bad-not-started: "bad-not-started + "\n--> non-non-completes: "num-non-completes + "\n--> non-completes: "non-completes + "\n--> all-curr-states: "all-curr-states + "\n--> all-curr-statuses: "all-curr-statuses + "\n--> newstate "newstate + "\n--> newstatus "newstatus + "\n\n") + + ;; NB// Pass the db so it is part of the transaction + (list newstate newstatus)))) (define (db:set-state-status-and-roll-up-run dbstruct run-id curr-state curr-status) (mutex-lock! *db-transaction-mutex*) (db:with-db - dbstruct #f #f - (lambda (db) + dbstruct run-id #t + (lambda (dbdat db) (let ((tr-res (sqlite3:with-transaction db (lambda () - (let* ((state-status-counts (db:get-all-state-status-counts-for-run dbstruct run-id)) - (state-stauses (db:roll-up-rules state-status-counts #f #f )) - (newstate (car state-stauses)) - (newstatus (cadr state-stauses))) - (if (or (not (eq? newstate curr-state)) (not (eq? newstatus curr-status))) - (db:set-run-state-status dbstruct run-id newstate newstatus ))))))) + (let* ((state-status-counts (db:get-all-state-status-counts-for-run-db dbdat db run-id)) + (state-statuses (db:roll-up-rules state-status-counts #f #f )) + (newstate (car state-statuses)) + (newstatus (cadr state-statuses))) + (if (or (not (eq? newstate curr-state)) (not (eq? newstatus curr-status))) + (db:set-run-state-status-db dbdat db run-id newstate newstatus ))))))) (mutex-unlock! *db-transaction-mutex*) tr-res)))) +(define (db:get-all-state-status-counts-for-run-db dbdat db run-id) + (sqlite3:map-row + (lambda (state status count) + (make-dbr:counts state: state status: status count: count)) + (db:get-cache-stmth + dbdat db + "SELECT state,status,count(id) FROM tests WHERE run_id=? GROUP BY state,status;") + run-id )) (define (db:get-all-state-status-counts-for-run dbstruct run-id) - (let* ((test-count-recs (db:with-db - dbstruct #f #f - (lambda (db) - (sqlite3:map-row - (lambda (state status count) - (make-dbr:counts state: state status: status count: count)) - db - "SELECT state,status,count(id) FROM tests WHERE run_id=? GROUP BY state,status;" - run-id ))))) - test-count-recs)) - + (db:with-db + dbstruct #f #f + (lambda (dbdat db) + (db:get-all-state-status-counts-for-run-db dbdat db run-id)))) ;; BBnote: db:get-all-state-status-counts-for-test returns dbr:counts object aggregating state and status of items of a given test, *not including rollup state/status* ;; ;; NOTE: This is called within a transaction ;; -(define (db:get-all-state-status-counts-for-test dbstruct run-id test-name item-path item-state-in item-status-in) - (let* ((test-info (db:get-test-info dbstruct run-id test-name item-path)) +(define (db:get-all-state-status-counts-for-test db run-id test-name item-path item-state-in item-status-in) + (let* ((test-info (db:get-test-info-db db run-id test-name item-path)) (item-state (or item-state-in (db:test-get-state test-info))) (item-status (or item-status-in (db:test-get-status test-info))) - (other-items-count-recs (db:with-db - dbstruct #f #f - (lambda (db) - (sqlite3:map-row - (lambda (state status count) - (make-dbr:counts state: state status: status count: count)) - db - ;; ignore current item because we have changed its value in the current transation so this select will see the old value. - "SELECT state,status,count(id) FROM tests WHERE run_id=? AND testname=? AND item_path != '' AND item_path !=? GROUP BY state,status;" - run-id test-name item-path)))) - + (other-items-count-recs (sqlite3:map-row + (lambda (state status count) + (make-dbr:counts state: state status: status count: count)) + db + ;; ignore current item because we have changed its value in the current transation so this select will see the old value. + "SELECT state,status,count(id) FROM tests WHERE run_id=? AND testname=? AND item_path != '' AND item_path !=? GROUP BY state,status;" + run-id test-name item-path)) ;; add current item to tally outside of sql query - (match-countrec-lambda (lambda (countrec) - (and (equal? (dbr:counts-state countrec) item-state) + (match-countrec-lambda (lambda (countrec) + (and (equal? (dbr:counts-state countrec) item-state) (equal? (dbr:counts-status countrec) item-status)))) - + (already-have-count-rec-list (filter match-countrec-lambda other-items-count-recs)) ;; will have either 0 or 1 count recs depending if another item shares this item's state/status (updated-count-rec (if (null? already-have-count-rec-list) (make-dbr:counts state: item-state status: item-status count: 1) @@ -4223,11 +3483,10 @@ (nonmatch-countrec-lambda (lambda (countrec) (not (match-countrec-lambda countrec)))) (unrelated-rec-list (filter nonmatch-countrec-lambda other-items-count-recs))) - (cons updated-count-rec unrelated-rec-list))) ;; (define (db:get-all-item-states db run-id test-name) ;; (sqlite3:map-row ;; (lambda (a) a) @@ -4245,11 +3504,11 @@ (define (db:test-get-logfile-info dbstruct run-id test-name) (db:with-db dbstruct run-id #f - (lambda (db) + (lambda (dbdat db) (let ((res #f)) (sqlite3:for-each-row (lambda (path final_logf) ;; (let ((path (sdb:qry 'getstr path-id)) ;; (final_logf (sdb:qry 'getstr final_logf-id))) @@ -4419,40 +3678,44 @@ set-verbosity killserver )) (define (db:login dbstruct calling-path calling-version client-signature) - (cond + (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 #t (conc "Login warning due to mismatch megatest version: " calling-version ", " megatest-version))) - (else + + (else (hash-table-set! *logged-in-clients* client-signature (current-seconds)) '(#t "successful login")))) -(define (db:general-call dbstruct stmtname params) +;; NO WAY TO KNOW IF IT MODIFIES THE DB BUT NEARLY ALL ARE UPDATES/INSERTS +;; +(define (db:general-call dbstruct run-id stmtname params) + ;; Why is db:lookup-query above not used here to get the query? (let ((query (let ((q (alist-ref (if (string? stmtname) (string->symbol stmtname) stmtname) db:queries))) (if q (car q) #f)))) (db:with-db - dbstruct #f #f - (lambda (db) + dbstruct run-id #t + (lambda (dbdat db) (apply sqlite3:execute db query params) #t)))) ;; get a summary of state and status counts to calculate a rollup ;; (define (db:get-state-status-summary dbstruct run-id testname) (let ((res '())) (db:with-db - dbstruct #f #f - (lambda (db) + dbstruct run-id #f + (lambda (dbdat db) (sqlite3:for-each-row (lambda (state status count) (set! res (cons (vector state status count) res))) db "SELECT state,status,count(state) FROM tests WHERE run_id=? AND testname=? AND item_path='' GROUP BY state,status;" @@ -4462,11 +3725,11 @@ (define (db:get-latest-host-load dbstruct raw-hostname) (let* ((hostname (string-substitute "\\..*$" "" raw-hostname)) (res (cons -1 0))) (db:with-db dbstruct #f #f - (lambda (db) + (lambda (dbdat db) (sqlite3:for-each-row (lambda (cpuload update-time) (set! res (cons cpuload update-time))) db "SELECT tr.cpuload, tr.update_time FROM test_rundat tr, tests t WHERE t.host=? AND tr.cpuload != -1 AND tr.test_id=t.id ORDER BY tr.update_time DESC LIMIT 1;" hostname))) res )) @@ -4507,11 +3770,11 @@ (keyvals #f) (tests-hash (make-hash-table))) ;; first look up the key values from the run selected by run-id (db:with-db dbstruct #f #f - (lambda (db) + (lambda (dbdat db) (sqlite3:for-each-row (lambda (a . b) (set! keyvals (cons a b))) db (conc "SELECT " selstr " FROM runs WHERE id=? ORDER BY event_time DESC;") run-id))) @@ -4518,11 +3781,11 @@ (if (not keyvals) '() (let ((prev-run-ids '())) (db:with-db dbstruct #f #f - (lambda (db) + (lambda (dbdat db) (apply sqlite3:for-each-row (lambda (id) (set! prev-run-ids (cons id prev-run-ids))) db (conc "SELECT id FROM runs WHERE " qrystr " AND id != ?;") (append keyvals (list run-id))))) @@ -4554,14 +3817,14 @@ ;; Function recursively checks if .journal exists; if yes means db busy; call itself after delayed interval ;; return the sqlite3 db handle if possible ;; (define (db:delay-if-busy dbdat #!key (count 6)) (if (not (configf:lookup *configdat* "server" "delay-on-busy")) - (and dbdat (db:dbdat-get-db dbdat)) + (and dbdat (dbr:dbdat-dbh dbdat)) (if dbdat - (let* ((dbpath (db:dbdat-get-path dbdat)) - (db (db:dbdat-get-db dbdat)) ;; we'll return this so (db:delay--if-busy can be called inline + (let* ((dbpath (dbr:dbdat-dbfile dbdat)) + (db (dbr:dbdat-dbh dbdat)) ;; we'll return this so (db:delay--if-busy can be called inline (dbfj (conc dbpath "-journal"))) (if (handle-exceptions exn (begin (debug:print-info 0 *default-log-port* "WARNING: failed to test for existance of " dbfj ", exn=" exn) @@ -4597,11 +3860,11 @@ (let ((res '())) (db:with-db dbstruct run-id #f - (lambda (db) + (lambda (dbdat db) (sqlite3:for-each-row (lambda (id itempath state status run_duration logf comment) (set! res (cons (vector id itempath state status run_duration logf comment) res))) db "SELECT id,item_path,state,status,run_duration,final_logf,comment FROM tests WHERE testname=? AND item_path != '' AND run_id=?;" ;; BUG! WHY NO run_id? @@ -4616,11 +3879,11 @@ ;; returns a hash table of tags to tests ;; (define (db:get-tests-tags dbstruct) (db:with-db dbstruct #f #f - (lambda (db) + (lambda (dbdat db) (let* ((res (make-hash-table))) (sqlite3:for-each-row (lambda (testname tags-in) (let ((tags (string-split tags-in ","))) (for-each @@ -4631,45 +3894,55 @@ tags))) db "SELECT testname,tags FROM test_meta") (hash-table->alist res))))) +;; testmeta doesn't change, we can cache it for up too an hour + +(define *db:testmeta-cache* (make-hash-table)) +(define *db:testmeta-last-update* 0) + ;; read the record given a testname (define (db:testmeta-get-record dbstruct testname) - (let ((res #f)) - (db:with-db - dbstruct - #f - #f - (lambda (db) - (sqlite3:for-each-row - (lambda (id testname author owner description reviewed iterated avg_runtime avg_disk tags jobgroup) - (set! res (vector id testname author owner description reviewed iterated avg_runtime avg_disk tags jobgroup))) - db - "SELECT id,testname,author,owner,description,reviewed,iterated,avg_runtime,avg_disk,tags,jobgroup FROM test_meta WHERE testname=?;" - testname) - res)))) + (if (and (< (- (current-seconds) *db:testmeta-last-update*) 600) + (hash-table-exists? *db:testmeta-cache* testname)) + (hash-table-ref *db:testmeta-cache* testname) + (let ((res #f)) + (db:with-db + dbstruct + #f + #f + (lambda (dbdat db) + (sqlite3:for-each-row + (lambda (id testname author owner description reviewed iterated avg_runtime avg_disk tags jobgroup) + (set! res (vector id testname author owner description reviewed iterated avg_runtime avg_disk tags jobgroup))) + db + "SELECT id,testname,author,owner,description,reviewed,iterated,avg_runtime,avg_disk,tags,jobgroup FROM test_meta WHERE testname=?;" + testname))) + (hash-table-set! *db:testmeta-cache* testname res) + (set! *db:testmeta-last-update* (current-seconds)) + res))) ;; create a new record for a given testname (define (db:testmeta-add-record dbstruct testname) - (db:with-db dbstruct #f #f - (lambda (db) + (db:with-db dbstruct #f #t + (lambda (dbdat db) (sqlite3:execute db "INSERT OR IGNORE INTO test_meta (testname,author,owner,description,reviewed,iterated,avg_runtime,avg_disk,tags) VALUES (?,'','','','','','','','');" testname)))) ;; update one of the testmeta fields (define (db:testmeta-update-field dbstruct testname field value) - (db:with-db dbstruct #f #f - (lambda (db) + (db:with-db dbstruct #f #t + (lambda (dbdat db) (sqlite3:execute db (conc "UPDATE test_meta SET " field "=? WHERE testname=?;") value testname)))) (define (db:testmeta-get-all dbstruct) (db:with-db dbstruct #f #f - (lambda (db) + (lambda (dbdat db) (let ((res '())) (sqlite3:for-each-row (lambda (a . b) (set! res (cons (apply vector a b) res))) db @@ -4746,11 +4019,11 @@ ;; 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='' is in common:well-ended-states, then prereq is met ;; if prereq test with itempath=ref-item-path and COMPLETED with PASS, WARN, CHECK, or WAIVED then prereq is met ;; ;; Note: mode 'normal means that tests must be COMPLETED and ok (i.e. PASS, WARN, CHECK, SKIP or WAIVED) ;; mode 'toplevel means that tests must be COMPLETED only ;; mode 'itemmatch or 'itemwait means that tests items must be COMPLETED and (PASS|WARN|WAIVED|CHECK) [[ NB// NOT IMPLEMENTED YET ]] @@ -4761,10 +4034,11 @@ ;; 2. any NOT completed and good? if yes => return those as prereqs not met, if no => return null list ;; ;; (define (db:get-prereqs-not-met dbstruct run-id waitons ref-item-path mode) (define (db:get-prereqs-not-met dbstruct run-id waitons ref-test-name ref-item-path mode itemmaps) ;; #!key (mode '(normal))(itemmap #f)) ;; BBnote - rollup of an itemized test's overall state/status done in db:set-state-status-and-roll-up-items + (debug:print 4 *default-log-port* "db:get-prereqs-not-met: " waitons) (append (if (member 'exclusive mode) (let ((running-tests (db:get-tests-for-run dbstruct #f ;; run-id of #f means for all runs. (if (string=? ref-item-path "") ;; testpatt @@ -4787,10 +4061,12 @@ ;; (conc (db:test-get-testname testdat) ;; "/" ;; (db:test-get-item-path testdat)))) running-tests) ;; calling functions want the entire data '()) + + ;; collection of: for each waiton - ;; if this ref-test-name is an item in an itemized test and mode is itemwait/itemmatch: ;; if waiton is not itemized - if waiton is not both completed and in ok status, add as unmet prerequisite ;; if waiton is itemized: @@ -4913,51 +4189,122 @@ (delete-duplicates result))))) ;;====================================================================== ;; To sync individual run ;;====================================================================== -(define (db:get-run-record-ids dbstruct target run keynames test-patt) -(let ((backcons (lambda (lst item)(cons item lst)))) - (db:with-db - dbstruct #f #f - (lambda (db) - (let* ((keystr (string-intersperse - (map (lambda (key val) +(define (db:get-run-record-ids dbstruct target run keynames) + (let* ((backcons (lambda (lst item)(cons item lst))) + (all_tests '()) + (keystr (string-intersperse + (map (lambda (key val) (conc key " like '" val "'")) - keynames - (string-split target "/")) - " AND ")) + keynames + (string-split target "/")) + " AND ") + ) (run-qry (conc "SELECT id FROM runs WHERE " keystr " and runname='" run"'")) - (test-qry (conc "SELECT id FROM tests WHERE run_id in (" run-qry ") and testname like '" test-patt "'"))) - (print run-qry) - (print test-qry) - `((runs . ,(sqlite3:fold-row backcons '() db run-qry)) - (tests . ,(sqlite3:fold-row backcons '() db test-qry)) - (test_steps . ,(sqlite3:fold-row backcons '() db (conc "SELECT id FROM test_steps WHERE test_id in (" test-qry ")"))) - (test_data . ,(sqlite3:fold-row backcons '() db (conc "SELECT id FROM test_data WHERE test_id in (" test-qry ")" ))) - )))))) + ; (test-qry (conc "SELECT id FROM tests WHERE run_id in (" run-qry ") and testname like '" test-patt "'")) + (run_ids + (db:with-db dbstruct #f #f + (lambda (dbdat db) + (sqlite3:fold-row backcons '() db run-qry)) + ) + ) + ) + run_ids) +) ;;====================================================================== ;; Just for sync, procedures to make sync easy ;;====================================================================== -;; get an alist of record ids changed since time since-time -;; '((runs . (1 2 3 ...))(steps . (5 6 7 ...) ...)) +;; get an alist of run ids and test/run, test_step/run pairs changed since time since-time +;; '((runs . (1 2 3 ...))(tests . ((5 . 1) (6 . 3) (6 . 2) (7 . 1) ... + +;; Retrieves record IDs from the database based on the timestamp of their last update. + +;; The function takes two arguments: dbstruct, which represents the database structure, and since-time, which is a timestamp indicating the time of the last update. +;; The function first defines a few helper functions, including backcons, which takes a list and an item and adds the item to the front of the list. +;; It then initializes several variables to empty lists: all_tests, all_test_steps, all_test_data, all_run_ids, and all_test_ids. +;; The function then retrieves a list of IDs for runs that have been changed since since-time using the db:get-changed-run-ids function. +;; It then filters the full list of run IDs to only include those that match the changed run IDs based on their modulo (num-run-dbs). +;; For each changed run ID, the function retrieves a list of test IDs, test step IDs, and test data IDs that have been updated since since-time. +;; It appends these IDs to the appropriate lists (all_tests, all_test_steps, and all_test_data) using the append and map functions. +;; The function then retrieves a list of run stat IDs that have been updated since since-time. +;; Finally, the function returns a list of associations between record types and their corresponding IDs: runs, tests, test_steps, test_data, and run_stats. ;; (define (db:get-changed-record-ids dbstruct since-time) ;; no transaction, allow the db to be accessed between the big queries - (let ((backcons (lambda (lst item)(cons item lst)))) - (db:with-db - dbstruct #f #f - (lambda (db) - `((runs . ,(sqlite3:fold-row backcons '() db "SELECT id FROM runs WHERE last_update>=?" since-time)) - (tests . ,(sqlite3:fold-row backcons '() db "SELECT id FROM tests WHERE last_update>=?" since-time)) - (test_steps . ,(sqlite3:fold-row backcons '() db "SELECT id FROM test_steps WHERE last_update>=?" since-time)) - (test_data . ,(sqlite3:fold-row backcons '() db "SELECT id FROM test_data WHERE last_update>=?" since-time)) - ;; (test_meta . ,(fold-row backcons '() db "SELECT id FROM test_meta WHERE last_update>?" since-time)) - (run_stats . ,(sqlite3:fold-row backcons '() db "SELECT id FROM run_stats WHERE last_update>=?" since-time)) - ))))) + (let* ((backcons (lambda (lst item)(cons item lst))) + (all_tests '()) + (changed_run_dbs (db:get-changed-run-ids since-time)) ;; gets the rundb numbers + (all_run_ids + (db:with-db dbstruct #f #f + (lambda (dbdat db) + (sqlite3:fold-row backcons '() db "SELECT id FROM runs")) + ) + ) + (changed_run_ids (filter (lambda (run) (member (modulo run (num-run-dbs)) changed_run_dbs)) all_run_ids)) + (run_ids + (db:with-db dbstruct #f #f + (lambda (dbdat db) + (sqlite3:fold-row backcons '() db "SELECT id FROM runs WHERE last_update>=?" since-time)) + ) + ) + ) + (for-each + (lambda (run_id) + (set! all_tests + (append + (map (lambda (x) (cons x run_id)) + (db:with-db dbstruct run_id #f + (lambda (dbdat db) + (sqlite3:fold-row backcons '() db "SELECT id FROM tests WHERE run_id=? and last_update>=?" run_id since-time) + ) + ) + ) all_tests + ) + ) + ) + changed_run_ids + ) + (debug:print 2 *default-log-port* "run_ids = " run_ids) + (debug:print 2 *default-log-port* "all_tests = " all_tests) + + `((runs . ,run_ids) + (tests . ,all_tests) + ) + ) +) + + + +(define (db:get-changed-record-test-ids dbstruct since-time run-id) + (let* ((backcons (lambda (lst item)(cons item lst))) + (all-tests (db:with-db dbstruct run-id #f + (lambda (dbdat db) + (sqlite3:fold-row backcons '() db "SELECT id FROM tests WHERE run_id=? and last_update>=?" run-id since-time))))) + + all-tests)) + +(define (db:get-changed-record-run-ids dbstruct since-time) + ;; no transaction, allow the db to be accessed between the big queries + (let* ((backcons (lambda (lst item)(cons item lst))) + (run_ids (db:with-db dbstruct #f #f + (lambda (dbdat db) + (sqlite3:fold-row backcons '() db "SELECT id FROM runs WHERE last_update>=?" since-time))))) + (debug:print 2 *default-log-port* "run_ids = " run_ids) + run_ids) +) + +(define (db:get-all-runids dbstruct) + (let* ((backcons (lambda (lst item)(cons item lst))) + (all_run_ids (db:with-db dbstruct #f #f + (lambda (dbdat db) + (sqlite3:fold-row backcons '() db "SELECT id FROM runs"))))) + +all_run_ids)) ;;====================================================================== ;; Extract ods file from the db ;;====================================================================== @@ -4964,16 +4311,17 @@ ;; NOT REWRITTEN YET!!!!! ;; runspatt is a comma delimited list of run patterns ;; keypatt-alist must contain *all* keys with an associated pattern: '( ("KEY1" "%") .. ) (define (db:extract-ods-file dbstruct outputfile keypatt-alist runspatt pathmod) + (assert #f "FATAL: call to db:extract-ods-file which is not ported yet.") (let* ((keysstr (string-intersperse (map car keypatt-alist) ",")) (keyqry (string-intersperse (map (lambda (p)(conc (car p) " LIKE ? ")) keypatt-alist) " AND ")) (numkeys (length keypatt-alist)) (test-ids '()) - (dbdat (db:get-db dbstruct)) - (db (db:dbdat-get-db dbdat)) + (dbdat (db:get-subdb dbstruct)) + (db (dbr:dbdat-dbh dbdat)) (windows (and pathmod (substring-index "\\" pathmod))) (tempdir (conc "/tmp/" (current-user-name) "/" runspatt "_" (random 10000) "_" (current-process-id))) (runsheader (append (list "Run Id" "Runname") ; 0 1 (map car keypatt-alist) ; + N = length keypatt-alist (list "Testname" ; 2 @@ -5080,11 +4428,342 @@ (begin (debug:print 0 *default-log-port* "WARNING: path given, " outputfile " is relative, prefixing with current directory") (conc (current-directory) "/" outputfile))) results) ;; brutal clean up - (stack-push! (dbr:dbstruct-dbstack dbstruct) dbdat) + (dbfile:add-dbdat dbstruct #f dbdat) (system "rm -rf tempdir"))) ;; (db:extract-ods-file db "outputfile.ods" '(("sysname" "%")("fsname" "%")("datapath" "%")) "%") +;;====================================================================== +;; moving watch dogs here due to dependencies +;;====================================================================== + +;;====================================================================== +;; currently the primary job of the watchdog is to run the sync back to megatest.db from the db in /tmp +;; if we are on the homehost and we are a server (by definition we are on the homehost if we are a server) +;; +(define (common:readonly-watchdog dbstruct) + (thread-sleep! 0.05) ;; delay for startup + (debug:print-info 13 *default-log-port* "common:readonly-watchdog entered.") + ;; sync megatest.db to /tmp/.../megatst.db + (let* ((sync-cool-off-duration 3) + (golden-mtdb (dbr:dbstruct-mtdb dbstruct)) + (golden-mtpath (db:dbdat-get-path golden-mtdb)) + (tmp-mtdb (dbr:dbstruct-tmpdb dbstruct)) + (tmp-mtpath (db:dbdat-get-path tmp-mtdb))) + (debug:print-info 0 *default-log-port* "Read-only periodic sync thread started.") + (let loop ((last-sync-time 0)) + (debug:print-info 13 *default-log-port* "loop top tmp-mtpath="tmp-mtpath" golden-mtpath="golden-mtpath) + (let* ((duration-since-last-sync (- (current-seconds) last-sync-time))) + (debug:print-info 13 *default-log-port* "duration-since-last-sync="duration-since-last-sync) + (if (and (not *time-to-exit*) + (< duration-since-last-sync sync-cool-off-duration)) + (thread-sleep! (- sync-cool-off-duration duration-since-last-sync))) + (if (not *time-to-exit*) + (let ((golden-mtdb-mtime (file-modification-time golden-mtpath)) + (tmp-mtdb-mtime (file-modification-time tmp-mtpath))) + (if (> golden-mtdb-mtime tmp-mtdb-mtime) + (if (< golden-mtdb-mtime (- (current-seconds) 3)) ;; file has NOT been touched in past three seconds, this way multiple servers won't fight to sync back + (let ((res (db:multi-db-sync dbstruct 'old2new))) + (debug:print-info 13 *default-log-port* "rosync called, " res " records transferred.")))) + (loop (current-seconds))) + #t))) + (debug:print-info 0 *default-log-port* "Exiting readonly-watchdog timer, *time-to-exit* = " *time-to-exit*" pid="(current-process-id)" mtpath="golden-mtpath))) + + +;; Get a lock from the no-sync-db for the from-db, then copy the from-db to the to-db, otherwise return #f + +(define (db:lock-and-sync no-sync-db from-db to-db) + (assert (not *db-sync-in-progress*) "FATAL: db:lock-and-sync called while a sync is in progress.") + (let* ((lockdat (db:no-sync-get-lock no-sync-db from-db)) + (gotlock (car lockdat)) + (locktime (cdr lockdat))) + (if gotlock + (begin + (file-copy from-db to-db #t) + (db:no-sync-del! no-sync-db from-db) + #t) + (begin + (debug:print 0 *default-log-port* "could not get lock for " from-db " from no-sync-db") + #f + )))) + +;; sync for filesystem local db writes +;; +(define (db:run-lock-and-sync no-sync-db) + (let* ((tmp-area (common:make-tmpdir-name *toppath* "")) + (dbfiles (glob (conc tmp-area"/.mtdb/*.db"))) + (sync-durations (make-hash-table))) + ;; (debug:print-info 0 *default-log-port* "lock-and-sync, dbfiles: "dbfiles) + (for-each + (lambda (file) + (let* ((fname (conc (pathname-file file) ".db")) + (fulln (conc *toppath*"/.mtdb/"fname)) + (time1 (if (file-exists? file) + (file-modification-time file) + (begin + (debug:print-info 0 *default-log-port* "Sync - I do not see file "file) + 1))) + (time2 (if (file-exists? fulln) + (file-modification-time fulln) + (begin + (debug:print-info 0 *default-log-port* "Sync - I do not see file "fulln) + 0))) + (changed (> time1 time2)) + (do-cp (cond + ((not (file-exists? fulln)) ;; shouldn't happen, but this might recover + (debug:print-info 0 *default-log-port* "File "fulln" not found! Copying "fname" to "fulln) + #t) + (changed ;; (and changed + ;; (> (- (current-seconds) time1) 3)) ;; if file is changed and three seconds have passed. + #t) + ((and changed *time-to-exit*) ;; last copy + #t) + (else + #f)))) + (if do-cp + (let* ((start-time (current-milliseconds))) + (debug:print-info 0 *default-log-port* "sync copy file: " fname", delta: " (- time1 time2) " seconds") + (db:lock-and-sync no-sync-db file fulln) + (hash-table-set! sync-durations (conc fname".db") (- (current-milliseconds) start-time))) + #;(debug:print-info 0 *default-log-port* "skipping sync...")))) + dbfiles) + (hash-table->alist sync-durations))) + +;; straight forward copy based sync +;; 1. for each .db fil +;; 2. next if file changed since last sync cycle +;; 2. next if time delta /tmp file to MTRA less than 3 seconds +;; 3. get a lock for the file in nosyncdb +;; 4. copy the file +;; 5. when copy is done release the lock +;; +;; DONE +(define (server:writable-watchdog-copysync dbstruct) + (thread-sleep! 0.05) ;; delay for startup + (let ((legacy-sync (common:run-sync?)) + (sync-stale-seconds (configf:lookup-number *configdat* "server" "sync-stale-seconds" default: 300)) + (debug-mode (debug:debug-mode 1)) + (last-time (current-seconds)) ;; last time through the sync loop + (no-sync-db (db:open-no-sync-db)) + (sync-duration 0) ;; run time of the sync in milliseconds + (tmp-area (common:make-tmpdir-name *toppath* ""))) + ;; Sync moved to http-transport keep-running loop + (debug:print-info 2 *default-log-port* "Periodic copy-based sync thread started. syncer is copy-sync, tmp-area is " tmp-area) + (debug:print-info 3 *default-log-port* "watchdog starting. syncer is copy-sync pid="(current-process-id));; " this-wd-num="this-wd-num) + + (if (and legacy-sync (not *time-to-exit*)) + (begin + (debug:print-info 0 *default-log-port* "Server running, periodic copy-based sync started.") + (let loop () + + ;; run the sync and print out durations + (debug:print-info 0 *default-log-port* "Sync durations: "(db:run-lock-and-sync no-sync-db)) + ;; keep going unless time to exit + ;; + (if (not *time-to-exit*) + (let delay-loop ((count 0)) + ;;(debug:print-info 13 *default-log-port* "delay-loop top; count="count" pid="(current-process-id)" this-wd-num="this-wd-num" *time-to-exit*="*time-to-exit*) + + (if (and (not *time-to-exit*) + (< count 6)) ;; was 11, changing to 4. + (begin + (thread-sleep! 1) + (delay-loop (+ count 1)))) + (if (not *time-to-exit*) (loop)))) + + ;; ==> ;; time to exit, close the no-sync db here + ;; ==> (db:no-sync-close-db no-sync-db stmt-cache) + (if (common:low-noise-print 30) + (debug:print-info 0 *default-log-port* "Exiting watchdog timer, *time-to-exit* = " + *time-to-exit*" pid="(current-process-id) ))))))) + +(define (server:writable-watchdog-deltasync dbstruct) + ;; This is awful complex and convoluted. Plan to redo? + ;; for now ... skip it. + + (thread-sleep! 0.05) ;; delay for startup + (let ((legacy-sync (common:run-sync?))) + (sync-stale-seconds (configf:lookup-number *configdat* "server" "sync-stale-seconds" default: 300)) + (debug-mode (debug:debug-mode 1)) + (last-time (current-seconds)) + (no-sync-db (db:open-no-sync-db)) + (stmt-cache #f) ;; (dbr:dbstruct-stmt-cache dbstruct)) + (sync-duration 0) ;; run time of the sync in milliseconds + (subdbs (hash-table-values (dbr:dbstruct-subdbs dbstruct)))) + (debug:print-info 2 *default-log-port* "Periodic sync thread started.") + (debug:print-info 3 *default-log-port* "watchdog starting. legacy-sync is " legacy-sync" pid="(current-process-id) );; " this-wd-num="this-wd-num) + + (if (and legacy-sync (not *time-to-exit*)) + (begin + (debug:print-info 0 *default-log-port* "Server running, periodic sync started.") + (let loop () + ;; sync for filesystem local db writes + ;; + (mutex-lock! *db-multi-sync-mutex*) + (let* ((start-file (conc tmp-area "/.start-sync")) + (end-file (conc tmp-area "/.end-sync")) + + (need-sync (>= *db-last-access* *db-last-sync*)) ;; no sync since last write + (sync-in-progress *db-sync-in-progress*) + (min-intersync-delay (configf:lookup-number *configdat* "server" "minimum-intersync-delay" default: 5)) + (should-sync (and (not *time-to-exit*) + (> (- (current-seconds) *db-last-sync*) min-intersync-delay))) ;; sync every five seconds minimum, deprecated logic, can probably be removed + (start-time (current-seconds)) + (cpu-load-adj (alist-ref 'adj-proc-load (common:get-normalized-cpu-load #f))) + (mt-mod-time (file-modification-time mtpath)) + (last-sync-start (if (common:file-exists? start-file) + (file-modification-time start-file) + 0)) + (last-sync-end (if (common:file-exists? end-file) + (file-modification-time end-file) + 10)) + (sync-period (+ 3 (* cpu-load-adj 30))) ;; as adjusted load increases increase the sync period + (recently-synced (and (< (- start-time mt-mod-time) sync-period) ;; not useful if sync didn't modify megatest.db! + (< mt-mod-time last-sync-start))) + (sync-done (<= last-sync-start last-sync-end)) + (sync-stale (> start-time (+ last-sync-start sync-stale-seconds))) + (will-sync (and (not *time-to-exit*) ;; do not start a sync if we are in the process of exiting + (or need-sync should-sync) + (or sync-done sync-stale) + (not sync-in-progress) + (not recently-synced)))) + (debug:print-info 13 *default-log-port* "WD writable-watchdog top of loop. need-sync="need-sync" sync-in-progress=" sync-in-progress + " should-sync="should-sync" start-time="start-time" mt-mod-time="mt-mod-time" recently-synced="recently-synced" will-sync="will-sync + " sync-done=" sync-done " sync-period=" sync-period) + (if (and (> sync-period 5) + (common:low-noise-print 30 "sync-period")) + (debug:print-info 0 *default-log-port* "Increased sync period due to long sync times, sync took: " sync-period " seconds.")) + ;; (if recently-synced (debug:print-info 0 *default-log-port* "Skipping sync due to recently-synced flag=" recently-synced)) + ;; (debug:print-info 0 *default-log-port* "need-sync: " need-sync " sync-in-progress: " sync-in-progress " should-sync: " should-sync " will-sync: " will-sync) + (if will-sync (set! *db-sync-in-progress* #t)) + (mutex-unlock! *db-multi-sync-mutex*) + (if will-sync + (let (;; (max-sync-duration (configf:lookup-number *configdat* "server" "max-sync-duration")) ;; KEEPING THIS AVAILABLE BUT SHOULD NOT USE, I'M PRETTY SURE IT DOES NOT WORK! + (sync-start (current-milliseconds))) + (with-output-to-file start-file (lambda ()(print (current-process-id)))) + + ;; put lock here + + ;; (if (or (not max-sync-duration) + ;; (< sync-duration max-sync-duration)) ;; NOTE: db:sync-to-megatest.db keeps track of time of last sync and syncs incrementally + + ;; + + (for-each + (lambda (subdb) + (let* (;;(dbstruct (db:setup)) + (mtdb (dbr:subdb-mtdb subdb)) + (mtpath (db:dbdat-get-path mtdb)) + (tmp-area (common:make-tmpdir-name *toppath* "")) + (res (db:sync-to-megatest.db dbstruct no-sync-db: no-sync-db))) ;; did we sync any data? If so need to set the db touched flag to keep the server alive + (set! sync-duration (- (current-milliseconds) sync-start)) + (if (> res 0) ;; some records were transferred, keep the db alive + (begin + (mutex-lock! *heartbeat-mutex*) + (set! *db-last-access* (current-seconds)) + (mutex-unlock! *heartbeat-mutex*) + (debug:print-info 0 *default-log-port* "sync called, " res " records transferred.")) + (debug:print-info 2 *default-log-port* "sync called but zero records transferred"))) + ) + subdbs))) + + (if will-sync + (begin + (mutex-lock! *db-multi-sync-mutex*) + (set! *db-sync-in-progress* #f) + (set! *db-last-sync* start-time) + (with-output-to-file end-file (lambda ()(print (current-process-id)))) + + ;; release lock here + + (mutex-unlock! *db-multi-sync-mutex*))) + (if (and debug-mode + (> (- start-time last-time) 60)) + (begin + (set! last-time start-time) + (debug:print-info 4 *default-log-port* "timestamp -> " (seconds->time-string (current-seconds)) ", time since start -> " (seconds->hr-min-sec (- (current-seconds) *time-zero*)))))) + + ;; keep going unless time to exit + ;; + (if (not *time-to-exit*) + (let delay-loop ((count 0)) + ;;(debug:print-info 13 *default-log-port* "delay-loop top; count="count" pid="(current-process-id)" this-wd-num="this-wd-num" *time-to-exit*="*time-to-exit*) + + (if (and (not *time-to-exit*) + (< count 6)) ;; was 11, changing to 4. + (begin + (thread-sleep! 1) + (delay-loop (+ count 1)))) + (if (not *time-to-exit*) (loop)))) + +;; ;; time to exit, close the no-sync db here +;; (db:no-sync-close-db no-sync-db stmt-cache) + (if (common:low-noise-print 30) + (debug:print-info 0 *default-log-port* "Exiting watchdog timer, *time-to-exit* = " *time-to-exit*" pid="(current-process-id) )))) +)) + +(define (std-exit-procedure) + ;;(common:telemetry-log-close) + (on-exit (lambda () 0)) ;; why is this here? + ;;(debug:print-info 13 *default-log-port* "std-exit-procedure called; *time-to-exit*="*time-to-exit*) + (let ((no-hurry (if *time-to-exit* ;; hurry up + #f + (begin + (set! *time-to-exit* #t) + #t)))) + (debug:print-info 4 *default-log-port* "starting exit process, finalizing databases.") + (if (and no-hurry + (debug:debug-mode 18)) + (rmt:print-db-stats)) + (let ((th1 (make-thread (lambda () ;; thread for cleaning up, give it five seconds + (if *dbstruct-dbs* (db:close-all *dbstruct-dbs*)) ;; one second allocated + (if (list? *on-exit-procs*) + (for-each + (lambda (proc) + (proc)) + *on-exit-procs*)) + (if *task-db* + (let ((db (cdr *task-db*))) + (if (sqlite3:database? db) + (begin + (sqlite3:interrupt! db) + (sqlite3:finalize! db #t) + ;; (vector-set! *task-db* 0 #f) + (set! *task-db* #f))))) + (if (and *no-sync-db* + (sqlite3:database? *no-sync-db*)) + (sqlite3:finalize! *no-sync-db* #t)) + (if (and (not (args:get-arg "-server")) + *runremote* + (eq? (rmt:transport-mode) 'http)) + (begin + (debug:print-info 0 *default-log-port* "Closing all client connections...") + (http-transport:close-connections *runremote*) + #;(http-client#close-all-connections!))) + ;; (if (and *runremote* + ;; (remote-conndat *runremote*)) + ;; (begin + ;; (http-client#close-all-connections!))) ;; for http-client + (if (not (eq? *default-log-port* (current-error-port))) + (close-output-port *default-log-port*)) + (set! *default-log-port* (current-error-port))) "Cleanup db exit thread")) + (th2 (make-thread (lambda () + (debug:print 4 *default-log-port* "Attempting clean exit. Please be patient and wait a few seconds...") + (if no-hurry + (begin + (thread-sleep! 5)) ;; give the clean up few seconds to do it's stuff + (begin + (thread-sleep! 2))) + (debug:print 4 *default-log-port* " ... done") + ) + "clean exit"))) + (thread-start! th1) + (thread-start! th2) + (thread-join! th1) + ) + ) + + 0) Index: db_records.scm ================================================================== --- db_records.scm +++ db_records.scm @@ -16,76 +16,10 @@ ;; along with Megatest. If not, see . ;;====================================================================== ;; dbstruct ;;====================================================================== - -;; -;; -path-|-megatest.db -;; |-db-|-main.db -;; |-monitor.db -;; |-sdb.db -;; |-fdb.db -;; |-1.db -;; |-.db -;; -;; -;; Accessors for a dbstruct -;; - -;; (define-inline (dbr:dbstruct-main vec) (vector-ref vec 0)) ;; ( db path ) -;; (define-inline (dbr:dbstruct-strdb vec) (vector-ref vec 1)) ;; ( db path ) -;; (define-inline (dbr:dbstruct-path vec) (vector-ref vec 2)) -;; (define-inline (dbr:dbstruct-local vec) (vector-ref vec 3)) -;; (define-inline (dbr:dbstruct-rundb vec) (vector-ref vec 4)) ;; ( db path ) -;; (define-inline (dbr:dbstruct-inmem vec) (vector-ref vec 5)) ;; ( db #f ) -;; (define-inline (dbr:dbstruct-mtime vec) (vector-ref vec 6)) -;; (define-inline (dbr:dbstruct-rtime vec) (vector-ref vec 7)) -;; (define-inline (dbr:dbstruct-stime vec) (vector-ref vec 8)) -;; (define-inline (dbr:dbstruct-inuse vec) (vector-ref vec 9)) -;; (define-inline (dbr:dbstruct-refdb vec) (vector-ref vec 10)) ;; ( db path ) -;; (define-inline (dbr:dbstruct-locdbs vec) (vector-ref vec 11)) -;; (define-inline (dbr:dbstruct-olddb vec) (vector-ref vec 12)) ;; ( db path ) -;; ;; (define-inline (dbr:dbstruct-main-path vec) (vector-ref vec 13)) -;; ;; (define-inline (dbr:dbstruct-rundb-path vec) (vector-ref vec 14)) -;; ;; (define-inline (dbr:dbstruct-run-id vec) (vector-ref vec 13)) -;; -;; (define-inline (dbr:dbstruct-main-set! vec val)(vector-set! vec 0 val)) -;; (define-inline (dbr:dbstruct-strdb-set! vec val)(vector-set! vec 1 val)) -;; (define-inline (dbr:dbstruct-path-set! vec val)(vector-set! vec 2 val)) -;; (define-inline (dbr:dbstruct-local-set! vec val)(vector-set! vec 3 val)) -;; (define-inline (dbr:dbstruct-rundb-set! vec val)(vector-set! vec 4 val)) -;; (define-inline (dbr:dbstruct-inmem-set! vec val)(vector-set! vec 5 val)) -;; (define-inline (dbr:dbstruct-mtime-set! vec val)(vector-set! vec 6 val)) -;; (define-inline (dbr:dbstruct-rtime-set! vec val)(vector-set! vec 7 val)) -;; (define-inline (dbr:dbstruct-stime-set! vec val)(vector-set! vec 8 val)) -;; (define-inline (dbr:dbstruct-inuse-set! vec val)(vector-set! vec 9 val)) -;; (define-inline (dbr:dbstruct-refdb-set! vec val)(vector-set! vec 10 val)) -;; (define-inline (dbr:dbstruct-locdbs-set! vec val)(vector-set! vec 11 val)) -;; (define-inline (dbr:dbstruct-olddb-set! vec val)(vector-set! vec 12 val)) -;; (define-inline (dbr:dbstruct-main-path-set! vec val)(vector-set! vec 13 val)) -;; (define-inline (dbr:dbstruct-rundb-path-set! vec val)(vector-set! vec 14 val)) -;; -; (define-inline (dbr:dbstruct-run-id-set! vec val)(vector-set! vec 13 val)) - -;; constructor for dbstruct -;; -;; (define (make-dbr:dbstruct #!key (path #f)(local #f)) -;; (let ((v (make-vector 15 #f))) -;; (dbr:dbstruct-path-set! v path) -;; (dbr:dbstruct-local-set! v local) -;; (dbr:dbstruct-locdbs-set! v (make-hash-table)) -;; v)) - -;; Returns the database for a particular run-id fron the dbstruct:localdbs -;; -(define (dbr:dbstruct-localdb v run-id) - (hash-table-ref/default (dbr:dbstruct-locdbs v) run-id #f)) - -(define (dbr:dbstruct-localdb-set! v run-id db) - (hash-table-set! (dbr:dbstruct-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)) ADDED dbfile.scm Index: dbfile.scm ================================================================== --- /dev/null +++ dbfile.scm @@ -0,0 +1,1668 @@ +;;====================================================================== +;; Copyright 2017, Matthew Welland. +;; +;; This file is part of Megatest. +;; +;; Megatest is free software: you can redistribute it and/or modify +;; it under the terms of the GNU General Public License as published by +;; the Free Software Foundation, either version 3 of the License, or +;; (at your option) any later version. +;; +;; Megatest is distributed in the hope that it will be useful, +;; but WITHOUT ANY WARRANTY; without even the implied warranty of +;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +;; GNU General Public License for more details. +;; +;; You should have received a copy of the GNU General Public License +;; along with Megatest. If not, see . + +;;====================================================================== + +(use srfi-18 posix hostinfo) + +(declare (unit dbfile)) +(declare (uses debugprint)) +(declare (uses commonmod)) + +(module dbfile + * +(import scheme) + +(cond-expand + (chicken-4 + + (import chicken + data-structures + extras + matchable + + (prefix sqlite3 sqlite3:) + posix posix-extras typed-records + + srfi-18 + srfi-1 + srfi-69 + stack + files + ports + hostinfo + + commonmod + debugprint + ) + ) + (chicken-5 + (import (prefix sqlite3 sqlite3:) + ;; data-structures + ;; extras + ;; files + ;; posix + ;; posix-extras + chicken.base + chicken.condition + chicken.file + chicken.file.posix + chicken.format + chicken.io + chicken.pathname + chicken.port + chicken.process + chicken.process-context + chicken.process-context.posix + chicken.sort + chicken.string + chicken.time + chicken.time.posix + + matchable + md5 + message-digest + pathname-expand + regex + regex-case + srfi-1 + srfi-18 + srfi-69 + typed-records + stack + system-information + + commonmod + debugprint + ) + (define file-write-access? file-writable?) + (define file-move move-file) + )) + +;; parameters +;; +(define dbfile:testsuite-name (make-parameter #f)) + +(define keep-age-param (make-parameter 10)) ;; qif file age, if over move to attic +(define num-run-dbs (make-parameter 10)) ;; number of db's in .mtdb +(define dbfile:sync-method (make-parameter 'attach)) ;; 'attach or 'original +(define dbfile:cache-method (make-parameter 'cachedb)) ;; 'direct +(define dbcache-mode (make-parameter 'tmp)) ;; 'cachedb, 'tmp (changes what open cachedb routine does) + +;; moved from tcp-transportmod so that it can be used in launch.scm +(define tt-server-profile-string (make-parameter "")) + +;; 'original - use old condition code +;; 'suicide-mode - create mtrah/stop-the-train with info on what went wrong +;; else use no condition code (should be production mode) +;; +(define no-condition-db-with-db (make-parameter 'suicide-mode)) + +;;====================================================================== +;; R E C O R D S +;;====================================================================== + +;; a single Megatest area with it's multiple dbs is +;; managed in a dbstruct +;; +(defstruct dbr:dbstruct + (areapath #f) + (homehost #f) + (tmppath #f) + (read-only #f) + (subdbs (make-hash-table)) + ;; + ;; for the cachedb approach (see dbmod.scm) + ;; this is one db per server + (cachedb #f) ;; handle for the in memory copy + (dbfile #f) ;; path to the db file on disk + (dbfname #f) ;; short name of db file on disk (used to validate accessing correct db) + (ondiskdb #f) ;; handle for the on-disk file + (dbtmpname #f) ;; path to db file in /tmp (non-imem method) + (dbdat #f) ;; create a dbdat for the downstream calls such as db:with-db + (last-update 0) + (sync-proc #f) + ) + +;; NOTE: Need one dbr:subdb per main.db, 1.db ... +;; +(defstruct dbr:subdb + (dbname #f) ;; .mtdb/1.db + (mtdbfile #f) ;; mtrah/.mtdb/1.db + (mtdbdat #f) ;; only need one of these for syncing + ;; (dbdats (make-hash-table)) ;; id => dbdat + (tmpdbfile #f) ;; /tmp/.../.mtdb/1.db + ;; (refndbfile #f) ;; /tmp/.../.mtdb/1.db_ref + (dbstack (make-stack)) ;; stack for tmp dbr:dbdat, + (homehost #f) ;; not used yet + (on-homehost #f) ;; not used yet + (read-only #f) + (last-sync 0) + (last-write (current-seconds)) + ) ;; goal is to converge on one struct for an area but for now it is too confusing + +;; need to keep dbhandles and cached statements together +(defstruct dbr:dbdat + (dbfile #f) + (dbh #f) + (stmt-cache (make-hash-table)) + (read-only #f) + (birth-sec (current-seconds))) + +;; used in simple-get-runs (thanks Brandon!) +(define-record simple-run target id runname state status owner event_time) +(define-record-printer (simple-run x out) + (fprintf out "#,(simple-run ~S ~S ~S ~S)" + (simple-run-target x) (simple-run-id x) (simple-run-runname x) (time->string (seconds->local-time (simple-run-event_time x) )))) + +;; args is hash table of string to value +;; +(define (get-purpose args) + (let* ((get-arg (lambda (key) + (hash-table-ref/default args key #f))) + (get-switch (lambda keys + (fold + (lambda (key res) + (if (hash-table-ref/default args key #f) + (or key res) + res)) + #f + keys))) + (action (get-switch "-server" "-execute" "-run" "-rerun"))) + (cond + (action + (substring action 1 (string-length action))) + (else + "nopurpose")))) + +;; megatest process tracking + +(defstruct procinf + (start (current-seconds)) + (end -1) + (host (get-host-name)) ;; why is this not being recognised? + (pid (current-process-id)) + (port -1) + (cwd (current-directory)) + (load #f) + (purpose #f) ;; get-purpose needed to be run in megatest.scm + (dbname #f) + (mtbin (car (argv))) + (mtversion #f) + (status "running") + + + ) + +(define *procinf* (make-procinf)) +(define *dbstruct-dbs* #f) +(define *db-open-mutex* (make-mutex)) +(define *db-access-mutex* (make-mutex)) ;; used in common.scm +(define *no-sync-db* #f) +(define *db-sync-in-progress* #f) +(define *db-with-db-mutex* (make-mutex)) +(define *max-api-process-requests* 0) +(define *api-process-request-count* 0) +(define *db-write-access* #t) +(define *db-last-sync* 0) ;; last time the sync to megatest.db happened +(define *db-multi-sync-mutex* (make-mutex)) ;; protect access to *db-sync-in-progress*, *db-last-sync* +(define *db-last-access* (current-seconds)) + +(define *db-transaction-mutex* (make-mutex)) + +(define (db:generic-error-printout exn . message) + (print-call-chain (current-error-port)) + (apply dbfile:print-err message) + (dbfile:print-err + ", error: " ((condition-property-accessor 'exn 'message) exn) + ", arguments: " ((condition-property-accessor 'exn 'arguments) exn) + ", location: " ((condition-property-accessor 'exn 'location) exn) + )) + +(define (dbfile:run-id->key run-id) + (or run-id 'main)) + +(define (db:safely-close-sqlite3-db db stmt-cache #!key (try-num 3)) + (if (<= try-num 0) + #f + (handle-exceptions + exn + (begin + (print "Attempt to safely close sqlite3 db failed. Trying again. exn=" exn) + (thread-sleep! 3) + (sqlite3:interrupt! db) + (db:safely-close-sqlite3-db db stmt-cache try-num: (- try-num 1))) + (if (sqlite3:database? db) + (let* ((stmts (and stmt-cache (hash-table-ref/default stmt-cache db #f)))) + (if stmts (map sqlite3:finalize! (hash-table-values stmts))) + (sqlite3:finalize! db) + #t) + (begin + (dbfile:print-err "db:safely-close-sqlite3-db: " db " is not an sqlite3 db") + #f + ) + )))) + +;; close all opened run-id dbs +(define (db:close-all dbstruct) + (if (dbr:dbstruct? dbstruct) +;; (handle-exceptions +;; exn +;; (begin +;; (debug:print 0 *default-log-port* "WARNING: Finalizing failed, " ((condition-property-accessor 'exn 'message) exn) ", note - exn=" exn) +;; (print-call-chain *default-log-port*)) + ;; (db:sync-touched dbstruct 0 force-sync: #t) ;; NO. Do not do this here. Instead we rely on a server to be started when there are writes, even if the server itself is not going to be used as a server. + (let* ((subdbs (hash-table-values (dbr:dbstruct-subdbs dbstruct)))) + (for-each + (lambda (subdb) + (let* ((tdbs (stack->list (dbr:subdb-dbstack subdb))) + (mtdbdat (dbr:dbdat-dbh (dbr:subdb-mtdbdat subdb))) + #;(rdb (dbr:dbdat-dbh (dbr:subdb-refndb subdb)))) + + (map (lambda (dbdat) + (let* ((stmt-cache (dbr:dbdat-stmt-cache dbdat)) + (dbh (dbr:dbdat-dbh dbdat))) + (db:safely-close-sqlite3-db dbh stmt-cache))) + tdbs) + (db:safely-close-sqlite3-db mtdbdat (dbr:dbdat-stmt-cache (dbr:subdb-mtdbdat subdb))) + ;; (if (sqlite3:database? mdb) (sqlite3:finalize! mdb)) + #;(db:safely-close-sqlite3-db rdb #f))) ;; stmt-cache))))) ;; (if (sqlite3:database? rdb) (sqlite3:finalize! rdb)))))) + subdbs) + #t + ) + #f + ) +) + +(define (dbfile:make-tmpdir-name areapath tmpadj) + (let* ((area (pathname-file areapath)) + (dname (conc "/tmp/"(current-user-name)"/megatest_localdb/" area "/" (string-translate areapath "/" ".") tmpadj "/.mtdb"))) + (unless (directory-exists? dname) + (create-directory dname #t)) + dname)) + +(define (dbfile:run-id->path apath run-id) + (conc apath"/"(dbfile:run-id->dbname run-id))) + +(define (db:dbname->path apath dbname) + (conc apath"/"dbname)) + +(define (dbfile:run-id->dbnum run-id) + (cond + ((number? run-id) + (modulo run-id (num-run-dbs))) + ((not run-id) "main") ;; 0 or main? No, not 0. + (else + (assert #f "FATAL: run-id is required to be a number or #f")))) + +;; just the filename +(define (dbfile:run-id->dbfname run-id) + (conc (dbfile:run-id->dbnum run-id)".db")) + +;; the path in MTRAH with the filename +(define (dbfile:run-id->dbname run-id) + (conc (dbfile:run-id->dbfname run-id))) + + +;; Make the dbstruct, setup up auxillary db's and call for main db at least once +;; +;; called in http-transport and replicated in rmt.scm for *local* access. +;; +(define (dbfile:setup areapath tmppath) + (cond + (*dbstruct-dbs* + (dbfile:print-err "WARNING: dbfile:setup called when *dbstruct-dbs* is already initialized") + *dbstruct-dbs*) ;; TODO: when multiple areas are supported, this optimization will be a hazard + (else + (let* ((dbstruct (make-dbr:dbstruct areapath: areapath tmppath: tmppath))) + (set! *dbstruct-dbs* dbstruct) + dbstruct)))) + +(define (dbfile:get-subdb dbstruct run-id) + (let* ((dbfname (dbfile:run-id->dbname run-id))) + (hash-table-ref/default (dbr:dbstruct-subdbs dbstruct) dbfname #f))) + +(define (dbfile:set-subdb dbstruct run-id subdb) + (hash-table-set! (dbr:dbstruct-subdbs dbstruct) (dbfile:run-id->dbname run-id) subdb)) + +;; (define *dbfile:num-handles-in-use* 0) + +;; Get/open a database. +;; +;; NOTE: most usage should call dbfile:open-db to get a dbdat +;; +;; if run-id => get run specific db +;; if #f => get main db +;; if run-id is a string treat it as a filename - DON'T use this - we'll get rid of it. +;; if db already open - return cachedb +;; if db not open, open cachedb, rundb and sync then return cachedb +;; inuse gets set automatically for rundb's +;; +(define (dbfile:get-dbdat dbstruct run-id) + (let* ((subdb (dbfile:get-subdb dbstruct run-id))) + (if (stack-empty? (dbr:subdb-dbstack subdb)) + #f + (begin + (stack-pop! (dbr:subdb-dbstack subdb)))))) + +;; return a previously opened db handle to the stack of available handles +(define (dbfile:add-dbdat dbstruct run-id dbdat) + (let* ((subdb (dbfile:get-subdb dbstruct run-id)) + (dbstk (dbr:subdb-dbstack subdb)) + (count (stack-count dbstk))) + (if (> count 15) + (dbfile:print-err "WARNING: stack for "run-id".db is "count".")) + (stack-push! dbstk dbdat) + dbdat)) + +;; set up a subdb +;; +(define (dbfile:init-subdb dbstruct run-id init-proc) + (let* ((dbname (dbfile:run-id->dbname run-id)) + (areapath (dbr:dbstruct-areapath dbstruct)) + (tmppath (dbr:dbstruct-tmppath dbstruct)) + (mtdbpath (dbfile:run-id->path areapath run-id)) + (tmpdbpath (dbfile:run-id->path tmppath run-id)) + (mtdbdat (dbfile:open-sqlite3-db mtdbpath init-proc sync-mode: 0 journal-mode: #f)) ;; "WAL")) + (newsubdb (make-dbr:subdb dbname: dbname + mtdbfile: mtdbpath + tmpdbfile: tmpdbpath + mtdbdat: mtdbdat))) + (dbfile:set-subdb dbstruct run-id newsubdb) + newsubdb)) ;; return the new subdb - but shouldn't really use it + +;; returns dbdat with dbh and dbfilepath +;; +;; NOTE: the handle is on /tmp db file! +;; +;; 1. if needed setup the subdb for the given run-id +;; 2. if there is no existing db handle in the stack +;; create a new handle and return it (do NOT add +;; it to the stack). +;; +(define (dbfile:open-db dbstruct run-id init-proc) + (let* ((subdb (dbfile:get-subdb dbstruct run-id))) + (if (not subdb) ;; not yet defined + (begin + (dbfile:init-subdb dbstruct run-id init-proc) + (dbfile:open-db dbstruct run-id init-proc)) + (let* ((dbdat (dbfile:get-dbdat dbstruct run-id))) + (if dbdat + dbdat + (let* ((tmppath (dbr:dbstruct-tmppath dbstruct)) + (tmpdbpath (dbfile:run-id->path tmppath run-id)) + (dbdat (dbfile:open-sqlite3-db tmpdbpath init-proc sync-mode: 0 journal-mode: "WAL"))) + + ;; the following line short-circuits the "one db handle per thread" model + ;; + ;; (dbfile:add-dbdat dbstruct run-id dbdat) + ;; + dbdat)))))) + +;; COMBINE dbfile:open-sqlite-db and dbfile:lock-create-open +;; + +;; this stuff is for initial debugging, please remove it when +;; this code stabilizes +(define *dbopens* (make-hash-table)) +(define (dbfile:inc-db-open dbfile) + (let* ((curr-opens-count (+ (hash-table-ref/default *dbopens* dbfile 0) 1))) + (if (and (> curr-opens-count 1) ;; this should NOT be happening + (common:low-noise-print 15 "db-opens")) + (dbfile:print-err "INFO: db "dbfile" has been opened "curr-opens-count" times!")) + (hash-table-set! *dbopens* dbfile curr-opens-count) + curr-opens-count)) + +;; Open the classic megatest.db file (defaults to open in toppath) +;; +;; NOTE: returns a dbdat not a dbstruct! +;; +(define (dbfile:open-sqlite3-db dbpath init-proc #!key (sync-mode 0)(journal-mode #f)) + (let* ((dbexists (file-exists? dbpath)) + (write-access (file-write-access? dbpath)) + (db (dbfile:cautious-open-database dbpath init-proc sync-mode journal-mode))) + (dbfile:inc-db-open dbpath) + ;; (init-proc db) + (make-dbr:dbdat dbfile: dbpath dbh: db read-only: (not write-access)))) + +(define (dbfile:print-and-exit . params) + (with-output-to-port + (current-error-port) + (lambda () + (apply print params))) + (exit 1)) + +(define (dbfile:print-err . params) + (with-output-to-port + (current-error-port) + (lambda () + (apply print params)))) + +(define (dbfile:cautious-open-database fname init-proc sync-mode journal-mode + #!key (tries-left 500)(force-init #f)) + (let* ((busy-file (conc fname "-journal")) + (delay-time (* (- 51 tries-left) 1.1)) + (write-access (file-write-access? fname)) + (dir-access (file-write-access? (pathname-directory fname))) + (retry (lambda () + (thread-sleep! delay-time) + (if (> tries-left 0) + (dbfile:cautious-open-database fname init-proc + sync-mode journal-mode + tries-left: (- tries-left 1)))))) + (assert (>= tries-left 0) (conc "FATAL: too many attempts in dbfile:cautious-open-database of "fname", giving up.")) + + (if (and (file-write-access? fname) + (file-exists? busy-file)) + (begin + (if (common:low-noise-print 120 busy-file) + (dbfile:print-err "INFO: dbfile:cautious-open-database: journal file " + busy-file" exists, trying again in few seconds.")) + (thread-sleep! 1) + (if (eq? tries-left 2) + (begin + (dbfile:print-err "INFO: forcing journal rollup "busy-file) + (dbfile:brute-force-salvage-db fname))) + (dbfile:cautious-open-database fname init-proc sync-mode journal-mode tries-left: (- tries-left 1))) + + (let* ((result (condition-case + (if dir-access + (dbfile:with-simple-file-lock + (conc fname ".lock") + (lambda () + (let* ((db-exists (file-exists? fname)) + (db (sqlite3:open-database fname))) ;; creates an empty db if it did not already exist. + (sqlite3:set-busy-handler! db (sqlite3:make-busy-timeout 30000)) + (if sync-mode + (sqlite3:execute db (conc "PRAGMA synchronous = "sync-mode";"))) + (if journal-mode + (sqlite3:execute db (conc "PRAGMA journal_mode = "journal-mode";"))) + (if (and init-proc (or force-init + (not db-exists))) + (init-proc db)) + db)) + expire-time: 30) + (begin + (if (file-exists? fname ) + (let ((db (sqlite3:open-database fname))) + ;; pragmas synchronous not needed because this db is used read-only + ;; (sqlite3:execute db (conc "PRAGMA synchronous = "mode";") + (sqlite3:set-busy-handler! db (sqlite3:make-busy-timeout 30000)) ;; read-only but still need timeout + db ) + (print "cautious-open-database: file doesn't exist: " fname)))) + (exn (io-error) + (dbfile:print-err exn "ERROR: i/o error with " fname ". Check permissions, disk space etc. and try again.") + (retry)) + (exn (corrupt) + (dbfile:print-err exn "ERROR: database " fname " is corrupt. Repair it to proceed.") + (retry)) + (exn (busy) + (dbfile:print-err exn "ERROR: database " fname + " is locked. Try copying to another location, remove original and copy back.") + (retry)) + (exn (permission)(dbfile:print-err exn "ERROR: database " fname " has some permissions problem.") + (retry)) + (exn () + (dbfile:print-err exn "ERROR: Unknown error with database " fname " message: " + ((condition-property-accessor 'exn 'message) exn)) + (retry))))) + result)))) + +(define (dbfile:brute-force-salvage-db fname) + (let* ((backupfname (conc fname"-"(current-process-id)".bak")) + (cmd (conc "cp "fname" "backupfname";mv "fname" "(conc fname ".delme;") + "cp "backupfname" "fname))) + (dbfile:print-err "WARNING: attempting recovery of file "fname" by running commands:\n" + " "cmd) + (system cmd))) + +;; opens and returns handle and nothing else +;; +;; NOTE: this is already protected by mutex *no-sync-db-mutex* +;; +(define (dbfile:raw-open-no-sync-db dbpath) + (if (not (file-exists? dbpath)) + (create-directory dbpath #t)) + (debug:print-info 2 *default-log-port* "(dbfile:raw-open-no-sync-db: Opening "dbpath"/no-sync.db") + (let* ((dbname (conc dbpath "/no-sync.db")) + (db-exists (file-exists? dbname)) + (init-proc (lambda (db) + (sqlite3:with-transaction + db + (lambda () + ;; I have been having trouble with init of no-sync.db so + ;; doing the init in a transaction every time (no gating + ;; on file existance. + (for-each + (lambda (stmt) + (sqlite3:execute db stmt)) + (list + "CREATE TABLE IF NOT EXISTS jobs_queue + (id INTEGER PRIMARY KEY, + host_type TEXT, + cores INTEGER, + memory TEXT, + vars TEXT, + exekey TEXT, + cmdline TEXT, + state TEXT, + event_time INTEGER, + last_update INTEGER);" + "CREATE TABLE IF NOT EXISTS test_extra_data + (id INTEGER PRIMARY KEY, + run_id INTEGER, + test_id INTEGER, + last_seen_running INTEGER);" + "CREATE TABLE IF NOT EXISTS no_sync_metadat + (var TEXT, + val TEXT, + CONSTRAINT no_sync_metadat_constraint UNIQUE (var));" + "CREATE TABLE IF NOT EXISTS no_sync_locks + (key TEXT, + val TEXT, + CONSTRAINT no_sync_metadat_constraint UNIQUE (key));" + "CREATE TABLE IF NOT EXISTS processes + (id INTEGER PRIMARY KEY, + host TEXT, + port INTEGER, + pid INTEGER, + starttime INTEGER, + endtime INTEGER, + status TEXT, + purpose TEXT, + dbname TEXT, + mtversion TEXT, + reason TEXT DEFAULT 'none', + CONSTRAINT no_sync_processes UNIQUE (host,pid));" + )))))) + (on-tmp (equal? (car (string-split dbpath "/")) "tmp")) + (db (if on-tmp + (dbfile:cautious-open-database dbname init-proc 1 "WAL" force-init: #t) ;; WAL MODE should use syncronous=1 + ;; (dbfile:cautious-open-database dbname init-proc 0 #f force-init: #t) + (dbfile:cautious-open-database dbname init-proc 0 "MEMORY" force-init: #t) ;; Journal mode = memory is fastest? + ;; (sqlite3:open-database dbname) + ))) + ;; (if on-tmp ;; done in cautious-open-database + ;; (begin + ;; (sqlite3:execute db "PRAGMA synchronous = 0;") ;; why was this here when is is handled by cautious-open-database? + (sqlite3:set-busy-handler! db (sqlite3:make-busy-timeout 136000)) ;; )) + db)) + +;; mtest processes registry calls + +(define (dbfile:insert-or-update-process nsdb dat) + (let* ((host (procinf-host dat)) + (pid (procinf-pid dat)) + (curr-info (dbfile:get-process-info nsdb host pid))) + (if curr-info ;; record exists, do update + (match curr-info + ((host port pid starttime endtime status purpose dbname mtversion) + (sqlite3:execute + nsdb + "UPDATE processes SET port=?,starttime=?,endtime=?,status=?, + purpose=?,dbname=?,mtversion=? + WHERE host=? AND pid=?;" + (or (procinf-port dat) port) + (or (procinf-start dat) starttime) + (or (procinf-end dat) endtime) + (or (procinf-status dat) status) + (or (procinf-purpose dat) purpose) + (or (procinf-dbname dat) dbname) + (or (procinf-mtversion dat) mtversion) + host pid)) + (else + #f ;; what to do? + )) + (dbfile:register-process + nsdb + (procinf-host dat) + (procinf-port dat) + (procinf-pid dat) + (procinf-start dat) + (procinf-end dat) + (procinf-status dat) + (procinf-purpose dat) + (procinf-dbname dat) + (procinf-mtversion dat))))) + + +(define (dbfile:register-process nsdb host port pid starttime endtime status purpose dbname mtversion) + (sqlite3:execute nsdb "INSERT INTO processes (host,port,pid,starttime,endtime,status,purpose,dbname,mtversion) VALUES (?,?,?,?,?,?,?,?,?);" + host port pid starttime endtime status purpose dbname mtversion)) + +(define (dbfile:set-process-status nsdb host pid newstatus) + (sqlite3:execute nsdb "UPDATE processes SET status=? WHERE host=? AND pid=?;" newstatus host pid)) + +;; as sorted should be stable. can use to choose "winner" +;; +(define (dbfile:get-process-options nsdb purpose dbname) + (sqlite3:fold-row + ;; host port pid starttime status mtversion + (lambda (res . row) + (cons row res)) + '() + nsdb + "SELECT host,port,pid,starttime,endtime,status,mtversion FROM processes WHERE purpose=? AND dbname LIKE ? AND status IN ('running','alive') ORDER BY starttime ASC,host,port;" + purpose dbname)) + +(define (dbfile:get-process-info nsdb host pid) + (let ((res (sqlite3:fold-row + ;; host port pid starttime status mtversion + (lambda (res . row) + (cons row res)) + '() + nsdb + "SELECT host,port,pid,starttime,endtime,status,purpose,dbname,mtversion FROM processes WHERE host=? AND pid=?;" + host pid))) + (if (null? res) + #f + (car res)))) + +(define (dbfile:row->procinf row) + (match row + ((host port pid starttime endtime status mtversion) + (make-procinf host: host port: port pid: pid starttime: starttime endtime: endtime status: status mtversion: mtversion)) + (else + (debug:print 0 *default-log-port* "ERROR: row "row" did not match host,port,pid,starttime,endtime,status,mtversion") + #f))) + +(define (dbfile:set-process-done nsdb host pid reason) + (sqlite3:execute nsdb "UPDATE processes SET status='done',endtime=?,reason=? WHERE host=? AND pid=?;" (current-seconds) reason host pid) + (dbfile:cleanup-old-entries nsdb)) + +(define (dbfile:cleanup-old-entries nsdb) + (sqlite3:execute nsdb "DELETE FROM process WHERE status='done' AND endtimenumber res) + #f))) + (if newres + newres + res)) + res))) + +;; timestring+identifier+payload +;; locks are unique on identifier, payload is informational +(define (db:extract-time-identifier instr) + (let ((tokens (string-split instr "+"))) + (match tokens + ((t i)(cons (string->number t) i)) + ((t) (cons (string->number t) #f)) + (else + (assert #f "FATAL: db:extract-time-identifier handed bad data "instr))))) + +;; transaction protected lock aquisition +;; either: +;; fails returns (#f lock-creation-time identifier) +;; succeeds (returns (#t lock-creation-time identifier) +;; use (db:no-sync-del! db keyname) to release the lock +;; +(define (db:no-sync-get-lock-with-id db keyname identifier) + (debug:print 2 *default-log-port* "db:no-sync-get-lock-with-id: db: " db " keyname: " keyname " identifier: " identifier) + (sqlite3:with-transaction + db + (lambda () + (condition-case + (let* ((curr-val (db:no-sync-get/default db keyname #f))) + (debug:print 2 *default-log-port* "db:no-sync-get-lock-with-id: curr-val: " curr-val) + (if curr-val + (match (db:extract-time-identifier curr-val) ;; result->timestamp, identifier + ((timestamp . ident) + (cons (equal? ident identifier) timestamp)) + (else + (debug:print 2 *default-log-port* "db:no-sync-get-lock-with-id: malformed lock") + (cons #f 'malformed-lock) + ) + ) ;; lock malformed + (let ((curr-sec (current-seconds)) + (lock-value (if identifier + (conc (current-seconds)"+"identifier) + (current-seconds)))) + (sqlite3:execute db "INSERT OR REPLACE INTO no_sync_metadat (var,val) VALUES(?,?);" keyname lock-value) + (cons #t curr-sec)))) + (exn (io-error) (dbfile:print-err "ERROR: i/o error with no-sync db. Check permissions, disk space etc. and try again.")) + (exn (corrupt) (dbfile:print-err "ERROR: database no-sync db is corrupt. Repair it to proceed.")) + (exn (busy) (dbfile:print-err "ERROR: database no-sync db is locked. Try copying to another location, remove original and copy back.")) + (exn (permission)(dbfile:print-err "ERROR: database no-sync db has some permissions problem.")) + (exn () ;; (status done) ;; I don't know how to detect status done but no data! + (dbfile:print-err "ERROR: Unknown error with database no-sync db message: exn="(condition->list exn)", \n" + ((condition-property-accessor 'exn 'message) exn)) + (cons #f #f)))))) + +(define (db:no-sync-check-lock db keyname identifier) + (let* ((curr-val (db:no-sync-get/default db keyname #f))) + (match (db:extract-time-identifier curr-val) ;; result->timestamp, identifier + ((timestamp . ident) + (cons (equal? ident identifier) ident)) + (else (cons #f 'no-lock))))) + +;; get the lock, wait 0.25 seconds and verify still have it. +;; this should not be necessary given the use of transaction in +;; db:no-sync-get-lock-with-id but it does seem to be needed +;; +(define (db:no-sync-lock-and-check db keyname identifier) + (let* ((result (db:no-sync-get-lock-with-id db keyname identifier)) + (gotlock (car result))) + (if gotlock + (begin + (thread-sleep! 0.25) + (db:no-sync-check-lock db keyname identifier)) + result))) + +;; transaction protected lock aquisition +;; either: +;; fails returns (#f . lock-creation-time) +;; succeeds (returns (#t . lock-creation-time) +;; use (db:no-sync-del! db keyname) to release the lock +;; +(define (db:no-sync-get-lock db keyname) + (sqlite3:with-transaction + db + (lambda () + (condition-case + (let* ((curr-val (db:no-sync-get/default db keyname #f))) + (if curr-val + `(#f . ,curr-val) ;; (sqlite3:first-result db "SELECT val FROM no_sync_metadat WHERE var=?;" keyname)) + (let ((lock-time (current-seconds))) + (sqlite3:execute db "INSERT OR REPLACE INTO no_sync_metadat (var,val) VALUES(?,?);" keyname lock-time) + `(#t . ,lock-time)))) + (exn (io-error) (dbfile:print-err "ERROR: i/o error with no-sync db. Check permissions, disk space etc. and try again.")) + (exn (corrupt) (dbfile:print-err "ERROR: database no-sync db is corrupt. Repair it to proceed.")) + (exn (busy) (dbfile:print-err "ERROR: database no-sync db is locked. Try copying to another location, remove original and copy back.")) + (exn (permission)(dbfile:print-err "ERROR: database no-sync db has some permissions problem.")) + (exn () ;; (status done) ;; I don't know how to detect status done but no data! + (dbfile:print-err "ERROR: Unknown error with database no-sync db message: exn="(condition->list exn)", \n" + ((condition-property-accessor 'exn 'message) exn)) + `(#f . ,(current-seconds))))))) + +(define (db:no-sync-get-lock-timeout db keyname timeout) + (let* ((lockdat (db:no-sync-get-lock db keyname))) + (match lockdat + ((#f . lock-time) + (if (> (- (current-seconds) (if (string? lock-time)(string->number lock-time)lock-time)) timeout) + (let ((lock-time (current-seconds))) + ;; (debug:print-info 2 *default-log-port* "db:no-sync-get-lock keyname=" keyname ", lock-time=" lock-time ", exn=" exn) + (sqlite3:execute db "INSERT OR REPLACE INTO no_sync_metadat (var,val) VALUES(?,?);" keyname lock-time) + `(#t . ,lock-time)) + lockdat)) + (else lockdat)))) + +;; NOTE: This will steal the lock after timeout of waiting. +;; +(define (db:with-no-sync-lock db keyname timeout proc) + (let* ((lockdat (db:no-sync-get-lock-timeout db keyname)) + (gotlock (car lockdat)) + (locktime (cdr lockdat))) + (if gotlock + (let ((res (proc))) + (db:no-sync-del! db keyname) + res)))) + +;;====================================================================== +;; sync back functions pulled from db.scm +;;====================================================================== + +;; Get a lock from the no-sync-db for the from-db, then delta sync the from-db to the to-db, otherwise return #f +;; +(define (db:lock-and-delta-sync no-sync-db dbstruct from-db-file runid keys dbinit) + (assert (not *db-sync-in-progress*) "FATAL: db:lock-and-sync called while a sync is in progress.") + ;; (dbfile:print-err *default-log-port* "db:lock-and-delta-sync") + (let* ((lock-file (conc from-db-file ".lock"))) + (if (common:simple-file-lock lock-file) + (begin + (dbfile:print-err "INFO: db:lock-and-delta-sync copying db "runid" at "(current-seconds)) + (set! *db-sync-in-progress* #t) + (db:sync-touched dbstruct runid keys dbinit) + (set! *db-sync-in-progress* #f) + (delete-file* lock-file) + #t) + (begin + (if (common:low-noise-print 120 (conc "no lock "from-db-file)) + (dbfile:print-err "INFO: could not get lock for " from-db-file ", sync likely in progress.")) + #f + )))) + +;; ;; Get a lock from the no-sync-db for the from-db, then delta sync the from-db to the to-db, otherwise return #f +;; ;; +;; (define (db:lock-and-delta-sync-orig no-sync-db dbstruct from-db-file runid keys dbinit) +;; (assert (not *db-sync-in-progress*) "FATAL: db:lock-and-sync called while a sync is in progress.") +;; ;; (dbfile:print-err *default-log-port* "db:lock-and-delta-sync") +;; (let* ((lockdat (db:no-sync-get-lock-timeout no-sync-db from-db-file 60)) +;; (gotlock (car lockdat)) +;; (locktime (cdr lockdat))) +;; ;; (debug:print-info 3 *default-log-port* "db:lock-and-delta-sync: got lock?") +;; +;; (if gotlock +;; (begin +;; (dbfile:print-err "INFO: db:lock-and-delta-sync copying db "runid" at "(current-seconds)) +;; (set! *db-sync-in-progress* #t) +;; (db:sync-touched dbstruct runid keys dbinit) +;; (set! *db-sync-in-progress* #f) +;; (db:no-sync-del! no-sync-db from-db-file) +;; #t) +;; (begin +;; (dbfile:print-err "ERROR: could not get lock for " from-db-file " from no-sync-db") +;; #f +;; )))) + +;; sync run from tmp disk to nfs disk if touched +;; +;; call with dbinit=db:initialize-main-db +;; +(define (db:sync-touched dbstruct run-id keys #!key dbinit (force-sync #f)) + (dbfile:print-err "db:sync-touched Syncing: " (conc (if run-id run-id "main") ".db")) + (let* (;; the subdb is needed to access the mtdbdat + (subdb (or (dbfile:get-subdb dbstruct run-id) + (dbfile:init-subdb dbstruct run-id dbinit))) + (tmpdbfile (dbr:subdb-tmpdbfile subdb)) + (mtdb (dbr:subdb-mtdbdat subdb)) + (tmpdb (db:open-db dbstruct run-id dbinit)) ;; sqlite3-db tmpdbfile #f)) + (start-t (current-seconds))) + (mutex-lock! *db-multi-sync-mutex*) + (let ((update_info (cons "last_update" (if force-sync 0 *db-last-sync*) ))) + (mutex-unlock! *db-multi-sync-mutex*) + (db:sync-tables (db:sync-all-tables-list keys) update_info tmpdb mtdb)) + (mutex-lock! *db-multi-sync-mutex*) + (set! *db-last-sync* start-t) + (set! *db-last-access* start-t) + (mutex-unlock! *db-multi-sync-mutex*) + (dbfile:add-dbdat dbstruct run-id tmpdb) + #t)) + +;; just tests, test_steps and test_data tables +(define db:sync-tests-only + (list + ;; (list "strs" + ;; '("id" #f) + ;; '("str" #f)) + (list "tests" + '("id" #f) + '("run_id" #f) + '("testname" #f) + '("host" #f) + '("cpuload" #f) + '("diskfree" #f) + '("uname" #f) + '("rundir" #f) + '("shortdir" #f) + '("item_path" #f) + '("state" #f) + '("status" #f) + '("attemptnum" #f) + '("final_logf" #f) + '("logdat" #f) + '("run_duration" #f) + '("comment" #f) + '("event_time" #f) + '("fail_count" #f) + '("pass_count" #f) + '("archived" #f) + '("last_update" #f)) + (list "test_steps" + '("id" #f) + '("test_id" #f) + '("stepname" #f) + '("state" #f) + '("status" #f) + '("event_time" #f) + '("comment" #f) + '("logfile" #f) + '("last_update" #f)) + (list "test_data" + '("id" #f) + '("test_id" #f) + '("category" #f) + '("variable" #f) + '("value" #f) + '("expected" #f) + '("tol" #f) + '("units" #f) + '("comment" #f) + '("status" #f) + '("type" #f) + '("last_update" #f)))) + +;; needs db to get keys, this is for syncing all tables +;; +(define (db:sync-main-list keys) + (let ((keys keys)) + (list + (list "keys" + '("id" #f) + '("fieldname" #f) + '("fieldtype" #f)) + (list "metadat" '("var" #f) '("val" #f)) + (append (list "runs" + '("id" #f)) + (map (lambda (k)(list k #f)) + (append keys + (list "runname" "state" "status" "owner" "event_time" "comment" "fail_count" "pass_count" "contour" "last_update")))) + (list "archive_disks" + '("id" #f) + '("archive_area_name" #f) + '("disk_path" #f) + '("last_df" #f) + '("last_df_time" #f) + '("creation_time" #f)) + + (list "archive_blocks" + '("id" #f) + '("archive_disk_id" #f) + '("disk_path" #f) + '("last_du" #f) + '("last_du_time" #f) + '("creation_time" #f)) + + (list "test_meta" + '("id" #f) + '("testname" #f) + '("owner" #f) + '("description" #f) + '("reviewed" #f) + '("iterated" #f) + '("avg_runtime" #f) + '("avg_disk" #f) + '("tags" #f) + '("jobgroup" #f)) + + + (list "tasks_queue" + '("id" #f) + '("action" #f) + '("owner" #f) + '("state" #f) + '("target" #f) + '("name" #f) + '("testpatt" #f) + '("keylock" #f) + '("params" #f) + '("creation_time" #f) + '("execution_time" #f)) + ))) + +(define (db:sync-all-tables-list keys) + (append (db:sync-main-list keys) + db:sync-tests-only)) + +;; tbls is ( ("tablename" ( "field1" [#f|proc1] ) ( "field2" [#f|proc2] ) .... ) ) +;; db's are dbdat's +;; +;; if last-update specified ("field-name" . time-in-seconds) +;; then sync only records where field-name >= time-in-seconds +;; IFF field-name exists +;; +(define (db:sync-tables tbls last-update fromdb todb . slave-dbs) + (handle-exceptions + exn + (begin + (dbfile:print-err "EXCEPTION: database probably overloaded or unreadable in db:sync-tables.") + (print-call-chain (current-error-port)) + (dbfile:print-err " message: " ((condition-property-accessor 'exn 'message) exn)) + (dbfile:print-err "exn=" (condition->list exn)) + (dbfile:print-err " status: " ((condition-property-accessor 'sqlite3 'status) exn)) + (dbfile:print-err " src db: " (dbr:dbdat-dbfile fromdb)) + (for-each (lambda (dbdat) + (let ((dbpath (dbr:dbdat-dbfile dbdat))) + (dbfile:print-err " dbpath: " dbpath) + (if #t ;; (not (db:repair-db dbdat)) + (begin + (dbfile:print-err "Failed to rebuild (repair is turned off) " dbpath ", exiting now.") + (exit))))) + (cons todb slave-dbs)) + + 0) + + ;; this is the work to be done") + (cond + ((not fromdb) (dbfile:print-err "WARNING: db:sync-tables called with fromdb missing") + -1) + ((not todb) (dbfile:print-err "WARNING: db:sync-tables called with todb missing") + -2) + ((not (sqlite3:database? (dbr:dbdat-dbh fromdb))) + (dbfile:print-err "db:sync-tables called with fromdb not a database " fromdb) + -3) + ((not (sqlite3:database? (dbr:dbdat-dbh todb))) + (dbfile:print-err "db:sync-tables called with todb not a database " todb) + -4) + + ((not (file-write-access? (dbr:dbdat-dbfile todb))) + (dbfile:print-err "db:sync-tables called with todb not a read-only database " todb) + -5) + ((not (null? (let ((readonly-slave-dbs + (filter + (lambda (dbdat) + (not (file-write-access? (dbr:dbdat-dbfile todb)))) + slave-dbs))) + (for-each + (lambda (bad-dbdat) + (dbfile:print-err "db:sync-tables called with todb not a read-only database " bad-dbdat)) + readonly-slave-dbs) + readonly-slave-dbs))) -6) + (else + ;; (dbfile:print-err "db:sync-tables: args are good") + + (let ((stmts (make-hash-table)) ;; table-field => stmt + (all-stmts '()) ;; ( ( stmt1 value1 ) ( stml2 value2 )) + (numrecs (make-hash-table)) + (start-time (current-milliseconds)) + (tot-count 0)) + (for-each ;; table + (lambda (tabledat) + (let* ((tablename (car tabledat)) + (fields (cdr tabledat)) + (has-last-update (member "last_update" fields)) + (use-last-update (cond + ((and has-last-update + (member "last_update" fields)) + #t) ;; if given a number, just use it for all fields + ((number? last-update) #f) ;; if not matched first entry then ignore last-update for this table + ((and (pair? last-update) + (member (car last-update) ;; last-update field name + (map car fields))) + #t) + ((and last-update (not (pair? last-update)) (not (number? last-update))) + (dbfile:print-err "ERROR: parameter last-update for db:sync-tables must be a pair or a number, received: " last-update);; found in fields + #f) + (else + #f))) + (last-update-value (if use-last-update ;; no need to check for has-last-update - it is already accounted for + (if (number? last-update) + last-update + (cdr last-update)) + #f)) + (last-update-field (if use-last-update + (if (number? last-update) + "last_update" + (car last-update)) + #f)) + (num-fields (length fields)) + (field->num (make-hash-table)) + (num->field (apply vector (map car fields))) ;; BBHERE + (full-sel (conc "SELECT " (string-intersperse (map car fields) ",") + " FROM " tablename (if use-last-update ;; apply last-update criteria + (conc " WHERE " last-update-field " >= " last-update-value) + "") + ";")) + (full-ins (conc "INSERT OR REPLACE INTO " tablename " ( " (string-intersperse (map car fields) ",") " ) " + " VALUES ( " (string-intersperse (make-list num-fields "?") ",") " );")) + (fromdat '()) + (fromdats '()) + (totrecords 0) + (batch-len 100) ;; (string->number (or (configf:lookup *configdat* "sync" "batchsize") "100"))) + (todat (make-hash-table)) + (count 0) + (field-names (map car fields)) + (delay-handicap 0) ;; (string->number (or (configf:lookup *configdat* "sync" "delay-handicap") "0"))) + ) + + ;; set up the field->num table + (for-each + (lambda (field) + (hash-table-set! field->num field count) + (set! count (+ count 1))) + fields) + + ;; read the source table + ;; store a list of all rows in the table in fromdat, up to batch-len. + ;; Then add fromdat to the fromdats list, clear fromdat and repeat. + (sqlite3:with-transaction + (dbr:dbdat-dbh fromdb) + (lambda () + (sqlite3:for-each-row + (lambda (a . b) + (set! fromdat (cons (apply vector a b) fromdat)) + (if (> (length fromdat) batch-len) + (begin + (set! fromdats (cons fromdat fromdats)) + (set! fromdat '()) + (set! totrecords (+ totrecords 1))) + ) + ) + (dbr:dbdat-dbh fromdb) + full-sel) + ) + ) + + ;; Count less than batch-len as a record + (if (> (length fromdat) 0) + (set! totrecords (+ totrecords 1))) + + ;; tack on remaining records in fromdat + (if (not (null? fromdat)) + (set! fromdats (cons fromdat fromdats))) + + (sqlite3:for-each-row + (lambda (a . b) + (hash-table-set! todat a (apply vector a b))) + (dbr:dbdat-dbh todb) + full-sel) + + (when (and delay-handicap (> delay-handicap 0)) + (dbfile:print-err "imposing synthetic sync delay of "delay-handicap" seconds since sync/delay-handicap is configured") + (thread-sleep! delay-handicap) + (dbfile:print-err "synthetic sync delay of "delay-handicap" seconds completed") + ) + + ;; first pass implementation, just insert all changed rows + + (for-each + (lambda (targdb) + (let* ((db (dbr:dbdat-dbh targdb)) + (drp-trigger (if (member "last_update" field-names) + (db:drop-trigger db tablename) + #f)) + (has-last-update (member "last_update" field-names)) + (is-trigger-dropped (if has-last-update + (db:is-trigger-dropped db tablename) + #f)) + (stmth (sqlite3:prepare db full-ins)) + (changed-rows 0)) + (for-each + (lambda (fromdat-lst) + (sqlite3:with-transaction + db + (lambda () + (for-each ;; + (lambda (fromrow) + (let* ((a (vector-ref fromrow 0)) + (curr (hash-table-ref/default todat a #f)) + (same #t)) + (let loop ((i 0)) + (if (or (not curr) + (not (equal? (vector-ref fromrow i)(vector-ref curr i)))) + (set! same #f)) + (if (and same + (< i (- num-fields 1))) + (loop (+ i 1)))) + (if (not same) + (begin + (apply sqlite3:execute stmth (vector->list fromrow)) + (hash-table-set! numrecs tablename (+ 1 (hash-table-ref/default numrecs tablename 0))) + (set! changed-rows (+ changed-rows 1)) + ) + ) + )) + fromdat-lst)))) + fromdats) + + (sqlite3:finalize! stmth) + (if (member "last_update" field-names) + (db:create-trigger db tablename)))) + (append (list todb) slave-dbs) + ) + ) + ) + tbls) + (let* ((runtime (- (current-milliseconds) start-time)) + (should-print (or ;; (debug:debug-mode 12) + (common:low-noise-print 120 "db sync") + (> runtime 500)))) ;; low and high sync times treated as separate. + (for-each + (lambda (dat) + (let ((tblname (car dat)) + (count (cdr dat))) + (set! tot-count (+ tot-count count)) + )) + (sort (hash-table->alist numrecs)(lambda (a b)(> (cdr a)(cdr b)))))) + tot-count))))) + +;;====================================================================== +;; trigger setup/takedown +;;====================================================================== + +(define db:trigger-list + (list (list "update_runs_trigger" "CREATE TRIGGER IF NOT EXISTS update_runs_trigger AFTER UPDATE ON runs + FOR EACH ROW + BEGIN + UPDATE runs SET last_update=(strftime('%s','now')) + WHERE id=old.id; + END;" ) + (list "update_run_stats_trigger" "CREATE TRIGGER IF NOT EXISTS update_run_stats_trigger AFTER UPDATE ON run_stats + FOR EACH ROW + BEGIN + UPDATE run_stats SET last_update=(strftime('%s','now')) + WHERE id=old.id; + END;" ) + (list "update_tests_trigger" "CREATE TRIGGER IF NOT EXISTS update_tests_trigger AFTER UPDATE ON tests + FOR EACH ROW + BEGIN + UPDATE tests SET last_update=(strftime('%s','now')) + WHERE id=old.id; + END;" ) + (list "update_teststeps_trigger" "CREATE TRIGGER IF NOT EXISTS update_teststeps_trigger AFTER UPDATE ON test_steps + FOR EACH ROW + BEGIN + UPDATE test_steps SET last_update=(strftime('%s','now')) + WHERE id=old.id; + END;" ) + (list "update_test_data_trigger" "CREATE TRIGGER IF NOT EXISTS update_test_data_trigger AFTER UPDATE ON test_data + FOR EACH ROW + BEGIN + UPDATE test_data SET last_update=(strftime('%s','now')) + WHERE id=old.id; + END;" ))) +(define (db:is-trigger-dropped db tbl-name) + (let* ((trigger-name (if (equal? tbl-name "test_steps") + "update_teststeps_trigger" + (conc "update_" tbl-name "_trigger"))) + (res #f)) + (sqlite3:for-each-row + (lambda (name) + (if (equal? name trigger-name) + (set! res #t))) + db + "SELECT name FROM sqlite_master WHERE type = 'trigger' ;") + res)) + +(define (db:drop-triggers db) + (for-each + (lambda (key) + (sqlite3:execute db (conc "drop trigger if exists " (car key)))) + db:trigger-list)) + +(define (db:drop-trigger db tbl-name) + (let* ((trigger-name (if (equal? tbl-name "test_steps") + "update_teststeps_trigger" + (conc "update_" tbl-name "_trigger")))) + (for-each + (lambda (key) + (if (equal? (car key) trigger-name) + (sqlite3:execute db (conc "drop trigger if exists " trigger-name)))) + db:trigger-list))) + +(define (db:create-trigger db tbl-name) + (let* ((trigger-name (if (equal? tbl-name "test_steps") + "update_teststeps_trigger" + (conc "update_" tbl-name "_trigger")))) + (for-each (lambda (key) + (if (equal? (car key) trigger-name) + (sqlite3:execute db (cadr key)))) + db:trigger-list))) + +;;====================================================================== +;; db access stuff +;;====================================================================== + +;; call with dbinit=db:initialize-main-db +;; +(define (db:open-db dbstruct run-id dbinit) + ;; (mutex-lock! *db-open-mutex*) + (let* ((dbdat (dbfile:open-db dbstruct run-id dbinit))) + (set! *db-write-access* (not (dbr:dbdat-read-only dbdat))) + ;; (mutex-unlock! *db-open-mutex*) + dbdat)) + +(define dbfile:db-init-proc (make-parameter #f)) + +;; in xmaxima this gives a curve close to what I want: +;; plot2d ((exp(x/1.2)-1)/300, [x, 0, 10])$ +;; plot2d ((exp(x/1.5)-1)/40, [x, 0, 10])$ +;; plot2d ((exp(x/5)-1)/40, [x, 0, 20])$ +(define (dbfile:droop x) + (/ (- (exp (/ x 5)) 1) 40)) + ;; (* numqrys (/ 1 (qif-slope)))) + +;; create a dropping near the db file in a qif dir +;; use count of such files to gate queries (queries in flight) +;; +(define (dbfile:wait-for-qif fname run-id params) + (let* ((thedir (pathname-directory fname)) + (dbnum (dbfile:run-id->dbnum run-id)) + (destdir (conc thedir"/qif-"dbnum)) + (uniqn (get-area-path-signature (conc dbnum params))) + (crumbn (conc destdir"/"(current-seconds)"-"uniqn"."(current-process-id)))) + (if (not (file-exists? destdir))(create-directory (conc destdir"/attic") #t)) + (let loop ((count 0)) + (let* ((currlks (glob (conc destdir"/*"))) + (numqrys (length currlks)) + (delayval (cond ;; do a droopish curve + ((> numqrys 25) + (for-each + (lambda (f) + (if (> (- (current-seconds) + (handle-exceptions + exn + (current-seconds) ;; file is likely gone, just fake out + (file-modification-time f))) + (keep-age-param)) + (let* ((basedir (pathname-directory f)) + (filen (pathname-file f)) + (destf (conc basedir"/attic/"filen))) + (dbfile:print-err "Moving qif file "f" older than 10 seconds to "destf) + ;; (delete-file* f) + (handle-exceptions + exn + #t + (file-move f destf #t))))) + currlks) + 4) + ((> numqrys 0) (dbfile:droop numqrys)) ;; slope of 1/100 + (else #f)))) + (if (and delayval + (< count 5)) + (begin + (thread-sleep! delayval) + (loop (+ count 1)))))) + (with-output-to-file crumbn + (lambda () + (print fname" run-id="run-id" params="params) + )) + crumbn)) + +;; ;; (db:with-db dbstruct run-id sqlite3:exec "select blah fgrom blaz;") +;; ;; r/w is a flag to indicate if the db is modified by this query #t = yes, #f = no +;; ;; +;; ;; Used only with http - to be removed +;; ;; +;; (define (dbfile:with-db dbstruct run-id r/w proc params) +;; (assert dbstruct "FATAL: db:with-db called with dbstruct "#f) +;; (assert (dbr:dbstruct? dbstruct) "FATAL: dbstruct is "dbstruct) +;; ;; Testing 2023, March 14th. I went from full time use of the mutext to no use at all and +;; ;; didn't see much change in the frequency of the messages: +;; ;; Warning (#): in thread: (bind!) bad parameter or other API misuse +;; ;; allowing request count to go up to 1000 and other crashes showed up: +;; ;; Warning (#): in thread: (deserialize) unexpected end of input: # +;; ;; +;; ;; leave it fully on for now, test later if there is a performance issue +;; ;; +;; (let* ((use-mutex #t) ;;(> *api-process-request-count* 50)) ;; risk of db corruption +;; (have-struct (dbr:dbstruct? dbstruct)) +;; (dbdat (if have-struct ;; this stuff just allows us to call with a db handle directly +;; (db:open-db dbstruct run-id (dbfile:db-init-proc)) ;; (dbfile:get-subdb dbstruct run-id) +;; #f)) +;; (db (if have-struct ;; this stuff just allows us to call with a db handle directly +;; (dbr:dbdat-dbh dbdat) +;; dbstruct)) +;; (fname (if dbdat +;; (dbr:dbdat-dbfile dbdat) +;; "nofilenameavailable")) +;; (jfile (conc fname"-journal")) +;; (qryproc (lambda () +;; (if use-mutex (mutex-lock! *db-with-db-mutex*)) +;; (let ((res (apply proc dbdat db params))) ;; the actual call is here. +;; (if use-mutex (mutex-unlock! *db-with-db-mutex*)) +;; ;; (if (vector? dbstruct)(db:done-with dbstruct run-id r/w)) +;; (if dbdat +;; (dbfile:add-dbdat dbstruct run-id dbdat)) +;; ;; (delete-file* crumbfile) +;; res))) +;; (stop-train (conc (dbr:dbstruct-areapath dbstruct)"/stop-the-train"))) +;; +;; (assert (sqlite3:database? db) "FATAL: db:with-db, db is not a database, db="db +;; ", fname="fname) +;; (if (file-exists? jfile) +;; (begin +;; (dbfile:print-err "INFO: "jfile" exists, delaying to reduce database load") +;; (thread-sleep! 0.2))) +;; (if (and use-mutex +;; (common:low-noise-print 120 "over-50-parallel-api-requests")) +;; (dbfile:print-err *api-process-request-count* +;; " parallel api requests being processed in process " +;; (current-process-id))) ;; ", throttling access")) +;; (case (no-condition-db-with-db) +;; ((production)(qryproc)) +;; ((suicide-mode) +;; (handle-exceptions +;; exn +;; (with-output-to-file stop-train +;; (lambda () +;; (db:generic-error-printout exn "Stop train mode, run-id: "run-id +;; " params: "params" proc: "proc))) +;; (qryproc))) +;; (else +;; (condition-case +;; (qryproc) +;; (exn (io-error) +;; (db:generic-error-printout exn "ERROR: i/o error with "fname +;; ". Check permissions, disk space etc. and try again.")) +;; (exn (corrupt) +;; (db:generic-error-printout exn "ERROR: database "fname +;; " is corrupt. Repair it to proceed.")) +;; (exn (busy) +;; (db:generic-error-printout exn "ERROR: database "fname +;; " is locked. Try copying to another location," +;; " remove original and copy back.")) +;; (exn (permission)(db:generic-error-printout exn "ERROR: database "fname +;; " has some permissions problem.")) +;; (exn () +;; (db:generic-error-printout exn "ERROR: Unknown error with database "fname +;; " message: " +;; ((condition-property-accessor 'exn 'message) exn)))))))) + +;;====================================================================== +;; another attempt at a transactionized queue +;;====================================================================== + +;; ;; ;; (define *transaction-queues* (make-hash-table)) +;; ;; ;; +;; ;; ;; (define (db:get-queue run-id) +;; ;; ;; (let* ((res (hash-table-ref/default *transaction-queues* run-id #f))) +;; ;; ;; (if res +;; ;; ;; res +;; ;; ;; (let* ((newq (make-queue))) +;; ;; ;; (hash-table-set! *transaction-queues* run-id newq) +;; ;; ;; newq)))) +;; ;; ;; +;; ;; ;; (define (db:add-to-transaction-queue dbstruct proc params) +;; ;; ;; (let* ((mbox (make-mailbox)) +;; ;; ;; (q (db:get-queue run-id))) +;; ;; ;; (queue-add! *transaction-queue* (list dbstruct proc mbox)) +;; ;; ;; (mailbox-receive mbox))) +;; ;; ;; +;; ;; ;; (define (db:process-transaction-queue *dbstruct-dbs*) +;; ;; ;; (for-each +;; ;; ;; (lambda (run-id) +;; ;; ;; (let* ((q (hash-table-ref *transaction-queue* run-id))) +;; ;; ;; ;; with-transaction +;; ;; ;; ;; dbstruct +;; ;; ;; ;; pop items from queue and execute them, return results via mailbox +;; ;; ;; q +;; ;; ;; ;; pop +;; ;; ;; )) +;; ;; ;; (hash-table-keys *transaction-queues*))) + +;;====================================================================== +;; file utils +;;====================================================================== + +;;====================================================================== +;; lazy-safe get file mod time. on any error (file not existing etc.) return 0 +;; +(define (dbfile:lazy-modification-time fpath) + (handle-exceptions + exn + (begin + (dbfile:print-err "Failed to get modification time for " fpath ", treating it as zero. exn=" exn) + 0) + (if (file-exists? fpath) + (file-modification-time fpath) + 0))) + +;;====================================================================== +;; find timestamp of newest file associated with a sqlite db file +(define (dbfile:lazy-sqlite-db-modification-time fpath) + (let* ((glob-list (handle-exceptions + exn + (begin + (dbfile:print-err "Failed to glob " fpath "*, exn=" exn) + `(,(conc "/no/such/file, message: " ((condition-property-accessor 'exn 'message) exn)))) + (glob (conc fpath "*")))) + (file-list (if (eq? 0 (length glob-list)) + '("/no/such/file") + glob-list))) + (apply max + (map + dbfile:lazy-modification-time + file-list)))) + +;; dot-locking egg seems not to work, using this for now +;; if lock is older than expire-time then remove it and try again +;; to get the lock +;; +(define (dbfile:simple-file-lock fname #!key (expire-time 300)) + (let ((fmod-time (handle-exceptions + ext + (current-seconds) + (file-modification-time fname)))) + + ;; if the file exists, if it has expired, delete it and call this function recursively. + (if (file-exists? fname) + (if (> (- (current-seconds) fmod-time) expire-time) + (begin + (dbfile:print-err "simple-file-lock: removing expired file: " fname) + (handle-exceptions exn #f (delete-file* fname)) + (dbfile:simple-file-lock fname expire-time: expire-time)) + #f + ) + + ;; If it doesn't exist, write the host name and process id to the file + (let ((key-string (conc (get-host-name) "-" (current-process-id) ": " (argv))) + (oup (open-output-file fname))) + (with-output-to-port + oup + (lambda () + (print key-string))) + (close-output-port oup) + + + ;; sleep 3 seconds and make sure it still exists and contains the same host/process id. + ;; if not, return #f + (thread-sleep! 0.25) + (if (file-exists? fname) + (handle-exceptions exn + #f + (with-input-from-file fname + (lambda () + (equal? key-string (read-line))))) + (begin + (dbfile:print-err "dbfile:simple-file-lock created " fname " but it was gone 0.25 seconds later") + #f + ) + ) + ) + ) + ) +) + +(define (dbfile:simple-file-lock-and-wait fname #!key (expire-time 300)) + (let ((end-time (+ expire-time (current-seconds)))) + (let loop ((got-lock (dbfile:simple-file-lock fname expire-time: expire-time))) + (if got-lock + #t + (if (> end-time (current-seconds)) + (begin + (thread-sleep! 3) + (loop (dbfile:simple-file-lock fname expire-time: expire-time))) + #f))))) + +(define (dbfile:simple-file-release-lock fname) + (handle-exceptions + exn + #f ;; I don't really care why this failed (at least for now) + (delete-file* fname))) + +(define (dbfile:with-simple-file-lock fname proc #!key (expire-time 300)(run-anyway #f)) + (let ((start-time (current-seconds)) + (gotlock (dbfile:simple-file-lock-and-wait fname expire-time: expire-time)) + (end-time (current-seconds)) + ) + (if gotlock + (let ((res (proc))) + (dbfile:simple-file-release-lock fname) + res) + (begin + (dbfile:print-err "dbfile:with-simple-file-lock: " fname " is locked by " + (handle-exceptions + exn + "unreadable" + (with-input-from-file fname + (lambda () + (read-line))))) + (dbfile:print-err "wait time = " (- end-time start-time)) + (dbfile:print-err "ERROR: simple file lock could not get a lock for " fname " in " expire-time " seconds") + (if run-anyway + (let ((res (proc))) + (dbfile:simple-file-release-lock fname) + res) + #f))))) + +(define *get-cache-stmth-mutex* (make-mutex)) + +(define (db:get-cache-stmth dbdat db stmt) + (mutex-lock! *get-cache-stmth-mutex*) + (let* (;; (dbdat (dbfile:get-dbdat dbstruct run-id)) + (stmt-cache (dbr:dbdat-stmt-cache dbdat)) + ;; (stmth (db:hoh-get stmt-cache db stmt)) + (stmth (hash-table-ref/default stmt-cache stmt #f)) + (result (or stmth + (let* ((newstmth (sqlite3:prepare db stmt))) + ;; (db:hoh-set! stmt-cache db stmt newstmth) + (hash-table-set! stmt-cache stmt newstmth) + newstmth)))) + (mutex-unlock! *get-cache-stmth-mutex*) + result)) + +;; (define *mutex-stmth-call* (make-mutex)) +;; +;; (define (db:with-mutex-for-stmth proc) +;; (mutex-lock! *mutex-stmth-call*) +;; (let* ((res (proc))) +;; (mutex-unlock! *mutex-stmth-call*) +;; res)) + +) Index: dbmod.scm ================================================================== --- dbmod.scm +++ dbmod.scm @@ -1,5 +1,6 @@ + ;;====================================================================== ;; Copyright 2017, Matthew Welland. ;; ;; This file is part of Megatest. ;; @@ -17,23 +18,964 @@ ;; along with Megatest. If not, see . ;;====================================================================== (declare (unit dbmod)) +(declare (uses dbfile)) +(declare (uses commonmod)) +(declare (uses debugprint)) (module dbmod * -(import scheme chicken data-structures extras) -(import (prefix sqlite3 sqlite3:) posix typed-records srfi-18) - -(define (just-testing) - (print "JUST TESTING")) - -;; (define (debug:print . params) #f) -;; (define (debug:print-info . params) #f) +(import scheme) + +(cond-expand + (chicken-4 + (import chicken + data-structures + extras + files + + posix + + )) + (chicken-5 + (import chicken.base + chicken.condition + chicken.file + chicken.pathname + chicken.process + chicken.sort + chicken.string + chicken.time + + ) + (define file-read-access? file-readable?) + (define file-copy copy-file) + )) + +(import format + (prefix sqlite3 sqlite3:) + matchable + typed-records + srfi-1 + srfi-18 + srfi-69 + + commonmod + dbfile + debugprint) + +;; NOTE: This returns only the name "1.db", "main.db", not the path +;; +(define (dbmod:run-id->dbfname run-id) + (conc (dbfile:run-id->dbnum run-id)".db")) + +(define (dbmod:get-dbdir dbstruct) + (let* ((areapath (dbr:dbstruct-areapath dbstruct)) + (dbdir (conc areapath"/.mtdb"))) + (if (and (file-write-access? areapath) + (not (file-exists? dbdir))) + (create-directory dbdir)) + dbdir)) + +(define (dbmod:run-id->full-dbfname dbstruct run-id) + (conc (dbmod:get-dbdir dbstruct) + "/"(dbmod:run-id->dbfname run-id))) + +;;====================================================================== +;; Read-only cachedb cached direct from disk method +;;====================================================================== + +(define *dbmod:nfs-db-handles* (make-hash-table)) ;; dbfname -> dbstruct + +;; called in rmt.scm nfs-transport-handler +(define (dbmod:nfs-get-dbstruct run-id keys init-proc areapath #!key (tmpadj "")) + (assert areapath "FATAL: dbmod:nfs-get-dbstruct called without areapath set.") + (let* ((dbfname (dbmod:run-id->dbfname run-id)) + (dbstruct (hash-table-ref/default *dbmod:nfs-db-handles* dbfname #f))) + (if dbstruct + dbstruct + (let* ((newdbstruct (dbmod:open-dbmoddb areapath run-id dbfname init-proc keys syncdir: 'fromdisk tmpadj: tmpadj))) + (hash-table-set! *dbmod:nfs-db-handles* dbfname newdbstruct) + newdbstruct)))) + +;;====================================================================== +;; The cachedb one-db file per server method goes in here +;;====================================================================== + +;; NOTE: the r/w is now w/r, #t=db modified by query, #f=db NOT modified by query +(define (dbmod:with-db dbstruct run-id w/r proc params) + (let* ((use-mutex w/r) ;; (or (and w/r ;; use the mutex on queries that modify the db and for sync to disk + ;; (> *api-process-request-count* 5)) ;; when writes are happening throttle more + ;; (> *api-process-request-count* 50))) + (dbdat (dbmod:open-db dbstruct run-id (dbfile:db-init-proc))) + (dbh (dbr:dbdat-dbh dbdat)) ;; this will be the cachedb handle + (dbfile (dbr:dbdat-dbfile dbdat))) + ;; if nfs mode do a sync if delta > 2 + #;(let* ((last-update (dbr:dbstruct-last-update dbstruct)) + ;; (sync-proc (dbr:dbstruct-sync-proc dbstruct)) + (curr-secs (current-seconds))) + (if (> (- curr-secs last-update) 5) + (begin + (sync-proc last-update) + + ;; MOVE THIS CALL TO INSIDE THE sync-proc CALL + (dbr:dbstruct-last-update-set! dbstruct curr-secs) + ))) + (assert (sqlite3:database? dbh) "FATAL: bad db handle in dbmod:with-db") + (if use-mutex (mutex-lock! *db-with-db-mutex*)) + (let* ((res (let loop ((count 3)) + (condition-case + (apply proc dbdat dbh params) + (exn (busy) + (if (> count 0) + (begin + (debug:print-info 0 *default-log-port* "dbmod:with-db, database is busy, will try "count" more times.") + (thread-sleep! 1) + (loop (- count 1))) + (begin + (debug:print-info 0 *default-log-port* "dbmod:with-db, database is busy, giving up.") + (exit 1)))) + (exn () + (dbfile:print-err exn "ERROR: dbmod:with-db: Unknown error with database for run-id "run-id", message: " + ((condition-property-accessor 'exn 'message) exn)) + (exit 2)))))) + (if use-mutex (mutex-unlock! *db-with-db-mutex*)) + res))) + +(define (db:with-db dbstruct run-id w/r proc . params) + (dbmod:with-db dbstruct run-id w/r proc params)) + +;; +(define (dbmod:open-cachedb-db init-proc dbfullname) + (let* ((db (if dbfullname + (dbmod:safely-open-db dbfullname init-proc #t) + (sqlite3:open-database ":memory:"))) + (handler (sqlite3:make-busy-timeout 136000))) + (sqlite3:set-busy-handler! db handler) + (init-proc db) + db)) + +(define (dbmod:open-db dbstruct run-id dbinit) + (or (dbr:dbstruct-dbdat dbstruct) + (let* ((dbdat (make-dbr:dbdat + dbfile: (dbr:dbstruct-dbfile dbstruct) + dbh: (dbr:dbstruct-cachedb dbstruct) + ))) + (dbr:dbstruct-dbdat-set! dbstruct dbdat) + dbdat))) + +;; NOT USED? +(define (dbmod:need-on-disk-db-handle) + (case (dbfile:cache-method) + ((none tmp) #t) + ((cachedb) + (case (dbfile:sync-method) + ((original) #t) + ((attach) #t) ;; we need it to force creation of the on-disk file - FIXME + (else + (debug:print 0 *default-log-port* "Unknown dbfile:sync-method setting: " + (dbfile:sync-method))))) + (else + (debug:print 0 *default-log-port* "Unknown dbfile:cache-method setting: " + (dbfile:cache-method)) + #f))) + +(define (dbmod:safely-open-db dbfullname init-proc write-access) + (dbfile:with-simple-file-lock + (conc dbfullname".lock") + (lambda () + (let* ((dbexists (file-exists? dbfullname)) + (db (sqlite3:open-database dbfullname)) + (handler (sqlite3:make-busy-timeout 136000))) + (sqlite3:set-busy-handler! db handler) + (if (and (not dbexists) + write-access) + (init-proc db)) + db)) + run-anyway: #t)) + +(define *sync-in-progress* #f) + +;; Open the cachedb db and the on-disk db +;; populate the cachedb db with data +;; +;; Updates fields in dbstruct +;; Returns dbstruct +;; +;; * This routine creates the db if not found +;; * Probably can get rid of the dbstruct-in ;; -;; (define (set-functions dbgp dbgpinfo) -;; (set! debug:print dbgp) -;; (set! debug:print-info dbgpinfo)) +(define (dbmod:open-dbmoddb areapath run-id dbfname-in init-proc keys + #!key (dbstruct-in #f) + ;; (dbcontext 'megatest) ;; use dashboard to do the dashboard + (tmpadj "") ;; add to tmp path + (syncdir 'todisk)) ;; todisk is used when caching in /tmp and writing data back to MTRAH + (let* ((dbstruct (or dbstruct-in (make-dbr:dbstruct areapath: areapath))) + (dbfname (or dbfname-in (dbmod:run-id->dbfname run-id))) + (dbpath (dbmod:get-dbdir dbstruct)) ;; directory where all the .db files are kept + (dbfullname (conc dbpath"/"dbfname)) ;; (dbmod:run-id->full-dbfname dbstruct run-id)) + (dbexists (file-exists? dbfullname)) + (tmpdir (common:make-tmpdir-name areapath tmpadj)) + (tmpdb (let* ((fname (conc tmpdir"/"dbfname))) + fname)) + (cachedb (dbmod:open-cachedb-db init-proc + ;; (if (eq? (dbfile:cache-method) 'cachedb) + ;; #f + tmpdb + ;; ) + )) + (write-access (file-write-access? dbpath)) + (db (dbmod:safely-open-db dbfullname init-proc write-access)) + (tables (db:sync-all-tables-list keys))) + (if (not (and (sqlite3:database? cachedb) + (sqlite3:database? db))) + (begin + (debug:print 0 *default-log-port* "ERROR: Failed to properly open "dbfname-in", exiting immediately.") + (exit))) ;; (assert (sqlite3:database? cachedb) "FATAL: open-dbmoddb: cachedb is not a db") + ;; (assert (sqlite3:database? db) "FATAL: open-dbmoddb: db is not a db") + (dbr:dbstruct-cachedb-set! dbstruct cachedb) + (dbr:dbstruct-ondiskdb-set! dbstruct db) + (dbr:dbstruct-dbfile-set! dbstruct dbfullname) + (dbr:dbstruct-dbtmpname-set! dbstruct tmpdb) + (dbr:dbstruct-dbfname-set! dbstruct dbfname) + (dbr:dbstruct-sync-proc-set! dbstruct + (lambda (last-update) + (if *sync-in-progress* + (debug:print 0 *default-log-port* "WARNING: overlapping calls to sync to disk") + (begin + ;; turn off writes - send busy or block? + ;; call db2db internally + ;; turn writes back on + ;; + (set! *api-halt-writes* #t) ;; do we need a mutex? + ;; (dbmod:db-to-db-sync src-db dest-db last-update (dbfile:db-init-proc) keys) + (debug:print-info 2 *default-log-port* "Internal sync running from "tmpdb" to "dbfullname) + (dbmod:db-to-db-sync tmpdb dbfullname last-update (dbfile:db-init-proc) keys) + (set! *api-halt-writes* #f) + )))) + ;; (dbmod:sync-tables tables #f db cachedb) + ;; + (thread-sleep! 1) ;; let things settle before syncing in needed data + (dbmod:sync-gasket tables #f cachedb db dbfullname 'fromdest keys) ;; ) ;; load into cachedb + (dbr:dbstruct-last-update-set! dbstruct (+ (current-seconds) -10)) ;; should this be offset back in time by one second? + dbstruct)) + +;; (if (eq? syncdir 'todisk) ;; sync to disk normally, sync from in dashboard +;; (dbmod:sync-tables tables last-update cachedb db) +;; (dbmod:sync-tables tables last-update db cachedb)))) +;; +;; direction: 'fromdest 'todest +;; +(define (dbmod:sync-gasket tables last-update cachedb dbh dbfname direction keys) + (assert (sqlite3:database? cachedb) "FATAL: sync-gasket: cachedb is not a db") + (assert (sqlite3:database? cachedb) "FATAL: sync-gasket: dbh is not a db") + (debug:print-info 2 *default-log-port* "dbmod:sync-gasket called with sync-method="(dbfile:sync-method)) + (case (dbfile:sync-method) + ((none) #f) + ((attach) + (dbmod:attach-sync tables cachedb dbfname direction)) + ((newsync) + (dbmod:new-sync tables cachedb dbh dbfname direction)) + (else ;; original + (case direction + ((todisk) ;; i.e. from the cache db to the mtrah db + (dbmod:sync-tables tables last-update keys cachedb dbh)) + (else + (dbmod:sync-tables tables last-update keys dbh cachedb)))))) + +(define (dbmod:close-db dbstruct) + ;; do final sync to disk file + ;; (do-sync ...) + (sqlite3:finalize! (dbr:dbstruct-ondiskdb dbstruct))) + +;;====================================================================== +;; Sync db +;;====================================================================== + +(define (dbmod:calc-use-last-update has-last-update fields last-update) + (cond + ((and has-last-update + (member "last_update" fields)) + #t) ;; if given a number, just use it for all fields + ((number? last-update) #f) ;; if not matched first entry then ignore last-update for this table + ((and (pair? last-update) + (member (car last-update) ;; last-update field name + (map car fields))) + #t) + ((and last-update (not (pair? last-update)) (not (number? last-update))) + (debug:print 0 *default-log-port* "ERROR: parameter last-update for db:sync-tables must be a pair or a number, received: " last-update);; found in fields + #f) + (else + #f))) + +;; tbls is ( ("tablename" ( "field1" [#f|proc1] ) ( "field2" [#f|proc2] ) .... ) ) +;; dbs are sqlite3 db handles +;; +;; if last-update specified ("field-name" . time-in-seconds) +;; then sync only records where field-name >= time-in-seconds +;; IFF field-name exists +;; +;; Use (db:sync-all-tables-list keys) to get the tbls input +;; +(define (dbmod:sync-tables tbls last-update keys fromdb todb) + (debug:print-info 2 *default-log-port* "dbmod:sync-tables called, from: "fromdb", to: "todb) + (assert (sqlite3:database? fromdb) "FATAL: dbmod:sync-tables called with fromdb not a database" fromdb) + (assert (sqlite3:database? todb) "FATAL: dbmod:sync-tables called with fromdb not a database" todb) + (let ((stmts (make-hash-table)) ;; table-field => stmt + (all-stmts '()) ;; ( ( stmt1 value1 ) ( stml2 value2 )) + (numrecs (make-hash-table)) + (start-time (current-milliseconds)) + (tot-count 0)) + (for-each ;; table + (lambda (tabledat) + (let* ((tablename (car tabledat)) + (fields (cdr tabledat)) + (has-last-update (member "last_update" fields)) + (use-last-update (dbmod:calc-use-last-update has-last-update fields last-update)) + (last-update-value (if use-last-update ;; no need to check for has-last-update - it is already accounted for + (if (number? last-update) + last-update + (cdr last-update)) + #f)) + (last-update-field (if use-last-update + (if (number? last-update) + "last_update" + (car last-update)) + #f)) + (num-fields (length fields)) + (field->num (make-hash-table)) + (num->field (apply vector (map car fields))) ;; BBHERE + (full-sel (conc "SELECT " (string-intersperse (map car fields) ",") + " FROM " tablename (if use-last-update ;; apply last-update criteria + (conc " WHERE " last-update-field " >= " last-update-value) + "") + ";")) + (full-ins (conc "INSERT OR REPLACE INTO " tablename " ( " (string-intersperse (map car fields) ",") " ) " + " VALUES ( " (string-intersperse (make-list num-fields "?") ",") " );")) + (fromdat '()) + (fromdats '()) + (totrecords 0) + (batch-len 100) ;; (string->number (or (configf:lookup *configdat* "sync" "batchsize") "100"))) + (todat (make-hash-table)) + (count 0) + (field-names (map car fields))) + + ;; set up the field->num table + (for-each + (lambda (field) + (hash-table-set! field->num field count) + (set! count (+ count 1))) + fields) + + ;; read the source table + ;; store a list of all rows in the table in fromdat, up to batch-len. + ;; Then add fromdat to the fromdats list, clear fromdat and repeat. + (sqlite3:for-each-row + (lambda (a . b) + (set! fromdat (cons (apply vector a b) fromdat)) + (if (> (length fromdat) batch-len) + (begin + (set! fromdats (cons fromdat fromdats)) + (set! fromdat '()) + (set! totrecords (+ totrecords 1))))) + fromdb + full-sel) + + ;; Count less than batch-len as a record + (if (> (length fromdat) 0) + (set! totrecords (+ totrecords 1))) + + ;; tack on remaining records in fromdat + (if (not (null? fromdat)) + (set! fromdats (cons fromdat fromdats))) + + (sqlite3:for-each-row + (lambda (a . b) + (hash-table-set! todat a (apply vector a b))) + todb + full-sel) + + ;; first pass implementation, just insert all changed rows + + (let* ((db todb) + (drp-trigger (if (member "last_update" field-names) + (db:drop-trigger db tablename) + #f)) + (has-last-update (member "last_update" field-names)) + (is-trigger-dropped (if has-last-update + (db:is-trigger-dropped db tablename) + #f)) + (stmth (sqlite3:prepare db full-ins)) + (changed-rows 0)) + (for-each + (lambda (fromdat-lst) + (mutex-lock! *db-transaction-mutex*) + (sqlite3:with-transaction + db + (lambda () + (for-each ;; + (lambda (fromrow) + (let* ((a (vector-ref fromrow 0)) + (curr (hash-table-ref/default todat a #f)) + (same #t)) + (let loop ((i 0)) + (if (or (not curr) + (not (equal? (vector-ref fromrow i)(vector-ref curr i)))) + (set! same #f)) + (if (and same + (< i (- num-fields 1))) + (loop (+ i 1)))) + (if (not same) + (begin + (apply sqlite3:execute stmth (vector->list fromrow)) + (hash-table-set! numrecs tablename (+ 1 (hash-table-ref/default numrecs tablename 0))) + (set! changed-rows (+ changed-rows 1)))))) + fromdat-lst))) + (mutex-unlock! *db-transaction-mutex*)) + fromdats) + ;; (debug:print 0 *default-log-port* "row="row) + + (sqlite3:finalize! stmth) + (if (member "last_update" field-names) + (db:create-trigger db tablename))) + )) + tbls) + (let* ((runtime (- (current-milliseconds) start-time)) + (should-print (or ;; (debug:debug-mode 12) + (common:low-noise-print 120 "db sync") + (> runtime 500)))) ;; low and high sync times treated as separate. + (for-each + (lambda (dat) + (let ((tblname (car dat)) + (count (cdr dat))) + (set! tot-count (+ tot-count count)))) + (sort (hash-table->alist numrecs)(lambda (a b)(> (cdr a)(cdr b)))))) + tot-count)) + +(define (has-last-update dbh tablename) + (let* ((has-last #f)) + (sqlite3:for-each-row + (lambda (name) + (if (equal? name "last_update") + (set! has-last #t))) + dbh + (conc "SELECT name FROM pragma_table_info('"tablename"') as tblInfo;")) + has-last)) + +(define (replace-question-marks-with-number str num) + (define (replace-helper str index result) + (if (>= index (string-length str)) + result + (let ((char (string-ref str index))) + (if (char=? char #\?) + (replace-helper str (+ index 1) (string-append result (number->string num))) + (replace-helper str (+ index 1) (string-append result (string char))))))) + + (replace-helper str 0 "")) + + +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;; tbls is ( ("tablename" ( "field1" [#f|proc1] ) ( "field2" [#f|proc2] ) .... ) ) +;; +;; direction = fromdest, todisk +;; mode = 'full, 'incr +;; +;; Idea: youngest in dest is last_update time +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; + +(define (dbmod:attach-sync tables dbh destdbfile direction #!key + (mode 'full) + (no-update '("keys")) ;; do + ) + (debug:print-info 2 *default-log-port* "dbmod:attach-sync") + (let* ((num-changes 0) + (update-changed (lambda (num-changed table qryname) + (if (> num-changed 0) + (begin + (debug:print-info 0 *default-log-port* "Changed "num-changed" rows for table "table", qry "qryname) + (set! num-changes (+ num-changes num-changed))))))) + (debug:print 2 *default-log-port* "Doing sync "direction" "destdbfile) + (if (not (sqlite3:auto-committing? dbh)) + (debug:print 0 *default-log-port* "Skipping sync due to transaction in flight.") + (let* ((table-names (map car tables)) + (dest-exists (file-exists? destdbfile))) + (assert dest-exists "FATAL: sync called with non-existant file, "destdbfile) + ;; attach the destdbfile + ;; for each table + ;; insert into dest. select * from src.

where last_update>last_update + ;; done + (debug:print 2 *default-log-port* "Attaching "destdbfile" as auxdb") + (handle-exceptions + exn + (begin + (debug:print 0 *default-log-port* "ATTACH failed, exiting. exn="(condition->list exn)) + (exit 1)) + (sqlite3:execute dbh (conc "ATTACH '"destdbfile"' AS auxdb;"))) + (for-each + (lambda (table) + (let* ((dummy (debug:print 2 *default-log-port* "Doing table " table)) + (tbldat (alist-ref table tables equal?)) + (fields (map car tbldat)) + (no-id-fields (filter (lambda (x)(not (equal? x "id"))) fields)) + (fields-str (string-intersperse fields ",")) + (no-id-fields-str (string-intersperse no-id-fields ",")) + (dir (eq? direction 'todisk)) + (fromdb (if dir "main." "auxdb.")) + (todb (if dir "auxdb." "main.")) + (set-str (string-intersperse + (map (lambda (field) + (conc fromdb field"="todb field)) + fields) + ",")) + (stmt1 (conc "INSERT OR IGNORE INTO "todb table + " SELECT * FROM "fromdb table";")) + (stmt2 (conc "INSERT OR IGNORE INTO "todb table + " SELECT * FROM "fromdb table" WHERE "fromdb table".id=?;")) + (stmt8 (conc "UPDATE "todb table" SET ("no-id-fields-str") = (SELECT "no-id-fields-str" FROM "fromdb table" WHERE "todb table".id="fromdb table".id" + (conc " AND "fromdb table".last_update > "todb table".last_update);") + ");")) + (update-string (conc "UPDATE "todb table" SET ")) + (split-update + (let () + (for-each + (lambda (column) + (set! update-string (conc update-string column" = (SELECT "column" FROM "fromdb table" WHERE "fromdb table".id=?), ")) + ) + no-id-fields + ) + ;; drop the last ", " + (conc (substring update-string 0 (-(string-length update-string) 2)) " WHERE "todb table".id=? ") + ) + ) + + + (stmt9 (conc "UPDATE "todb table" SET ("no-id-fields-str") = " + "(SELECT "no-id-fields-str" FROM "fromdb table" WHERE "fromdb table".id=?)" + " WHERE "todb table".id=?")) + (newrec (conc "SELECT id FROM "fromdb table" WHERE id NOT IN (SELECT id FROM "todb table");")) + (changedrec (conc "SELECT "fromdb table".id FROM "fromdb table" join "todb table" on "fromdb table".id="todb table".id WHERE "fromdb table".last_update > "todb table".last_update;")) + (start-ms (current-milliseconds)) + (new-ids (sqlite3:fold-row (lambda (res id)(cons id res)) '() dbh newrec))) + (update-changed (length new-ids) table "new records") + (mutex-lock! *db-transaction-mutex*) + (handle-exceptions + exn + (debug:print 0 *default-log-port* "Transaction update of id fields in "table" failed.") + (sqlite3:with-transaction + dbh + (lambda () + (for-each (lambda (id) + (sqlite3:execute dbh stmt2 id)) + new-ids)))) + + (if (member "last_update" fields) + (handle-exceptions + exn + (debug:print 0 *default-log-port* "Transaction update of non id fields in "table" failed.") + (sqlite3:with-transaction + dbh + (lambda () + (let* ((changed-ids (sqlite3:fold-row (lambda (res id)(cons id res)) '() dbh changedrec)) + (sql-query "") + ) + (update-changed (length changed-ids) table "changed records") + (for-each (lambda (id) + (let* ((update-with-ids (replace-question-marks-with-number split-update id)) + ) + (debug:print 2 *default-log-port* "about to do sqlite3:execute " dbh " " update-with-ids ) + (handle-exceptions + exn + (debug:print 0 *default-log-port* "update from " fromdb table " to " todb table " failed: " ((condition-property-accessor 'exn 'message) exn)) + (sqlite3:execute dbh update-with-ids) + ) + (debug:print 2 *default-log-port* "after sqlite3:execute") + ) + ) + changed-ids + ) + ) + ) + ) + ) + ) + (mutex-unlock! *db-transaction-mutex*) + + (debug:print 2 *default-log-port* "Synced table "table + " in "(- (current-milliseconds) start-ms)"ms") + + )) + table-names) + (sqlite3:execute dbh "DETACH auxdb;"))) + num-changes)) + +;; prefix is "" or "auxdb." +;; +;; (define (dbmod:last-update-patch dbh prefix) +;; (let (( + +;; tbls is ( ("tablename" ( "field1" [#f|proc1] ) ( "field2" [#f|proc2] ) .... ) ) +;; +;; direction = fromdest, todest +;; mode = 'full, 'incr +;; +;; Idea: youngest in dest is last_update time +;; +(define (dbmod:new-sync tables dbh1 dbh2 destdbfile direction #!key + (mode 'full)) + (debug:print 0 *default-log-port* "Doing new-sync "direction" "destdbfile) + (if (not (sqlite3:auto-committing? dbh1)) + (debug:print 0 *default-log-port* "Skipping sync due to transaction in flight.") + (let* ((table-names (map car tables)) + (dest-exists (file-exists? destdbfile))) + (assert dest-exists "FATAL: sync called with non-existant file, "destdbfile) + (for-each + (lambda (table) + (let* ((tbldat (alist-ref table tables equal?)) + (fields (map car tbldat)) + (no-id-fields (filter (lambda (x)(not (equal? x "id"))) fields)) + (questionmarks (string-intersperse (make-list (length no-id-fields) "?") ",")) + (fields-str (string-intersperse fields ",")) + (no-id-fields-str (string-intersperse no-id-fields ",")) + (dir (eq? direction 'todest)) + (fromdb (if dir dbh1 dbh2)) + (todb (if dir dbh2 dbh1)) + (set-str (string-intersperse + (map (lambda (field) + (conc fromdb field"="todb field)) + fields) + ",")) + ;; (stmt1 (conc "INSERT OR IGNORE INTO "todb table + ;; " SELECT * FROM "fromdb table";")) + ;; (stmt8 (conc "UPDATE "todb table" SET ("no-id-fields-str") = (SELECT "no-id-fields-str" FROM "fromdb table " WHERE "todb table".id="fromdb table".id" + ;; (if (member "last_update" fields) + ;; (conc " AND "fromdb table".last_update > "todb table".last_update);") + ;; ");"))) + (stmt1 (conc "SELECT MAX(last_update) FROM "table";")) ;; use the highest last_update as your time reference + (stmt2 (conc "SELECT no-id-fields-str FROM "table" WHERE last_update>?;")) + (stmt3 (conc "UPDATE "table" SET ("no-id-fields-str") = ("questionmarks") WHERE id=?;")) + (start-ms (current-milliseconds))) + (debug:print 0 *default-log-port* "stmt3="stmt3) + (if (sqlite3:auto-committing? dbh1) + (begin + (handle-exceptions + exn + (debug:print 0 *default-log-port* "Transaction update of "table" failed. "(condition->list exn)) + (sqlite3:with-transaction + dbh1 + (lambda () + (sqlite3:execute dbh1 stmt1) ;; get all new rows + + #;(if (member "last_update" fields) + (sqlite3:execute dbh1 stmt8)) ;; get all updated rows + ;; (sqlite3:execute dbh stmt5) + ;; (sqlite3:execute dbh stmt4) ;; if it worked this would be better for incremental up + ;; (sqlite3:execute dbh stmt6) + ))) + (debug:print 0 *default-log-port* "Synced table "table + " in "(- (current-milliseconds) start-ms)"ms")) + (debug:print 0 *default-log-port* "Skipping sync of table "table" due to transaction in flight.")))) + table-names) + (sqlite3:execute dbh1 "DETACH auxdb;")))) + + + + +;;====================================================================== +;; Moved from dbfile +;;====================================================================== + +;; wait up to aprox n seconds for a journal to go away +;; +(define (tasks:wait-on-journal path n #!key (remove #f)(waiting-msg #f)) + (if (not (string? path)) + (debug:print-error 0 *default-log-port* "Called tasks:wait-on-journal with path=" path " (not a string)") + (let ((fullpath (conc path "-journal"))) + (handle-exceptions + exn + (begin + (print-call-chain (current-error-port)) + (debug:print 0 *default-log-port* " message: " ((condition-property-accessor 'exn 'message) exn)) + (debug:print 5 *default-log-port* " exn=" (condition->list exn)) + (debug:print 0 *default-log-port* "tasks:wait-on-journal failed. Continuing on, you can ignore this call-chain") + #t) ;; if stuff goes wrong just allow it to move on + (let loop ((journal-exists (file-exists? fullpath)) + (count n)) ;; wait ten times ... + (if journal-exists + (begin + (if (and waiting-msg + (eq? (modulo n 30) 0)) + (debug:print 0 *default-log-port* waiting-msg)) + (if (> count 0) + (begin + (thread-sleep! 1) + (loop (file-exists? fullpath) + (- count 1))) + (begin + (debug:print 0 *default-log-port* "ERROR: removing the journal file " fullpath ", this is not good. Look for disk full, write access and other issues.") + (if remove (system (conc "rm -rf " fullpath))) + #f))) + #t)))))) + + +;;====================================================================== +;; M E T A G E T A N D S E T V A R S +;;====================================================================== + +;; returns number if string->number is successful, string otherwise +;; also updates *global-delta* +;; +(define (db:get-var dbstruct var) + (let* ((res #f)) + (db:with-db + dbstruct #f #f ;; for the moment vars are only stored in main.db + (lambda (dbdat db) + (sqlite3:for-each-row + (lambda (val) + (set! res val)) + db + "SELECT val FROM metadat WHERE var=?;" var) + ;; convert to number if can + (if (string? res) + (let ((valnum (string->number res))) + (if valnum (set! res valnum)))) + res)))) + +(define (db:inc-var dbstruct var) + (db:with-db dbstruct #f #t + (lambda (dbdat db) + (sqlite3:execute db "UPDATE metadat SET val=val+1 WHERE var=?;" var)))) + +(define (db:dec-var dbstruct var) + (db:with-db dbstruct #f #t + (lambda (dbdat db) + (sqlite3:execute db "UPDATE metadat SET val=val-1 WHERE var=?;" var)))) + +;; This was part of db:get-var. It was used to estimate the load on +;; the database files. +;; +;; scale by 10, average with current value. +;; (set! *global-delta* (/ (+ *global-delta* (* (- (current-milliseconds) start-ms) +;; (if throttle throttle 0.01))) +;; 2)) +;; (if (> (abs (- *last-global-delta-printed* *global-delta*)) 0.08) ;; don't print all the time, only if it changes a bit +;; (begin +;; (debug:print-info 4 *default-log-port* "launch throttle factor=" *global-delta*) +;; (set! *last-global-delta-printed* *global-delta*))) + +(define (db:set-var dbstruct var val) + (db:with-db dbstruct #f #t + (lambda (dbdat db) + (sqlite3:execute (db:get-cache-stmth dbdat db "INSERT OR REPLACE INTO metadat (var,val) VALUES (?,?);") + var val)))) + +(define (db:add-var dbstruct var val) + (db:with-db dbstruct #f #t + (lambda (dbdat db) + (sqlite3:execute (db:get-cache-stmth dbdat db "UPDATE metadat SET val=val+? WHERE var=?;") val var)))) + +(define (db:del-var dbstruct var) + (db:with-db dbstruct #f #t + (lambda (dbdat db) + (sqlite3:execute (db:get-cache-stmth dbdat db "DELETE FROM metadat WHERE var=?;") var)))) + +(define (db:get-toplevels-and-incompletes dbstruct run-id running-deadtime remotehoststart-deadtime) + (let* ((toplevels '()) + (oldlaunched '()) + (incompleted '())) + (db:with-db + dbstruct run-id #t ;; not a write but problemtic + (lambda (dbdat db) + (let* ((stmth1 (db:get-cache-stmth + dbdat db + "SELECT id,rundir,uname,testname,item_path,event_time,run_duration FROM tests + WHERE run_id=? AND (strftime('%s','now') - event_time) > (run_duration + ?) + AND state IN ('RUNNING');")) + (stmth2 (db:get-cache-stmth + dbdat db + "SELECT id,rundir,uname,testname,item_path,event_time,run_duration FROM tests + WHERE run_id=? AND (strftime('%s','now') - event_time) > (run_duration + ?) + AND state IN ('REMOTEHOSTSTART');")) + (stmth3 (db:get-cache-stmth + dbdat db + "SELECT id,rundir,uname,testname,item_path FROM tests + WHERE run_id=? AND (strftime('%s','now') - event_time) > 86400 + AND state IN ('LAUNCHED');"))) + ;; in RUNNING or REMOTEHOSTSTART for more than 10 minutes + ;; + ;; 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 run-dir uname testname item-path event-time run-duration) + (if (and (equal? uname "n/a") + (equal? item-path "")) ;; this is a toplevel test + ;; what to do with toplevel? call rollup? + (begin + (set! toplevels (cons (list test-id run-dir uname testname item-path run-id) toplevels)) + (debug:print-info 0 *default-log-port* "Found old toplevel test in RUNNING state, test-id=" test-id)) + (begin + (set! incompleted (cons (list test-id run-dir uname testname item-path run-id) incompleted)) + (debug:print-info 0 *default-log-port* "Found old test in RUNNING state, test-id=" + test-id" exceeded running-deadtime "running-deadtime" now="(current-seconds) + " event-time="event-time" run-duration="run-duration)))) + stmth1 + run-id running-deadtime) ;; default time 720 seconds + + (sqlite3:for-each-row + (lambda (test-id run-dir uname testname item-path event-time run-duration) + (if (and (equal? uname "n/a") + (equal? item-path "")) ;; this is a toplevel test + ;; what to do with toplevel? call rollup? + (begin + (set! toplevels (cons (list test-id run-dir uname testname item-path run-id) toplevels)) + (debug:print-info 0 *default-log-port* "Found old toplevel test in RUNNING state, test-id=" test-id)) + (begin + (debug:print-info 0 *default-log-port* "Found old test in REMOTEHOSTSTART state, test-id=" test-id + " exceeded running-deadtime "running-deadtime" now="(current-seconds)" event-time="event-time + " run-duration="run-duration) + (set! incompleted (cons (list test-id run-dir uname testname item-path run-id) incompleted))))) + stmth2 + run-id remotehoststart-deadtime) ;; default time 230 seconds + + ;; 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 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)) + (begin + (debug:print-info 0 *default-log-port* "Found old test in LAUNCHED state, test-id=" test-id + " 1 day since event_time marked") + (set! oldlaunched (cons (list test-id run-dir uname testname item-path run-id) oldlaunched))))) + stmth3 + run-id)))) + (list incompleted oldlaunched toplevels))) + +;;====================================================================== +;; db to db sync +;;====================================================================== + +(define (dbmod:db-to-db-sync src-db dest-db last-update init-proc keys) + (if (and (file-exists? src-db) ;; can't proceed without a source + (file-read-access? src-db)) + (let* ((have-dest (file-exists? dest-db)) + (dest-file-wr (and have-dest + (file-write-access? dest-db))) ;; exists and writable + (dest-dir (or (pathname-directory dest-db) + ".")) + (dest-dir-wr (and (file-exists? dest-dir) + (file-write-access? dest-dir))) + (d-wr (or (and have-dest + dest-file-wr) + dest-dir-wr)) + (copied (if (and (not have-dest) + dest-dir-wr) + (begin + (file-copy src-db dest-db) + #t) + #f))) + (if copied + (begin + (debug:print-info 0 *default-log-port* "db-to-db-sync done with file-copy") + #t) + (let* ((tables (db:sync-all-tables-list keys)) + (sdb (dbmod:safely-open-db src-db init-proc #t)) + (ddb (dbmod:safely-open-db dest-db init-proc d-wr)) + (res (dbmod:sync-gasket tables last-update sdb ddb dest-db 'todisk keys))) + (sqlite3:finalize! sdb) + (sqlite3:finalize! ddb) + res))) + #f)) + +;; ====================================================================== +;; dbstats +;;====================================================================== + +;; (define *dbstruct-dbs* #f) ;; used to cache the dbstruct in db:setup. Goal is to remove this. +;; db stats +(define *db-stats* (make-hash-table)) ;; hash of vectors < count duration-total > +(define *db-stats-mutex* (make-mutex)) + +(define (rmt:print-db-stats) + (let ((fmtstr "~40a~8-d~20-d~20,2-f")) ;; "~20,2-f" + (debug:print 0 *default-log-port* "DB Stats\n========") + (debug:print 0 *default-log-port* (format #f "~40a~8a~20a~10a" "Cmd" "Count" "TotTime" "Avg")) + (for-each (lambda (cmd) + (let* ((dat (hash-table-ref *db-stats* cmd)) + (count (dbstat-cnt dat)) + (tottime (dbstat-tottime dat))) + (debug:print 0 *default-log-port* + (format #f fmtstr cmd count tottime + (/ tottime count))))) + (sort (hash-table-keys *db-stats*) + (lambda (a b) + (> (dbstat-tottime (hash-table-ref *db-stats* a)) + (dbstat-tottime (hash-table-ref *db-stats* b)))))))) + +(defstruct dbstat + (cnt 0) + (tottime 0)) + +(define (db:add-stats cmd run-id params delta) + (let* ((modified-cmd (if (eq? cmd 'general-call) + (string->symbol (conc "general-call-" (car params))) + cmd)) + (rec (hash-table-ref/default *db-stats* modified-cmd #f))) + (if (not rec) + (let ((new-rec (make-dbstat))) + (hash-table-set! *db-stats* modified-cmd new-rec) + (set! rec new-rec))) + (dbstat-cnt-set! rec (+ (dbstat-cnt rec) 1)) + (dbstat-tottime-set! rec (+ (dbstat-tottime rec) delta)))) + + ) + + +;; ATTIC + + #;(let* ((syncer-logfile (conc areapath"/logs/"dbfname"-syncer.log")) + (sync-cmd (if (eq? syncdir 'todisk) + (conc "(NBFAKE_LOG="syncer-logfile" nbfake megatest -db2db -from "tmpdb" -to "dbfullname" -period 5 -timeout 10 > /dev/null 2&>1)&") + (conc "(NBFAKE_LOG="syncer-logfile" nbfake megatest -db2db -from "dbfullname" -to "tmpdb" -period 5 -timeout 10 > /dev/null 2&>1)&"))) + (synclock-file (conc dbfullname".lock")) + (syncer-running-file (conc dbfullname"-sync-running")) + (synclock-mod-time (if (file-exists? synclock-file) + (handle-exceptions + exn + #f + (file-modification-time synclock-file)) + #f)) + (thethread (lambda () + (thread-start! + (make-thread + (lambda () + (set! *sync-in-progress* #t) + (debug:print-info "Running "sync-cmd) + (if (file-exists? syncer-running-file) + (debug:print-info 0 *default-log-port* "Syncer still running, skipping syncer start.") + (system sync-cmd)) + (set! *sync-in-progress* #f))))))) + (if ((if (eq? syncdir 'todisk) < >) ;; use less than for todisk, greater than for from disk + (file-modification-time tmpdb) + (file-modification-time dbfullname)) + (debug:print 4 *default-log-port* "Skipping sync, "tmpdb" older than "dbfullname) + (if synclock-mod-time + (if (> (- (current-seconds) synclock-mod-time) 20) ;; something wrong with sync, remove file + (begin + (handle-exceptions + exn + #f + (begin + (debug:print 0 *default-log-port* "Sync lock file " synclock-file "is older than 20 seconds (" synclock-mod-time " seconds). Removing it") + (delete-file synclock-file) + ) + ) + (thethread)) + (debug:print 0 *default-log-port* "Skipping sync, lockfile "synclock-file" found.")) + (thethread)))) Index: dcommon.scm ================================================================== --- dcommon.scm +++ dcommon.scm @@ -16,22 +16,27 @@ ;; You should have received a copy of the GNU General Public License ;; along with Megatest. If not, see . ;; ;;====================================================================== +(declare (unit dcommon)) + +(declare (uses gutils)) +(declare (uses db)) +(declare (uses commonmod)) +(declare (uses rmtmod)) + (use format) (require-library iup) (import (prefix iup iup:)) (use canvas-draw) (import canvas-draw-iup) (use regex typed-records matchable) -(declare (unit dcommon)) - -(declare (uses gutils)) -(declare (uses db)) -;; (declare (uses synchash)) +(import commonmod + rmtmod + debugprint) (include "megatest-version.scm") (include "common_records.scm") (include "db_records.scm") (include "key_records.scm") @@ -54,10 +59,11 @@ update-mutex updaters updating uidat ;; needs to move to tabdat at some time hide-not-hide-tabs + target ) (define (dboard:commondat-make) (make-dboard:commondat curr-tab-num: 0 @@ -65,19 +71,41 @@ please-update: #t update-mutex: (make-mutex) updaters: (make-hash-table) updating: #f hide-not-hide-tabs: #f + target: "" )) ;; RADT => Matrix defstruct addition (defstruct dboard:graph-dat ((id #f) : string) ((color #f) : vector) ((flag #t) : boolean) ((cell #f) : number) ) + +;; RA => returns the tabdat stored at hashkey passed in commondat-tabdats table (e.g. 0 gives summary) +;; +(define (dboard:common-get-tabdat commondat #!key (tab-num #f)) + (let* ((tnum (or tab-num + (dboard:commondat-curr-tab-num commondat) + 0)) ;; tab-num value is curr-tab-num value in passed commondat + (ht (dboard:commondat-tabdats commondat)) + (res (hash-table-ref/default ht tnum #f))) + (or res + (let ((new-tabdat (dboard:tabdat-make-data))) + (hash-table-set! ht tnum new-tabdat) + new-tabdat)))) + +;; RA => sets the tabdat passed to the hashkey at commondat:tabdats hash table +;; +(define (dboard:common-set-tabdat! commondat tabnum tabdat) + (hash-table-set! + (dboard:commondat-tabdats commondat) + tabnum + tabdat)) ;; data for runs, tests etc. was used in run summary? ;; (defstruct dboard:runsdat ;; new system @@ -522,17 +550,20 @@ (let* ((shell (if (get-environment-variable "SHELL") (conc "-e " (get-environment-variable "SHELL")) "")) (command (conc "cd " rundir ";mt_xterm -T \"" (string-translate testfullname "()" " ") "\" " shell "&"))) - (print "Command =" command) + ;; (print "Command =" command) (common:without-vars command "MT_.*")) (message-window (conc "Directory " rundir " not found")))))) (xterm) - (print "Adding xterm code"))))) + ) + ) + ) +) ;;====================================================================== ;; D A T A T A B L E S ;;====================================================================== @@ -547,11 +578,11 @@ #:numcol 1 #:numlin (length key-vals) #:numcol-visible 1 #:numlin-visible (length key-vals) #:click-cb (lambda (obj lin col status) - (print "obj: " obj " lin: " lin " col: " col " status: " status))))) + (debug:print 0 *default-log-port* "obj: " obj " lin: " lin " col: " col " status: " status))))) ;; (iup:attribute-set! keys-matrix "0:0" "Run Keys") (iup:attribute-set! keys-matrix "WIDTH0" 0) (iup:attribute-set! keys-matrix "0:1" "Key Name") ;; (iup:attribute-set! keys-matrix "WIDTH1" "100") ;; fill in keys @@ -632,11 +663,12 @@ (common:max (map cadr col-indices)))) (max-visible (max (- (dboard:tabdat-num-tests tabdat) 15) 3)) (max-col-vis (if (> max-col 10) 10 max-col)) (numrows 1) (numcols 1)) - (iup:attribute-set! stats-matrix "CLEARVALUE" "CONTENTS") + (if (common:low-noise-print 60 "runs-stats-update-clear") + (iup:attribute-set! stats-matrix "CLEARVALUE" "CONTENTS")) (iup:attribute-set! stats-matrix "NUMCOL" max-col ) (iup:attribute-set! stats-matrix "NUMLIN" (if (< max-row max-visible) max-visible max-row)) ;; min of 20 (iup:attribute-set! stats-matrix "NUMCOL_VISIBLE" max-col-vis) (iup:attribute-set! stats-matrix "NUMLIN_VISIBLE" (if (> max-row max-visible) max-visible max-row)) ;;(print "row-indices: " row-indices " col-indices: " col-indices) @@ -701,11 +733,13 @@ #:numlin-visible 5 )) (colnames (list "Id" "MTver" "Pid" "Host" "Interface:OutPort" "RunTime" "State" "RunId")) (updater (lambda () (if (dashboard:monitor-changed? commondat tabdat) - (let ((servers (server:get-list *toppath* limit: 10))) + (let ((servers (case (rmt:transport-mode) + ((http)(server:choose-server *toppath* 'all-valid)) ;; (server:get-list *toppath* limit: 10))) + (else '())))) (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) @@ -713,26 +747,27 @@ ;; colnames) (set! rownum 1) (for-each (lambda (server) (set! colnum 0) - (match-let (((mod-time host port start-time pid) + ;; (("192.168.0.127" 60215 1669088591.0 "c85484f764df7a8550b0224409bd4bcd") + (match-let (((host port start-time server-id pid) server)) - (let* ((uptime (- (current-seconds) mod-time)) + (let* (;; (uptime (- (current-seconds) mod-time)) (runtime (if start-time - (- mod-time start-time) + (- (current-seconds) start-time) 0)) (vals (list "-" ;; (vector-ref server 0) ;; Id "-" ;; (vector-ref server 9) ;; MT-Ver pid ;; (vector-ref server 1) ;; Pid host ;; (vector-ref server 2) ;; Hostname (conc host ":" port) ;; (conc (vector-ref server 3) ":" (vector-ref server 4)) ;; IP:Port (seconds->hr-min-sec runtime) ;; (- (current-seconds) start-time)) ;; (vector-ref server 6))) - (cond - ((< uptime 5) "alive") - ((< uptime 16) "probably alive");; less than 15 seconds since mod, call it alive (vector-ref server 8) ;; State - (else "dead")) + "-" #;(cond + ((< uptime 5) "alive") + ((< uptime 16) "probably alive");; less than 15 seconds since mod, call it alive (vector-ref server 8) ;; State + (else "dead")) "-" ;; (vector-ref server 12) ;; RunId ))) (for-each (lambda (val) (let* ((row-col (conc rownum ":" colnum)) (curr-val (iup:attribute servers-matrix row-col))) @@ -742,11 +777,11 @@ (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"))) - (sort servers (lambda (a b)(> (car a)(car b)))))))))) + (sort servers (lambda (a b)(> (caddr a)(caddr b)))))))))) (set! colnum 0) (for-each (lambda (colname) (iup:attribute-set! servers-matrix (conc "0:" colnum) colname) (iup:attribute-set! servers-matrix "FITTOTEXT" (conc "C" colnum)) (set! colnum (+ colnum 1))) @@ -797,22 +832,23 @@ (iup:attribute fd "VALUE")) (iup:destroy! fd)))) ;; (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 "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 - ;; ) - )))) +;; (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 +;; ;; ) +;; )) + )) ;;====================================================================== ;; CANVAS STUFF FOR TESTS ;;====================================================================== @@ -953,13 +989,14 @@ (+ yoffset (* y scalef))) ;; sizex, sizey - canvas size ;; originx, originy - canvas origin ;; -(define (dcommon:initial-draw-tests cnv xadj yadj sizex sizey sizexmm sizeymm originx originy - tests-draw-state sorted-testnames test-records) - (let* ((dot-data (tests:lazy-dot test-records "plain" sizex sizey 'munged)) +(define (dcommon:initial-draw-tests cnv xadj yadj sizex sizey sizexmm sizeymm originx originy tests-draw-state sorted-testnames test-records) + (let* ((dot-data ;; (map cdr (filter + ;; (lambda (x)(equal? "node" (car x))) + (map string-split (tests:lazy-dot test-records "plain" sizex sizey))) ;; (tests:easy-dot test-records "plain"))) (xoffset (dcommon:get-xoffset tests-draw-state sizex xadj)) (yoffset (dcommon:get-yoffset tests-draw-state sizey yadj)) (no-dot (configf:lookup *configdat* "setup" "nodot")) (boxh 15) (boxw 10) @@ -1124,14 +1161,28 @@ #:readonly "YES" #:font "Courier New, -12" ))) (dboard:tabdat-command-tb-set! data tb) tb) + (iup:button "Execute" #:size "50x" #:action (lambda (obj) - ;; (let ((cmd (conc ;; "xterm -geometry 180x20 -e \"" - (common:run-a-command (iup:attribute (dboard:tabdat-command-tb data) "VALUE"))))))) + (let ((cmd (iup:attribute (dboard:tabdat-command-tb data) "VALUE"))) + (if (substring-index "no-runname-specified" cmd) + (debug:print 0 *default-log-port* "ERROR: no runname specified") + (begin + (if (substring-index "no-target-selected" cmd) + (debug:print 0 *default-log-port* "ERROR: no target selected") + (begin + (if (not (substring-index "-run" cmd)) + (debug:print 0 *default-log-port* "ERROR: No target selected") + (common:run-a-command (iup:attribute (dboard:tabdat-command-tb data) "VALUE")) + ) + ) + ) + ) + ))))))) ;; ";echo Press any key to continue;bash -c 'read -n 1 -s'\" &"))) ;; (system cmd))))))) (define (dcommon:command-action-selector commondat tabdat #!key (tab-num #f)) (iup:frame @@ -1156,15 +1207,14 @@ (let* ((default-run-name (seconds->work-week/day (current-seconds))) (tb (iup:textbox #:expand "HORIZONTAL" #:action (lambda (obj val txt) (debug:catch-and-dump (lambda () - ;; (print "obj: " obj " val: " val " unk: " unk) (dboard:tabdat-run-name-set! tabdat txt) ;; (iup:attribute obj "VALUE")) (dashboard:update-run-command tabdat)) "command-runname-selector tb action")) - #:value (or (args:get-arg "-runname") default-run-name (dboard:tabdat-run-name tabdat)))) + #:value (or default-run-name (dboard:tabdat-run-name tabdat)))) (lb (iup:listbox #:expand "HORIZONTAL" #:dropdown "YES" #:action (lambda (obj val index lbstate) (debug:catch-and-dump (lambda () @@ -1182,11 +1232,10 @@ (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")) runs-dat)))) - ;; (print "DEBUGINFO: run-names=" run-names) ;; (iup:attribute-set! lb "REMOVEITEM" "ALL") (iuplistbox-fill-list lb run-names selected-item: default-run-name)))))) ;; (dboard:tabdat-updater-for-runs-set! tabdat refresh-runs-list) (dboard:commondat-add-updater commondat refresh-runs-list tab-num: tab-num) ;; (refresh-runs-list) @@ -1353,11 +1402,10 @@ (let* ((status (vector-ref hed 3)) (val (vector-ref hed (- colnum 1))) (bgcolor (cond ((member (conc status) '("" "-" "#")) running-color) - ((member (conc status) '("0" 0)) white) (else test-status-color))) ; (else failcolor))) (mtrx-rc (conc rownum ":" colnum))) @@ -1413,36 +1461,10 @@ (begin (set! *last-monitor-update-time* run-update-time) ;; monitor-modtime) #t) #f))) -;; DOES NOT WORK RELIABLY WITH /tmp WAL mode files. Timestamps only change when the db -;; is closed (I think). If db dir starts with /tmp always return true -;; -(define (dashboard:database-changed? commondat tabdat #!key (context-key 'default)) - (let* ((run-update-time (current-seconds)) - (dbdir (dboard:tabdat-dbdir tabdat)) - (modtime (dashboard:get-youngest-run-db-mod-time dbdir)) - (recalc (dashboard:recalc modtime - (dboard:commondat-please-update commondat) - (dboard:get-last-db-update tabdat context-key)))) - ;; (dboard:tabdat-last-db-update tabdat)))) - (if recalc - (dboard:set-last-db-update! tabdat context-key run-update-time)) - (dboard:commondat-please-update-set! commondat #f) - recalc)) - -(define (dashboard:get-youngest-run-db-mod-time dbdir) - (handle-exceptions - exn - (begin - (debug:print 2 *default-log-port* "WARNING: error in accessing databases in get-youngest-run-db-mod-time: " ((condition-property-accessor 'exn 'message) exn) - " db-dir="dbdir ", exn=" exn) - (current-seconds)) ;; something went wrong - just print an error and return current-seconds - (common:max (map (lambda (filen) - (file-modification-time filen)) - (glob (conc dbdir "/*.db*")))))) (define (dboard:get-last-db-update tabdat context) (hash-table-ref/default (dboard:tabdat-last-db-update tabdat) context 0)) (define (dboard:set-last-db-update! tabdat context newtime) ADDED debugprint.scm Index: debugprint.scm ================================================================== --- /dev/null +++ debugprint.scm @@ -0,0 +1,183 @@ + +(declare (unit debugprint)) +(declare (uses mtargs)) + +(module debugprint + * + +(import scheme) +(cond-expand + (chicken-4 + (import + scheme + chicken + data-structures + posix + ports + extras + (prefix mtargs args:) + srfi-1 + ;; system-information + )) + (chicken-5 + (import + scheme + chicken.base + chicken.string + chicken.time + chicken.time.posix + chicken.port + chicken.process-context + chicken.process-context.posix + + srfi-1 + (prefix mtargs args:)) + + (define setenv set-environment-variable!) + )) + +;;====================================================================== +;; debug stuff +;;====================================================================== + +(define verbosity (make-parameter '())) +(define *default-log-port* (current-error-port)) +(define debug:print-logger (make-parameter #f)) ;; set to a proc to call on every logging print + +(define (debug:setup) + (let ((debugstr (or (args:get-arg "-debug") + (args:get-arg "-debug-noprop") + (get-environment-variable "MT_DEBUG_MODE")))) + (verbosity (debug:calc-verbosity debugstr 'q)) + (debug:check-verbosity (verbosity) debugstr) + ;; if we were handed a bad verbosity rule then we will override it with 1 and continue + (if (not (verbosity))(verbosity 1)) + (if (and (not (args:get-arg "-debug-noprop")) + (or (args:get-arg "-debug") + (not (get-environment-variable "MT_DEBUG_MODE")))) + (setenv "MT_DEBUG_MODE" (if (list? (verbosity)) + (string-intersperse (map conc (verbosity)) ",") + (conc (verbosity))))))) + +;; check verbosity, #t is ok +(define (debug:check-verbosity verbosity vstr) + (if (not (or (number? verbosity) + (list? verbosity))) + (begin + (print "ERROR: Invalid debug value \"" vstr "\"") + #f) + #t)) + +;;====================================================================== +;; (define (debug:print . params) #f) +;; (define (debug:print-info . params) #f) +;; +;; (define (set-functions dbgp dbgpinfo) +;; (set! debug:print dbgp) +;; (set! debug:print-info dbgpinfo)) + +;;====================================================================== +;; this was cached based on results from profiling but it turned out the profiling +;; somehow went wrong - perhaps too many processes writing to it. Leaving the caching +;; in for now but can probably take it out later. +;; +(define (debug:calc-verbosity vstr arg) ;; arg is 'v (verbose) or 'q (quiet) + (let* ((res (cond + ((number? vstr) vstr) + ((not (string? vstr)) 1) + ;; ((string-match "^\\s*$" vstr) 1) + (vstr (let ((debugvals (filter number? (map string->number (string-split vstr ","))))) + (cond + ((> (length debugvals) 1) debugvals) + ((> (length debugvals) 0)(car debugvals)) + (else 1)))) + ((eq? arg 'v) 2) ;; verbose + ((eq? arg 'q) 0) ;; quiet + (else 1)))) + (verbosity res) + res)) + +;;====================================================================== +;; check verbosity, #t is ok +#;(define (debug-check-verbosity verbosity vstr) + (if (not (or (number? verbosity) + (list? verbosity))) + (begin + (print "ERROR: Invalid debug value \"" vstr "\"") + #f) + #t)) + +(define (debug:debug-mode n) + (let* ((vb (verbosity))) + (cond + ((and (number? vb) ;; number number + (number? n)) + (<= n vb)) + ((and (list? vb) ;; list number + (number? n)) + (member n vb)) + ((and (list? vb) ;; list list + (list? n)) + (not (null? (lset-intersection! eq? vb n)))) + ((and (number? vb) + (list? n)) + (member vb n)) + (else #f)))) + +;; (define (debug:handle-remote-logging params) +;; (if (debug:print-logger) ;; NOTE: turn params into string to keep things simple for now +;; ((debug:print-logger)(conc "REMOTE ("(get-host-name)", pid="(current-process-id)") " +;; (string-intersperse (map conc params) " ") "; " +;; (string-intersperse (command-line-arguments) " "))))) + +(define debug:enable-timestamp (make-parameter #t)) + +(define (debug:timestamp) + (if (debug:enable-timestamp) + (conc (time->string + (seconds->local-time (current-seconds)) "%H:%M:%S") " ") + "")) + + (define (debug:print n e . params) + (if (debug:debug-mode n) + (with-output-to-port (or e (current-error-port)) + (lambda () + ;; (if *logging* + ;; (db:log-event (apply conc params)) + (apply print (debug:timestamp) params) + ;; (debug:handle-remote-logging params) + ))) + #t ;; only here to make remote stuff happy. It'd be nice to fix that ... + ) + +(define (debug:print-error n e . params) + ;; normal print + (if (debug:debug-mode n) + (with-output-to-port (if (port? e) e (current-error-port)) + (lambda () + (apply print "ERROR: " (debug:timestamp) params) + ;; (debug:handle-remote-logging (cons "ERROR: " params)) + ))) + ;; pass important messages to stderr + (if (and (eq? n 0)(not (eq? e (current-error-port)))) + (with-output-to-port (current-error-port) + (lambda () + (apply print "ERROR: " (debug:timestamp) params) + )))) + +(define (debug:print-info n e . params) + (if (debug:debug-mode n) + (with-output-to-port (if (port? e) e (current-error-port)) + (lambda () + (apply print "INFO: (" n ") "(debug:timestamp) params) ;; res) + ;; (debug:handle-remote-logging (cons "INFO: " params)) + )))) + +(define (debug:print-warn n e . params) + (if (debug:debug-mode n) + (with-output-to-port (if (port? e) e (current-error-port)) + (lambda () + (apply print "WARN: (" n ") " (debug:timestamp) params) ;; res) + ;; (debug:handle-remote-logging (cons "WARN: " params)) + )))) +) Index: diff-report.scm ================================================================== --- diff-report.scm +++ diff-report.scm @@ -16,11 +16,17 @@ ;; along with Megatest. If not, see . ;; (declare (unit diff-report)) (declare (uses common)) +(declare (uses debugprint)) (declare (uses rmt)) +(declare (uses rmtmod)) +(declare (uses commonmod)) +(import commonmod + rmtmod + debugprint) (include "common_records.scm") (use matchable) (use fmt) (use ducttape-lib) @@ -146,11 +152,11 @@ (define (diff:target+run-name->run-id target run-name) (let* ((keys (rmt:get-keys)) (target-parts (if target (string-split target "/") (map (lambda (x) "%") keys)))) (if (not (eq? (length keys) (length keys))) (begin - (print "Error: Target ("target") item count does not match fields count target tokens="target-parts" fields="keys) + (debug:print 0 *default-log-port* "Error: Target ("target") item count does not match fields count target tokens="target-parts" fields="keys) #f) (let* ((target-map (zip keys target-parts)) (qry-res (rmt:get-runs run-name 1 0 target-map))) (if (eq? 2 (vector-length qry-res)) @@ -384,22 +390,10 @@ (if html-output-file (with-output-to-file html-output-file (lambda () (print html-body)))) (when (and email-recipients-list (> (length email-recipients-list) 0)) (sendmail (string-join email-recipients-list ",") email-subject html-body use_html: #t)) html-body)) - - - - - -;; (let* ((src-run-name "all57") -;; (dest-run-name "all60") -;; (src-run-id (diff:run-name->run-id src-run-name)) -;; (dest-run-id (diff:run-name->run-id dest-run-name)) -;; (to-list (list "bjbarcla"))) -;; (diff:deliver-diff-report src-run-id dest-run-id email-recipients-list: to-list html-output-file: "/tmp/bjbarcla/zippy.html") -;; ) (define (do-diff-report src-target src-runname dest-target dest-runname html-file to-list-raw) (let* (;;(src-target "nope%") ;;(src-runname "all57") ;;(dest-target "%") @@ -410,16 +404,16 @@ (to-list (if (string? to-list-raw) (string-split to-list-raw ",:") #f)) ) (cond ((not src-run-id) - (print "No match for source target/runname="src-target"/"src-runname) - (print "Cannot proceed.") + (debug:print 0 *default-log-port* "No match for source target/runname="src-target"/"src-runname) + (debug:print 0 *default-log-port* "Cannot proceed.") #f) ((not dest-run-id) - (print "No match for source target/runname="dest-target"/"dest-runname) - (print "Cannot proceed.") + (debug:print 0 *default-log-port* "No match for source target/runname="dest-target"/"dest-runname) + (debug:print 0 *default-log-port* "Cannot proceed.") #f) (else (diff:deliver-diff-report src-run-id dest-run-id email-recipients-list: to-list html-output-file: html-file))))) Index: docs/Makefile ================================================================== --- docs/Makefile +++ docs/Makefile @@ -33,5 +33,8 @@ megatest.pdf : megatest.lyx lyx -e pdf2 megatest.lyx pkts.pdf : pkts.dot dot -Tpdf pkts.dot -o pkts.pdf + +stepwise.pdf : stepwise-rpc-via-direct-and-tcp-or-http.dot + dot stepwise-rpc-via-direct-and-tcp-or-http.dot -Tpdf -o stepwise.pdf ADDED docs/csirc Index: docs/csirc ================================================================== --- /dev/null +++ docs/csirc @@ -0,0 +1,33 @@ +(cond-expand + (chicken-4 + ;; chicken 4 stuff here + (use readline) + (current-input-port (make-readline-port)) + (install-history-file #f "/.csi.history") + ) + (chicken-5 + (import (chicken load)) + (import (chicken format)) + (import (chicken process-context)) + (import (chicken process signal)) + (load-verbose #f) + (let () + (unless (get-environment-variable "INSIDE_EMACS") + (import breadline) + (import breadline-scheme-completion) + (history-file (format "~a/.csi_history" (get-environment-variable "HOME"))) + (stifle-history! 10000) + (completer-word-break-characters-set! "\"\'`;|(") + (completer-set! scheme-completer) + (basic-quote-characters-set! "\"|") + (variable-bind! "blink-matching-paren" "on") + (paren-blink-timeout-set! 200000) + (let ((handler (signal-handler signal/int))) + (set-signal-handler! signal/int + (lambda (s) + (cleanup-after-signal!) + (reset-after-signal!) + (handler s)))) + (on-exit reset-terminal!) + (current-input-port (make-readline-port)))) + )) Index: docs/manual/Makefile ================================================================== --- docs/manual/Makefile +++ docs/manual/Makefile @@ -37,10 +37,13 @@ # dos2unix megatest_manual.html megatest_manual.pdf : megatest_manual.txt *.txt *png *.dot a2x -a toc -f pdf megatest_manual.txt +%.pdf : %.dot + dot -Tpdf $*.dot -o$*.pdf + server.ps : server.dot dot -Tps server.dot > server.ps client.ps : client.dot dot -Tps client.dot > client.ps Index: docs/manual/bisecting.png ================================================================== --- docs/manual/bisecting.png +++ docs/manual/bisecting.png cannot compute difference between binary files Index: docs/manual/debugging.txt ================================================================== --- docs/manual/debugging.txt +++ docs/manual/debugging.txt @@ -162,17 +162,17 @@ ---------------------------------------------------------------------- .How to check variable values and inspect logs at each stage [width="80%",cols="<,2m,2m",frame="topbot",options="header"] |====================== -|Stage | How to inspect | Watch for +|Stage | How to inspect | Watch for or try ... |A: post config processing | megatest -show-config -target your/target | #f (failed var processing) |B: post runconfig | megatest -show-runconfig -target your/target | Add -debug 0,9 to see which file your settings come from |C: processing testconfigs | inspect output from "megatest -run ..." | Messages indicating issues process configs, dependency problems |D: process testconfig for test launch | inspect output from megatest runner | Zero items (items expansion yielded no items) -|E,F: launching test | start test xterm, look at mt_launch.log | Did your batch system accept the job? Has the job landed on a machine? -|G: starting test | look at your batch systems logs for the process | Did the megatest -execute process start and run? +|E,F: launching test | start test xterm, look at mt_launch.log | Did your batch system accept the job? Has the job landed on a machine? +|G: starting test | look at your batch systems logs for the process | Did the megatest -execute process start and run? Extract the "megatest -execute ..." command and run it from your xterm. |H,H1,H2: step exectution | look at .log, .html and your own internal logs | Do you have sufficiently tight logpro rules? You must always have a "required" rule! |====================== Bisecting megatest.csh/sh ^^^^^^^^^^^^^^^^^^^^^^^^^ @@ -232,10 +232,11 @@ When this test is run an xterm will pop up. In that xterm the environment is exactly that in which the script "getcellnames.sh" would run. You can now debug the script to find out why it isn't working as expected. +Similarly in a script just call the xterm. NOTE: This technique can be very helpful in debugging running of EDA tools in Perl, Ruby, Python or tcl scripts: .Perl example .............................. some_code(); @@ -270,25 +271,44 @@ In scripts just insert the commands, this example helps you identify if "some commands ..." changed any environment variables.: .myscript.sh .............................. -env > somefile-before.log +env | sort > somefile-before.log some commands ... -env > somefile-after.log +env | sort > somefile-after.log .............................. .Use meld to examine the differences .............................. meld somefile-before.log somefile-after.log .............................. -Start an xterm to examine the environment, run scripts etc: +Oneshot Modifying a Variable +^^^^^^^^^^^^^^^^^^^^^^^^^^^^ + +To try various values for a variable without mutating the current value + +.within a bash shell +.............................. +SOMEVAR=123 runcmd.sh +.............................. + +.within csh +.............................. +(setenv SOMEVAR 123;runcmd.sh) + +# OR + +env SOMEVAR=123 runcmd.sh +.............................. -In a config file: +Capturing output from a command +^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^ -.megatest.config, runconfigs.config and testconfig files +.Use the "script" utility .............................. -#{shell xterm} (this blocks) +script -c "virtuoso -params and switches ..." .............................. -Similarly in a script just call the xterm. + + Index: docs/manual/megatest-test-stages.png ================================================================== --- docs/manual/megatest-test-stages.png +++ docs/manual/megatest-test-stages.png cannot compute difference between binary files Index: docs/manual/megatest_manual.html ================================================================== --- docs/manual/megatest_manual.html +++ docs/manual/megatest_manual.html @@ -1,10 +1,10 @@ - + The Megatest Users Manual

Dashboard

" (pathname-strip-directory *toppath*) "

Server Stats

Runs

" (pathname-strip-directory toppath) "