Index: Makefile ================================================================== --- Makefile +++ Makefile @@ -20,21 +20,24 @@ SHELL=/bin/bash PREFIX=$(PWD) CSCOPTS= INSTALL=install SRCFILES = common.scm items.scm launch.scm \ - ods.scm runconfig.scm server.scm configf.scm \ - db.scm keys.scm margs.scm megatest-version.scm \ + ods.scm runconfig.scm configf.scm \ + keys.scm margs.scm server.o megatest-version.scm \ process.scm runs.scm tasks.scm tests.scm genexample.scm \ http-transport.scm filedb.scm tdb.scm \ client.scm mt.scm \ - ezsteps.scm lock-queue.scm sdb.scm \ - rmt.scm api.scm subrun.scm \ - portlogger.scm archive.scm env.scm diff-report.scm cgisetup/models/pgdb.scm + ezsteps.scm lock-queue.scm \ + rmt.scm subrun.scm \ + archive.scm env.scm diff-report.scm cgisetup/models/pgdb.scm # module source files -MSRCFILES = ftail.scm +MSRCFILES = ftail.scm portlogger.scm nmsg-transport.scm db.scm api.scm + +# files needed for mtserve +MTSERVEFILES = common.scm megatest-version.scm margs.scm server.scm keys.scm ods.scm rmt.scm # Eggs to install (straightforward ones) EGGS=matchable readline apropos base64 regex-literals format regex-case test coops trace csv \ dot-locking posix-utils posix-extras directory-utils hostinfo tcp-server rpc csv-xml fmt \ json md5 awful http-client spiffy uri-common intarweb spiffy-request-vars \ @@ -42,10 +45,11 @@ GUISRCF = dashboard-context-menu.scm dashboard-tests.scm dashboard-guimonitor.scm gutils.scm dcommon.scm tree.scm vg.scm OFILES = $(SRCFILES:%.scm=%.o) GOFILES = $(GUISRCF:%.scm=%.o) +MTSERVEOFILES = $(MTSERVEFILES:%.scm=%.o) MOFILES = $(addprefix mofiles/,$(MSRCFILES:%.scm=%.o)) mofiles/%.o : %.scm mkdir -p mofiles @@ -68,36 +72,36 @@ ARCHSTR=$(shell if [[ -e /usr/bin/sw_vers ]]; then /usr/bin/sw_vers -productVersion; else lsb_release -sr; fi) # ARCHSTR=$(shell bash -c "echo \$$MACHTYPE") PNGFILES = $(shell cd docs/manual;ls *png) -#all : $(PREFIX)/bin/.$(ARCHSTR) mtest dboard mtut ndboard -all : $(PREFIX)/bin/.$(ARCHSTR) mtest dboard mtut +all : $(PREFIX)/bin/.$(ARCHSTR) mtest dboard mtut mtserve -mtest: $(OFILES) readline-fix.scm megatest.o $(MOFILES) mofiles/ftail.o +mtest: $(OFILES) readline-fix.scm megatest.o $(MOFILES) csc $(CSCOPTS) $(OFILES) $(MOFILES) megatest.o -o mtest +mtserve: $(MTSERVEOFILES) readline-fix.scm mtserve.o $(MOFILES) + csc $(CSCOPTS) $(MTSERVEOFILES) $(MOFILES) mtserve.o -o mtserve + showmtesthash: @echo $(MTESTHASH) dboard : $(OFILES) $(GOFILES) dashboard.scm $(MOFILES) csc $(CSCOPTS) $(OFILES) dashboard.scm $(GOFILES) $(MOFILES) -o dboard ndboard : newdashboard.scm $(OFILES) $(GOFILES) csc $(CSCOPTS) $(OFILES) $(GOFILES) newdashboard.scm -o ndboard -mtut: $(OFILES) megatest-fossil-hash.scm mtut.scm - csc $(CSCOPTS) $(OFILES) mtut.scm -o mtut +mtut: $(OFILES) megatest-fossil-hash.scm mtut.scm $(MOFILES) + csc $(CSCOPTS) $(OFILES) $(MOFILES) mtut.scm -o mtut TCMTOBJS = \ - api.o \ archive.o \ cgisetup/models/pgdb.o \ client.o \ common.o \ configf.o \ - db.o \ env.o \ http-transport.o \ items.o \ keys.o \ launch.o \ @@ -104,25 +108,27 @@ lock-queue.o \ margs.o \ mt.o \ megatest-version.o \ ods.o \ - portlogger.o \ process.o \ rmt.o \ - rpc-transport.o \ runconfig.o \ runs.o \ server.o \ tasks.o \ tdb.o \ tests.o \ subrun.o \ + +# api.o \ +# db.o \ +# rpc-transport.o \ +# portlogger.o \ - -tcmt : $(TCMTOBJS) tcmt.scm - csc $(CSCOPTS) $(TCMTOBJS) tcmt.scm -o tcmt +tcmt : $(TCMTOBJS) tcmt.scm $(MOFILES) + csc $(CSCOPTS) $(TCMTOBJS) $(MOFILES) tcmt.scm -o tcmt # install documentation to $(PREFIX)/docs # DOES NOT REBUILD DOCS # $(PREFIX)/share/docs/megatest_manual.html : docs/manual/megatest_manual.html @@ -156,27 +162,45 @@ megatest.o : megatest-fossil-hash.scm rmt.scm client.scm common.scm configf.scm dashboard-guimonitor.scm dashboard-tests.scm dashboard.scm db.scm dcommon.scm ezsteps.scm fs-transport.scm http-transport.scm index-tree.scm items.scm keys.scm launch.scm megatest.scm monitor.scm mt.scm newdashboard.scm runconfig.scm runs.scm server.scm tdb.scm tests.scm tree.scm : common_records.scm common_records.scm : altdb.scm vg.o dashboard.o : vg_records.scm dcommon.o : run_records.scm + +# module deps +http-transport.o : mofiles/portlogger.o +megatest.o rnt.o : mofiles/nmsg-transport.o + # Temporary while transitioning to new routine # runs.o : run-tests-queue-classic.scm run-tests-queue-new.scm megatest-fossil-hash.scm : $(SRCFILES) megatest.scm *_records.scm echo "(define megatest-fossil-hash \"$(MTESTHASH)\")" > megatest-fossil-hash.new if ! diff -q megatest-fossil-hash.new megatest-fossil-hash.scm ; then echo copying .new to .scm;cp -f megatest-fossil-hash.new megatest-fossil-hash.scm;fi $(OFILES) $(GOFILES) : common_records.scm -%.o : %.scm $(MOFILES) - csc $(CSCOPTS) -c $< $(MOFILES) +# %.o : %.scm $(MOFILES) +# csc $(CSCOPTS) -c $< $(MOFILES) + +%.o : %.scm + csc $(CSCOPTS) -c $< $(PREFIX)/bin/.$(ARCHSTR)/mtest : mtest utils/mk_wrapper @echo Installing to PREFIX=$(PREFIX) $(INSTALL) mtest $(PREFIX)/bin/.$(ARCHSTR)/mtest utils/mk_wrapper $(PREFIX) mtest $(PREFIX)/bin/megatest chmod a+x $(PREFIX)/bin/megatest + +$(PREFIX)/bin/.$(ARCHSTR)/mtserve : mtserve utils/mk_wrapper + @echo Installing to PREFIX=$(PREFIX) + $(INSTALL) mtserve $(PREFIX)/bin/.$(ARCHSTR)/mtserve + utils/mk_wrapper $(PREFIX) mtserve $(PREFIX)/bin/mtserver + chmod a+x $(PREFIX)/bin/mtserver + +$(PREFIX)/bin/mtserver : $(PREFIX)/bin/.$(ARCHSTR)/mtserve utils/mk_wrapper + utils/mk_wrapper $(PREFIX) mtserve $(PREFIX)/bin/mtserver + chmod a+x $(PREFIX)/bin/mtserver $(PREFIX)/bin/.$(ARCHSTR)/ndboard : ndboard $(INSTALL) ndboard $(PREFIX)/bin/.$(ARCHSTR)/ndboard $(PREFIX)/bin/newdashboard : $(PREFIX)/bin/.$(ARCHSTR)/ndboard utils/mk_wrapper @@ -278,11 +302,11 @@ chmod a+x $(PREFIX)/bin/dashboard $(INSTALL) dboard $(PREFIX)/bin/.$(ARCHSTR)/dboard install : $(PREFIX)/bin/.$(ARCHSTR) $(PREFIX)/bin/.$(ARCHSTR)/mtest $(PREFIX)/bin/megatest \ $(PREFIX)/bin/.$(ARCHSTR)/dboard $(PREFIX)/bin/dashboard $(HELPERS) $(PREFIX)/bin/nbfake \ - $(PREFIX)/bin/serialize-env \ + $(PREFIX)/bin/serialize-env $(PREFIX)/bin/mtserver \ $(PREFIX)/bin/nbfind $(PREFIX)/bin/loadrunner $(PREFIX)/bin/viewscreen $(PREFIX)/bin/mt_xterm \ $(PREFIX)/share/docs/megatest_manual.html $(PREFIX)/bin/remrun \ $(PREFIX)/share/docs/megatest_manual.html $(PREFIX)/bin/remrun $(PREFIX)/bin/mtutil \ $(PREFIX)/bin/tcmt $(PREFIX)/share/db/mt-pg.sql \ $(PREFIX)/share/js/jquery-3.1.0.slim.min.js @@ -303,11 +327,11 @@ $(MTQA_FOSSIL) : fossil clone https://www.kiatoa.com/fossils/megatest_qa $(MTQA_FOSSIL) clean : - rm -f $(OFILES) $(GOFILES) $(MOFILES) $(TCMTOBJS) $(PREFIX)/megatest $(PREFIX)/dashboard mtest mtutil dboard dboard.o megatest.o dashboard.o megatest-fossil-hash.* altdb.scm mofiles/*.o vg.o + rm -f $(OFILES) $(GOFILES) $(MOFILES) $(TCMTOBJS) $(PREFIX)/megatest $(PREFIX)/dashboard mtest mtutil dboard dboard.o megatest.o dashboard.o megatest-fossil-hash.* altdb.scm mofiles/*.o vg.o *import.scm #====================================================================== # Make the records files #====================================================================== @@ -402,12 +426,12 @@ fi if csi -ne '(use postgresql)';then \ echo "(use postgresql)(hash-table-set! *available-db* 'postgresql #t)" >> altdb.scm;\ fi -portlogger-example : portlogger-example.scm api.o archive.o client.o common.o configf.o dashboard-tests.o dashboard-context-menu.o db.o dcommon.o ezsteps.o filedb.o genexample.o gutils.o http-transport.o items.o keys.o launch.o lock-queue.o margs.o megatest-version.o mt.o ods.o portlogger.o process.o rmt.o rpc-transport.o runconfig.o runs.o sdb.o server.o synchash.o tasks.o tdb.o tests.o tree.o - csc $(CSCOPTS) portlogger-example.scm api.o archive.o client.o common.o configf.o dashboard-tests.o dashboard-context-menu.o db.o dcommon.o ezsteps.o filedb.o genexample.o gutils.o http-transport.o items.o keys.o launch.o lock-queue.o margs.o megatest-version.o mt.o ods.o portlogger.o process.o rmt.o rpc-transport.o runconfig.o runs.o sdb.o server.o synchash.o tasks.o tdb.o tests.o tree.o +portlogger-example : portlogger-example.scm portlogger.o + csc $(CSCOPTS) portlogger-example.scm portlogger.o # create a pdf dot graphviz diagram from notations in rmt.scm rmt.pdf : rmt.scm grep ';;DOT' rmt.scm | sed -e 's/.*;;DOT //' > rmt.dot;dot -Tpdf rmt.dot -o rmt.pdf Index: api.scm ================================================================== --- api.scm +++ api.scm @@ -16,355 +16,20 @@ ;; You should have received a copy of the GNU General Public License ;; along with Megatest. If not, see . ;; ;;====================================================================== -(use srfi-69 posix) - -(declare (unit api)) -(declare (uses rmt)) -(declare (uses db)) -(declare (uses tasks)) - -;; allow these queries through without starting a server -;; -(define api:read-only-queries - '(get-key-val-pairs - get-var - get-keys - get-key-vals - test-toplevel-num-items - get-test-info-by-id - get-steps-info-by-id - get-data-info-by-id - test-get-rundir-from-test-id - get-count-tests-running-for-testname - get-count-tests-running - get-count-tests-running-in-jobgroup - get-previous-test-run-record - get-matching-previous-test-run-records - test-get-logfile-info - test-get-records-for-index-file - get-testinfo-state-status - test-get-top-process-pid - test-get-paths-matching-keynames-target-new - get-prereqs-not-met - get-count-tests-running-for-run-id - get-run-info - get-run-status - get-run-stats - get-run-times - get-targets - get-target - ;; register-run - get-tests-tags - get-test-times - get-tests-for-run - get-test-id - get-tests-for-runs-mindata - get-tests-for-run-mindata - get-run-name-from-id - get-runs - simple-get-runs - get-num-runs - get-runs-cnt-by-patt - get-all-run-ids - get-prev-run-ids - get-run-ids-matching-target - get-runs-by-patt - get-steps-data - get-steps-for-test - read-test-data - read-test-data* - login - tasks-get-last - testmeta-get-record - have-incompletes? - synchash-get - get-changed-record-ids - get-run-record-ids - )) - -(define api:write-queries - '( - get-keys-write ;; dummy "write" query to force server start - - ;; SERVERS - start-server - kill-server - - ;; TESTS - test-set-state-status-by-id - delete-test-records - delete-old-deleted-test-records - test-set-state-status - test-set-top-process-pid - set-state-status-and-roll-up-items - update-pass-fail-counts - top-test-set-per-pf-counts ;; (db:top-test-set-per-pf-counts (db:get-db *db* 5) 5 "runfirst") - - ;; RUNS - register-run - set-tests-state-status - delete-run - lock/unlock-run - update-run-event_time - mark-incomplete - - ;; STEPS - teststep-set-status! - - ;; TEST DATA - test-data-rollup - csv->test-data - - ;; MISC - sync-inmem->db - - ;; TESTMETA - testmeta-add-record - testmeta-update-field - - ;; TASKS - tasks-add - tasks-set-state-given-param-key - )) - -;; These are called by the server on recipt of /api calls -;; - keep it simple, only return the actual result of the call, i.e. no meta info here -;; -;; - returns #( flag result ) -;; -(define (api:execute-requests dbstruct dat) - (handle-exceptions - exn - (let ((call-chain (get-call-chain))) - (debug:print 0 *default-log-port* "WARNING: api:execute-requests received an exception from peer, dat=" dat) - (print-call-chain (current-error-port)) - (debug:print 0 *default-log-port* " message: " ((condition-property-accessor 'exn 'message) exn)) - (vector #f (vector exn call-chain dat))) ;; return some stuff for debug if an exception happens - (cond - ((not (vector? dat)) ;; it is an error to not receive a vector - (vector #f (vector #f "remote must be called with a vector"))) - ((> *api-process-request-count* 20) ;; 20) - (debug:print 0 *default-log-port* "WARNING: api:execute-requests received an overloaded message.") - (set! *server-overloaded* #t) - (vector #f (vector #f 'overloaded))) ;; the inner vector is what gets returned. nope, don't know why. please refactor! - (else - (let* ((cmd-in (vector-ref dat 0)) - (cmd (if (symbol? cmd-in) - cmd-in - (string->symbol cmd-in))) - (params (vector-ref dat 1)) - (start-t (current-milliseconds)) - (readonly-mode (dbr:dbstruct-read-only dbstruct)) - (readonly-command (member cmd api:read-only-queries)) - (writecmd-in-readonly-mode (and readonly-mode (not readonly-command))) - (res - (if writecmd-in-readonly-mode - (conc "attempt to run write command "cmd" on a read-only database") - (case cmd - ;;=============================================== - ;; READ/WRITE QUERIES - ;;=============================================== - - ((get-keys-write) (db:get-keys dbstruct)) ;; force a dummy "write" query to force server; for debug in -repl - - ;; SERVERS - ((start-server) (apply server:kind-run params)) - ((kill-server) (set! *server-run* #f)) - - ;; TESTS - - ;;((test-set-state-status-by-id) (apply mt:test-set-state-status-by-id dbstruct params)) - ;;BB - commented out above because it was calling below, eventually, incorrectly (dbstruct passed to mt:test-set-state-status-by-id, which previosly did more, but now only passes thru to db:set-state-status-and-roll-up-items. - ((test-set-state-status-by-id) - - ;; (define (db:set-state-status-and-roll-up-items dbstruct run-id test-name item-path state status comment) - (db:set-state-status-and-roll-up-items - dbstruct - (list-ref params 0) ; run-id - (list-ref params 1) ; test-name - #f ; item-path - (list-ref params 2) ; state - (list-ref params 3) ; status - (list-ref params 4) ; comment - )) - - ((delete-test-records) (apply db:delete-test-records dbstruct params)) - ((delete-old-deleted-test-records) (apply db:delete-old-deleted-test-records dbstruct params)) - ((test-set-state-status) (apply db:test-set-state-status dbstruct params)) - ((test-set-top-process-pid) (apply db:test-set-top-process-pid dbstruct params)) - ((set-state-status-and-roll-up-items) (apply db:set-state-status-and-roll-up-items dbstruct params)) - ((top-test-set-per-pf-counts) (apply db:top-test-set-per-pf-counts dbstruct params)) - ((test-set-archive-block-id) (apply db:test-set-archive-block-id dbstruct params)) - - ;; RUNS - ((register-run) (apply db:register-run dbstruct params)) - ((set-tests-state-status) (apply db:set-tests-state-status dbstruct params)) - ((delete-run) (apply db:delete-run dbstruct params)) - ((lock/unlock-run) (apply db:lock/unlock-run dbstruct params)) - ((update-run-event_time) (apply db:update-run-event_time dbstruct params)) - ((update-run-stats) (apply db:update-run-stats dbstruct params)) - ((set-var) (apply db:set-var dbstruct params)) - ((del-var) (apply db:del-var dbstruct params)) - - ;; STEPS - ((teststep-set-status!) (apply db:teststep-set-status! dbstruct params)) - - ;; TEST DATA - ((test-data-rollup) (apply db:test-data-rollup dbstruct params)) - ((csv->test-data) (apply db:csv->test-data dbstruct params)) - - ;; MISC - ((sync-inmem->db) (let ((run-id (car params))) - (db:sync-touched dbstruct run-id force-sync: #t))) - ((mark-incomplete) (apply db:find-and-mark-incomplete dbstruct params)) - - ;; TESTMETA - ((testmeta-add-record) (apply db:testmeta-add-record dbstruct params)) - ((testmeta-update-field) (apply db:testmeta-update-field dbstruct params)) - ((get-tests-tags) (db:get-tests-tags dbstruct)) - - ;; TASKS - ((tasks-add) (apply tasks:add dbstruct params)) - ((tasks-set-state-given-param-key) (apply tasks:set-state-given-param-key dbstruct params)) - ((tasks-get-last) (apply tasks:get-last dbstruct params)) - - ;; NO SYNC DB - ((no-sync-set) (apply db:no-sync-set *no-sync-db* params)) - ((no-sync-get/default) (apply db:no-sync-get/default *no-sync-db* params)) - ((no-sync-del!) (apply db:no-sync-del! *no-sync-db* params)) - ((no-sync-get-lock) (apply db:no-sync-get-lock *no-sync-db* params)) - - ;; ARCHIVES - ;; ((archive-get-allocations) - ((archive-register-disk) (apply db:archive-register-disk dbstruct params)) - ((archive-register-block-name)(apply db:archive-register-block-name dbstruct params)) - ((archive-allocate-testsuite/area-to-block)(apply db:archive-allocate-testsuite/area-to-block dbstruct block-id testsuite-name areakey)) - - ;;====================================================================== - ;; READ ONLY QUERIES - ;;====================================================================== - - ;; KEYS - ((get-key-val-pairs) (apply db:get-key-val-pairs dbstruct params)) - ((get-keys) (db:get-keys dbstruct)) - ((get-key-vals) (apply db:get-key-vals dbstruct params)) - ((get-target) (apply db:get-target dbstruct params)) - ((get-targets) (db:get-targets dbstruct)) - - ;; ARCHIVES - ((test-get-archive-block-info) (apply db:test-get-archive-block-info dbstruct params)) - - ;; TESTS - ((test-toplevel-num-items) (apply db:test-toplevel-num-items dbstruct params)) - ((get-test-info-by-id) (apply db:get-test-info-by-id dbstruct params)) - ((test-get-rundir-from-test-id) (apply db:test-get-rundir-from-test-id dbstruct params)) - ((get-count-tests-running-for-testname) (apply db:get-count-tests-running-for-testname dbstruct params)) - ((get-count-tests-running) (apply db:get-count-tests-running dbstruct params)) - ((get-count-tests-running-in-jobgroup) (apply db:get-count-tests-running-in-jobgroup dbstruct params)) - ;; ((delete-test-step-records) (apply db:delete-test-step-records dbstruct params)) - ((get-previous-test-run-record) (apply db:get-previous-test-run-record dbstruct params)) - ((get-matching-previous-test-run-records)(apply db:get-matching-previous-test-run-records dbstruct params)) - ((test-get-logfile-info) (apply db:test-get-logfile-info dbstruct params)) - ((test-get-records-for-index-file) (apply db:test-get-records-for-index-file dbstruct params)) - ((get-testinfo-state-status) (apply db:get-testinfo-state-status dbstruct params)) - ((test-get-top-process-pid) (apply db:test-get-top-process-pid dbstruct params)) - ((test-get-paths-matching-keynames-target-new) (apply db:test-get-paths-matching-keynames-target-new dbstruct params)) - ((get-prereqs-not-met) (apply db:get-prereqs-not-met dbstruct params)) - ((get-count-tests-running-for-run-id) (apply db:get-count-tests-running-for-run-id dbstruct params)) - ((synchash-get) (apply synchash:server-get dbstruct params)) - ((get-raw-run-stats) (apply db:get-raw-run-stats dbstruct params)) - ((get-test-times) (apply db:get-test-times dbstruct params)) - - ;; RUNS - ((get-run-info) (apply db:get-run-info dbstruct params)) - ((get-run-status) (apply db:get-run-status dbstruct params)) - ((set-run-status) (apply db:set-run-status dbstruct params)) - ((get-tests-for-run) (apply db:get-tests-for-run dbstruct params)) - ((get-test-id) (apply db:get-test-id dbstruct params)) - ((get-tests-for-run-mindata) (apply db:get-tests-for-run-mindata dbstruct params)) - ((get-tests-for-runs-mindata) (apply db:get-tests-for-runs-mindata dbstruct params)) - ((get-runs) (apply db:get-runs dbstruct params)) - ((simple-get-runs) (apply db:simple-get-runs dbstruct params)) - ((get-num-runs) (apply db:get-num-runs dbstruct params)) - ((get-runs-cnt-by-patt) (apply db:get-runs-cnt-by-patt dbstruct params)) - ((get-all-run-ids) (db:get-all-run-ids dbstruct)) - ((get-prev-run-ids) (apply db:get-prev-run-ids dbstruct params)) - ((get-run-ids-matching-target) (apply db:get-run-ids-matching-target dbstruct params)) - ((get-runs-by-patt) (apply db:get-runs-by-patt dbstruct params)) - ((get-run-name-from-id) (apply db:get-run-name-from-id dbstruct params)) - ((get-main-run-stats) (apply db:get-main-run-stats dbstruct params)) - ((get-var) (apply db:get-var dbstruct params)) - ((get-run-stats) (apply db:get-run-stats dbstruct params)) - ((get-run-times) (apply db:get-run-times dbstruct params)) - - ;; STEPS - ((get-steps-data) (apply db:get-steps-data dbstruct params)) - ((get-steps-for-test) (apply db:get-steps-for-test dbstruct params)) - ((get-steps-info-by-id) (apply db:get-steps-info-by-id dbstruct params)) - - ;; TEST DATA - ((read-test-data) (apply db:read-test-data dbstruct params)) - ((read-test-data*) (apply db:read-test-data* dbstruct params)) - ((get-data-info-by-id) (apply db:get-data-info-by-id dbstruct params)) - - ;; MISC - ((get-latest-host-load) (apply db:get-latest-host-load dbstruct params)) - ((have-incompletes?) (apply db:have-incompletes? dbstruct params)) - ((login) (apply db:login dbstruct params)) - ((general-call) (let ((stmtname (car params)) - (run-id (cadr params)) - (realparams (cddr params))) - (db:general-call dbstruct stmtname realparams))) - ((sdb-qry) (apply sdb:qry params)) - ((ping) (current-process-id)) - ((get-changed-record-ids) (apply db:get-changed-record-ids dbstruct params)) - ((get-run-record-ids) (apply db:get-run-record-ids dbstruct params)) - ;; TESTMETA - ((testmeta-get-record) (apply db:testmeta-get-record dbstruct params)) - - ;; TASKS - ((find-task-queue-records) (apply tasks:find-task-queue-records dbstruct params)) - (else - (debug:print 0 *default-log-port* "ERROR: bad api call " cmd) - (conc "ERROR: BAD api call " cmd)))))) - - ;; save all stats - (let ((delta-t (- (current-milliseconds) - start-t))) - (hash-table-set! *db-api-call-time* cmd - (cons delta-t (hash-table-ref/default *db-api-call-time* cmd '())))) - (if writecmd-in-readonly-mode - (vector #f res) - (vector #t res))))))) - -;; http-server send-response -;; api:process-request -;; db:* -;; -;; NB// Runs on the server as part of the server loop -;; -(define (api:process-request dbstruct $) ;; the $ is the request vars proc - (set! *api-process-request-count* (+ *api-process-request-count* 1)) - (let* ((cmd ($ 'cmd)) - (paramsj ($ 'params)) - (params (db:string->obj paramsj transport: 'http)) ;; incoming data from the POST (or is it a GET?) - (resdat (api:execute-requests dbstruct (vector cmd params))) ;; process the request, resdat = #( flag result ) - (success (vector-ref resdat 0)) - (res (vector-ref resdat 1))) ;; (vector flag payload), get the payload, ignore the flag (why?) - (if (not success) - (debug:print 0 *default-log-port* "ERROR: success flag is #f for " cmd " with params " params)) - (if (> *api-process-request-count* *max-api-process-requests*) - (set! *max-api-process-requests* *api-process-request-count*)) - (set! *api-process-request-count* (- *api-process-request-count* 1)) - ;; This can be here but needs controls to ensure it doesn't run more than every 4 seconds - ;; (rmt:dat->json-str - ;; (if (or (string? res) - ;; (list? res) - ;; (number? res) - ;; (boolean? res)) - ;; res - ;; (list "ERROR, not string, list, number or boolean" 1 cmd params res))))) - (db:obj->string res transport: 'http))) - +(declare (unit api)) + +(module + api + ( + * + ) + +(import scheme posix chicken data-structures ports) + + +(define (api:execute-requests . args) #t) +(define (api:process-request . args) #t) + +) Index: client.scm ================================================================== --- client.scm +++ client.scm @@ -31,91 +31,86 @@ (declare (uses tasks)) ;; tasks are where stuff is maintained about what is running. (include "common_records.scm") (include "db_records.scm") -;; client:get-signature -(define (client:get-signature) - (if *my-client-signature* *my-client-signature* - (let ((sig (conc (get-host-name) " " (current-process-id)))) - (set! *my-client-signature* sig) - *my-client-signature*))) - -;; Not currently used! But, I think it *should* be used!!! -(define (client:logout serverdat) - (let ((ok (and (socket? serverdat) - (cdb:logout serverdat *toppath* (client:get-signature))))) - ok)) - -(define (client:connect iface port) - (case (server:get-transport) - ((rpc) (rpc:client-connect iface port)) - ((http) (http:client-connect iface port)) - ((zmq) (zmq:client-connect iface port)) - (else (rpc:client-connect iface port)))) - -(define (client:setup areapath #!key (remaining-tries 100) (failed-connects 0)) - (case (server:get-transport) - ((rpc) (rpc-transport:client-setup remaining-tries: remaining-tries failed-connects: failed-connects)) ;;(client:setup-rpc run-id)) - ((http)(client:setup-http areapath remaining-tries: remaining-tries failed-connects: failed-connects)) - (else (rpc-transport:client-setup remaining-tries: remaining-tries failed-connects: failed-connects)))) ;; (client:setup-rpc run-id)))) - -;; Do all the connection work, look up the transport type and set up the -;; connection if required. -;; -;; There are two scenarios. -;; 1. We are a test manager and we received *transport-type* and *runremote* via cmdline -;; 2. We are a run tests, list runs or other interactive process and we must figure out -;; *transport-type* and *runremote* from the monitor.db -;; -;; client:setup -;; -;; lookup_server, need to remove *runremote* stuff -;; - -(define (client:setup-http areapath #!key (remaining-tries 100) (failed-connects 0)(area-dat #f)) - (debug:print-info 2 *default-log-port* "client:setup remaining-tries=" remaining-tries) - (server:start-and-wait areapath) - (if (<= remaining-tries 0) - (begin - (debug:print-error 0 *default-log-port* "failed to start or connect to server") - (exit 1)) - ;; - ;; Alternatively here, we can get the list of candidate servers and work our way - ;; through them searching for a good one. - ;; - (let* ((server-dat (server:get-rand-best areapath)) ;; (server:get-first-best areapath)) - (runremote (or area-dat *runremote*))) - (if (not server-dat) ;; no server found - (client:setup-http areapath remaining-tries: (- remaining-tries 1)) - (let ((host (cadr server-dat)) - (port (caddr server-dat))) - (debug:print-info 4 *default-log-port* "client:setup server-dat=" server-dat ", remaining-tries=" remaining-tries) - (if (and (not area-dat) - (not *runremote*)) - (set! *runremote* (make-remote))) - (if (and host port) - (let* ((start-res (case *transport-type* - ((http)(http-transport:client-connect host port)))) - (ping-res (case *transport-type* - ((http)(rmt:login-no-auto-client-setup start-res))))) - (if (and start-res - ping-res) - (let ((runremote (or area-dat *runremote*))) ;; it might have been generated only a few statements ago - (remote-conndat-set! runremote start-res) ;; (hash-table-set! runremote run-id start-res) - (debug:print-info 2 *default-log-port* "connected to " (http-transport:server-dat-make-url start-res)) - start-res) - (begin ;; login failed but have a server record, clean out the record and try again - (debug:print-info 0 *default-log-port* "client:setup, login failed, will attempt to start server ... start-res=" start-res ", server-dat=" server-dat) ;; had runid. Fixes part of Randy;s ticket 1405717332 - (case *transport-type* - ((http)(http-transport:close-connections))) - (remote-conndat-set! runremote #f) ;; (hash-table-delete! runremote run-id) - (thread-sleep! 1) - (client:setup-http areapath remaining-tries: (- remaining-tries 1)) - ))) - (begin ;; no server registered - ;; (server:kind-run areapath) - (server:start-and-wait areapath) - (debug:print-info 0 *default-log-port* "client:setup, no server registered, remaining-tries=" remaining-tries) - (thread-sleep! 1) ;; (+ 5 (random (- 20 remaining-tries)))) ;; give server a little time to start up, randomize a little to avoid start storms. - (client:setup-http areapath remaining-tries: (- remaining-tries 1))))))))) - +;; ;; Not currently used! But, I think it *should* be used!!! +;; (define (client:logout serverdat) +;; (let ((ok (and (socket? serverdat) +;; (cdb:logout serverdat *toppath* (client:get-signature))))) +;; ok)) +;; +;; (define (client:connect iface port) +;; (case (server:get-transport) +;; ((http) (http:client-connect iface port)) +;; ((zmq) (zmq:client-connect iface port)) +;; (else (begin +;; (debug:print 0 *default-log-port* "ERROR: no such transport " (server:get-transport) ", exiting now.") +;; (exit 1))))) +;; +;; (define (client:setup areapath #!key (remaining-tries 100) (failed-connects 0)) +;; (case (server:get-transport) +;; ((http)(client:setup-http areapath remaining-tries: remaining-tries failed-connects: failed-connects)) +;; (else (begin +;; (debug:print 0 *default-log-port* "ERROR: no such transport " (server:get-transport) ", exiting now.") +;; (exit 1))))) +;; +;; ;; Do all the connection work, look up the transport type and set up the +;; ;; connection if required. +;; ;; +;; ;; There are two scenarios. +;; ;; 1. We are a test manager and we received *transport-type* and *runremote* via cmdline +;; ;; 2. We are a run tests, list runs or other interactive process and we must figure out +;; ;; *transport-type* and *runremote* from the monitor.db +;; ;; +;; ;; client:setup +;; ;; +;; ;; lookup_server, need to remove *runremote* stuff +;; ;; +;; +;; (define (client:setup-http areapath #!key (remaining-tries 100) (failed-connects 0)(area-dat #f)) +;; (debug:print-info 2 *default-log-port* "client:setup remaining-tries=" remaining-tries) +;; (server:start-and-wait areapath) +;; (if (<= remaining-tries 0) +;; (begin +;; (debug:print-error 0 *default-log-port* "failed to start or connect to server") +;; (exit 1)) +;; ;; +;; ;; Alternatively here, we can get the list of candidate servers and work our way +;; ;; through them searching for a good one. +;; ;; +;; (let* ((server-dat (server:get-rand-best areapath)) ;; (server:get-first-best areapath)) +;; (runremote (or area-dat *runremote*))) +;; (if (not server-dat) ;; no server found +;; (client:setup-http areapath remaining-tries: (- remaining-tries 1)) +;; (let ((host (cadr server-dat)) +;; (port (caddr server-dat))) +;; (debug:print-info 4 *default-log-port* "client:setup server-dat=" server-dat ", remaining-tries=" remaining-tries) +;; (if (and (not area-dat) +;; (not *runremote*)) +;; (set! *runremote* (make-remote))) +;; (if (and host port) +;; (let* ((start-res (case *transport-type* +;; ((http)(http-transport:client-connect host port)))) +;; (ping-res (case *transport-type* +;; ((http)(rmt:login-no-auto-client-setup start-res))))) +;; (if (and start-res +;; ping-res) +;; (let ((runremote (or area-dat *runremote*))) ;; it might have been generated only a few statements ago +;; (remote-conndat-set! runremote start-res) ;; (hash-table-set! runremote run-id start-res) +;; (debug:print-info 2 *default-log-port* "connected to " (http-transport:server-dat-make-url start-res)) +;; start-res) +;; (begin ;; login failed but have a server record, clean out the record and try again +;; (debug:print-info 0 *default-log-port* "client:setup, login failed, will attempt to start server ... start-res=" start-res ", server-dat=" server-dat) ;; had runid. Fixes part of Randy;s ticket 1405717332 +;; (case *transport-type* +;; ((http)(http-transport:close-connections))) +;; (remote-conndat-set! runremote #f) ;; (hash-table-delete! runremote run-id) +;; (thread-sleep! 1) +;; (client:setup-http areapath remaining-tries: (- remaining-tries 1)) +;; ))) +;; (begin ;; no server registered +;; ;; (server:kind-run areapath) +;; (server:start-and-wait areapath) +;; (debug:print-info 0 *default-log-port* "client:setup, no server registered, remaining-tries=" remaining-tries) +;; (thread-sleep! 1) ;; (+ 5 (random (- 20 remaining-tries)))) ;; give server a little time to start up, randomize a little to avoid start storms. +;; (client:setup-http areapath remaining-tries: (- remaining-tries 1))))))))) +;; Index: common.scm ================================================================== --- common.scm +++ common.scm @@ -1135,11 +1135,11 @@ ;; logic for getting homehost. Returns (host . at-home) ;; IF *toppath* is not set, wait up to five seconds trying every two seconds ;; (this is to accomodate the watchdog) ;; -(define (common:get-homehost #!key (trynum 5)) +#;(define (common:get-homehost #!key (trynum 5)) ;; called often especially at start up. use mutex to eliminate collisions (mutex-lock! *homehost-mutex*) (cond (*home-host* (mutex-unlock! *homehost-mutex*) @@ -1187,11 +1187,11 @@ (mutex-unlock! *homehost-mutex*) *home-host*)))) ;; am I on the homehost? ;; -(define (common:on-homehost?) +#;(define (common:on-homehost?) (let ((hh (common:get-homehost))) (if hh (cdr hh) #f))) Index: db.scm ================================================================== --- db.scm +++ db.scm @@ -22,136 +22,94 @@ ;; Database access ;;====================================================================== ;; dbstruct vector containing all the relevant dbs like main.db, megatest.db, run.db etc -(use (srfi 18) extras tcp stack) -(use sqlite3 srfi-1 posix regex regex-case srfi-69 csv-xml s11n md5 message-digest base64 format dot-locking z3 typed-records matchable) -(import (prefix sqlite3 sqlite3:)) -(import (prefix base64 base64:)) - -(declare (unit db)) -(declare (uses common)) -(declare (uses keys)) -(declare (uses ods)) -(declare (uses client)) -(declare (uses mt)) - -(include "common_records.scm") -(include "db_records.scm") -(include "key_records.scm") -(include "run_records.scm") - -(define *rundb-mutex* (make-mutex)) ;; prevent problems opening/closing rundb's -(define *number-of-writes* 0) -(define *number-non-write-queries* 0) - -;;====================================================================== -;; R E C O R D S -;;====================================================================== - -;; each db entry is a pair ( db . dbfilepath ) -;; I propose this record evolves into the area record -;; -(defstruct dbr:dbstruct - (tmpdb #f) - (dbstack #f) ;; stack for tmp db handles, do not initialize with a stack - (mtdb #f) - (refndb #f) - (homehost #f) ;; not used yet - (on-homehost #f) ;; not used yet - (read-only #f) - ) ;; goal is to converge on one struct for an area but for now it is too confusing - - -;; record for keeping state,status and count for doing roll-ups in -;; iterated tests -;; -(defstruct dbr:counts - (state #f) - (status #f) - (count 0)) - -;;====================================================================== -;; SQLITE3 HELPERS -;;====================================================================== - -(define (db:general-sqlite-error-dump exn stmt . params) - (let ((err-status ((condition-property-accessor 'sqlite3 'status #f) exn))) ;; RADT ... how does this work? - ;; check for (exn sqlite3) ((condition-property-accessor 'exn 'message) exn) - (print "err-status: " err-status) - (debug:print-error 0 *default-log-port* " query " stmt " failed, params: " params ", error: " ((condition-property-accessor 'exn 'message) exn)) - (print-call-chain (current-error-port)))) - -;; convert to -inline -;; -(define (db:first-result-default db stmt default . params) - (handle-exceptions - exn - (let ((err-status ((condition-property-accessor 'sqlite3 'status #f) exn))) - ;; check for (exn sqlite3) ((condition-property-accessor 'exn 'message) exn) - (if (eq? err-status 'done) - default - (begin - (debug:print-error 0 *default-log-port* " query " stmt " failed, params: " params ", error: " ((condition-property-accessor 'exn 'message) exn)) - (print-call-chain (current-error-port)) - default))) - (apply sqlite3:first-result db stmt params))) - -;; Get/open a database -;; if run-id => get run specific db -;; if #f => get main db -;; if db already open - return inmem -;; if db not open, open inmem, rundb and sync then return inmem -;; inuse gets set automatically for rundb's -;; -(define (db:get-db dbstruct) ;; run-id) - (if (stack? (dbr:dbstruct-dbstack dbstruct)) - (if (stack-empty? (dbr:dbstruct-dbstack dbstruct)) - (let ((newdb (db:open-megatest-db path: (db:dbfile-path)))) - ;; (stack-push! (dbr:dbstruct-dbstack dbstruct) newdb) - newdb) - (stack-pop! (dbr:dbstruct-dbstack dbstruct))) - (db:open-db dbstruct))) - -;; ;; legacy handling of structure for managing db's. Refactor this into dbr:? -(define (db:dbdat-get-db dbdat) - (if (pair? dbdat) - (car dbdat) - dbdat)) - -(define (db:dbdat-get-path dbdat) - (if (pair? dbdat) - (cdr dbdat) - #f)) - -;; mod-read: -;; 'mod modified data -;; 'read read data -;; Locks the mutex and depending on 'mod or 'read passed, sets the last timestamp in dbstruct -;; -;; (define (db:done-with dbstruct run-id mod-read) -;; (if (not (sqlite3:database? dbstruct)) -;; (begin -;; (mutex-lock! *rundb-mutex*) -;; (if (eq? mod-read 'mod) -;; (dbr:dbstruct-mtime-set! dbstruct (current-milliseconds)) -;; (dbr:dbstruct-rtime-set! dbstruct (current-milliseconds))) -;; (dbr:dbstruct-inuse-set! dbstruct #f) -;; (mutex-unlock! *rundb-mutex*)))) - -;; (db:with-db dbstruct run-id sqlite3:exec "select blah fgrom blaz;") -;; r/w is a flag to indicate if the db is modified by this query #t = yes, #f = no -;; -(define (db:with-db dbstruct run-id r/w proc . params) - (let* ((have-struct (dbr:dbstruct? dbstruct)) - (dbdat (if have-struct - (db:get-db dbstruct) - #f)) - (db (if have-struct - (db:dbdat-get-db dbdat) - dbstruct)) +(declare (unit db)) + +(module db + ( + db:setup + ) + +(import scheme posix chicken data-structures ports) + +(use (prefix sqlite3 sqlite3:) + (srfi 18) extras tcp stack srfi-1 posix regex regex-case srfi-69 + csv-xml s11n md5 message-digest base64 format dot-locking z3 + typed-records matchable + (prefix base64 base64:)) + +;;====================================================================== +;; +;;====================================================================== + +(defstruct dbinfo + (mtrah #f) + (dbpath #f) + (maindb #f) + (dbfile #f) + (writeable #f) + (rundbs (make-hash-table)) ;; id => #(dbhandle readq writeq) + (stats (make-hash-table)) + (mreadq (make-queue)) ;; read queue for main.db + (mwriteq (make-queue)) ;; write queue for main.db + (localq (make-queue)) ;; queue for cpuload, numcores and other OS requests + (respq (make-queue)) ;; queue for responses + ) + +(defstruct rundbinfo + (rundb #f) ;; db handle + (dbfile #f) + (readq (make-queue)) + (writeq (make-queue)) + (sdbcache (make-hash-table)) ;; cache the id => strings as we read them + (stats (make-hash-table)) + ) + +(defstruct request + (srchost #f) + (srcport #f) + (reqtype #f) ;; read, write, local + (response #f) + (status 'new) + (start (current-milliseconds))) + +;; create a dbinfo record initialized to a specific Megatest area +;; +(define (db:create-dbinfo mtrah) + (make-dbinfo mtrah: mtrah dbpath: (conc mtrah "/.mtdb"))) + +(define (db:get-open-db dbinfo run-id #!key (dbpath #f)) + (let* ((dbpath (dbinfo-dbpath dbinfo)) + (ismain (if (number? run-id) #f #t)) + (dbname (if run-id (conc run-id ".db") "main.db")) ;; can use string for run-id + (dbfile (conc dbpath "/" dbname)) + (dbexists (file-exists? dbfile)) + (readable (file-read-access? dbpath)) ;; should be safe to assume can read db file + (writeable (file-write-access? dbpath))) + ;; handle error conditions + (cond + ((and (not dbexists) (not writeable))(values #f "No db file and no write access")) + ((not readable) (values #f "No read access")) + (else + ;; TODO - transfer over the error handling from MT1.65 db:lock-create-open + (let ((db (sqlite3:open-database dbfile))) + (if (not dbexists)(db:initialize-db db)) + ;; now deal with the added structure for run-id based db if needed + (if ismain + (begin + (dbinfo-maindb-set! dbinfo db) + (dbinfo-writeable-set! dbinfo writeable)) + (let ((runrec (or (hash-table-ref/default (dbinfo-rundbs dbinfo) run-id (make-rundbinfo rundb: db dbfile: dbfile))))) + (hash-table-set! (dbinfo-rundbs dbinfo) run-id runrec))) + (values #t "Success")))))) + +;; dbinfo must have been initiatized with the dbpath +;; +#;(define (db:with-db dbinfo run-id proc . params) + (let* ((db (db:get-open-db dbinfo run-id)) (use-mutex (> *api-process-request-count* 25))) (if (and use-mutex (common:low-noise-print 120 "over-50-parallel-api-requests")) (debug:print-info 0 *default-log-port* *api-process-request-count* " parallel api requests being processed in process " (current-process-id) ", throttling access")) (if (common:low-noise-print 600 (conc "parallel-api-requests" *max-api-process-requests*)) @@ -168,1081 +126,52 @@ (if use-mutex (mutex-unlock! *db-with-db-mutex*)) ;; (if (vector? dbstruct)(db:done-with dbstruct run-id r/w)) (if dbdat (stack-push! (dbr:dbstruct-dbstack dbstruct) dbdat)) res)))) -;;====================================================================== -;; K E E P F I L E D B I N dbstruct -;;====================================================================== - -;; (define (db:get-filedb dbstruct run-id) -;; (let ((db (vector-ref dbstruct 2))) -;; (if db -;; db -;; (let ((fdb (filedb:open-db (conc *toplevel* "/db/files.db")))) -;; (vector-set! dbstruct 2 fdb) -;; fdb)))) -;; -;; ;; Can also be used to save arbitrary strings -;; ;; -;; (define (db:save-path dbstruct path) -;; (let ((fdb (db:get-filedb dbstruct)))b -;; (filedb:register-path fdb path))) -;; -;; ;; Use to get a path. To get an arbitrary string see next define -;; ;; -;; (define (db:get-path dbstruct id) -;; (let ((fdb (db:get-filedb dbstruct))) -;; (filedb:get-path db id))) - -;; NB// #f => return dbdir only -;; (was planned to be; zeroth db with name=main.db) -;; -;; If run-id is #f return to create and retrieve the path where the db will live. -;; -(define db:dbfile-path common:get-db-tmp-area) - -(define (db:set-sync db) - (let ((syncprag (configf:lookup *configdat* "setup" "sychronous"))) - (sqlite3:execute db (conc "PRAGMA synchronous = " (or syncprag 0) ";")))) - -;; open an sql database inside a file lock -;; returns: db existed-prior-to-opening -;; RA => Returns a db handler; sets the lock if opened in writable mode -;; -;; (define *db-open-mutex* (make-mutex)) - -(define (db:lock-create-open fname initproc) - (let* ((parent-dir (or (pathname-directory fname)(current-directory))) ;; no parent? go local - (raw-fname (pathname-file fname)) - (dir-writable (file-write-access? parent-dir)) - (file-exists (common:file-exists? fname)) - (file-write (if file-exists - (file-write-access? fname) - dir-writable ))) - ;; (mutex-lock! *db-open-mutex*) ;; tried this mutex, not clear it helped. - (if file-write ;; dir-writable - (condition-case - (let* ((lockfname (conc fname ".lock")) - (readyfname (conc parent-dir "/.ready-" raw-fname)) - (readyexists (common:file-exists? readyfname))) - (if (not readyexists) - (common:simple-file-lock-and-wait lockfname)) - (let ((db (sqlite3:open-database fname))) - (sqlite3:set-busy-handler! db (make-busy-timeout 136000)) - (sqlite3:execute db "PRAGMA synchronous = 0;") - (if (not file-exists) - (begin - - (if (and (configf:lookup *configdat* "setup" "use-wal") - (string-match "^/tmp/.*" fname)) ;; this is a file in /tmp - (sqlite3:execute db "PRAGMA journal_mode=WAL;") - (debug:print 2 *default-log-port* "Creating " fname " in NON-WAL mode.")) - (initproc db))) - (if (not readyexists) - (begin - (common:simple-file-release-lock lockfname) - (with-output-to-file - readyfname - (lambda () - (print "Ready at " - (seconds->year-work-week/day-time - (current-seconds))))))) - db)) - (exn (io-error) (debug:print 0 *default-log-port* "ERROR: i/o error with " fname ". Check permissions, disk space etc. and try again.")) - (exn (corrupt) (debug:print 0 *default-log-port* "ERROR: database " fname " is corrupt. Repair it to proceed.")) - (exn (busy) (debug:print 0 *default-log-port* "ERROR: database " fname " is locked. Try copying to another location, remove original and copy back.")) - (exn (permission)(debug:print 0 *default-log-port* "ERROR: database " fname " has some permissions problem.")) - (exn () (debug:print 0 *default-log-port* "ERROR: Unknown error with database " fname " message: " ((condition-property-accessor 'exn 'message) exn)))) - - (condition-case - (begin - (debug:print 2 *default-log-port* "WARNING: opening db in non-writable dir " fname) - (let ((db (sqlite3:open-database fname))) - ;; (mutex-unlock! *db-open-mutex*) - db)) - (exn (io-error) (debug:print 0 *default-log-port* "ERROR: i/o error with " fname ". Check permissions, disk space etc. and try again.")) - (exn (corrupt) (debug:print 0 *default-log-port* "ERROR: database " fname " is corrupt. Repair it to proceed.")) - (exn (busy) (debug:print 0 *default-log-port* "ERROR: database " fname " is locked. Try copying to another location, remove original and copy back.")) - (exn (permission)(debug:print 0 *default-log-port* "ERROR: database " fname " has some permissions problem.")) - (exn () (debug:print 0 *default-log-port* "ERROR: Unknown error with database " fname " message: " ((condition-property-accessor 'exn 'message) exn)))) - ))) - - - - - - -;; ;; This routine creates the db. It is only called if the db is not already opened -;; ;; -;; (define (db:open-rundb dbstruct run-id #!key (attemptnum 0)(do-not-open #f)) ;; (conc *toppath* "/megatest.db") (car *configinfo*))) -;; (let* ((dbfile (db:dbfile-path run-id)) ;; (conc toppath "/db/" run-id ".db")) -;; (dbexists (common:file-exists? dbfile)) -;; (db (db:lock-create-open dbfile (lambda (db) -;; (handle-exceptions -;; exn -;; (begin -;; ;; (release-dot-lock dbpath) -;; (if (> attemptnum 2) -;; (debug:print-error 0 *default-log-port* "tried twice, cannot create/initialize db for run-id " run-id ", at path " dbpath) -;; (db:open-rundb dbstruct run-id attemptnum (+ attemptnum 1)))) -;; (db:initialize-run-id-db db) -;; (sqlite3:execute -;; db -;; "INSERT OR IGNORE INTO tests (id,run_id,testname,event_time,item_path,state,status) VALUES (?,?,'bogustest',strftime('%s','now'),'nowherepath','DELETED','n/a');" -;; (* run-id 30000) ;; allow for up to 30k tests per run -;; run-id) -;; ;; do a dummy query to test that the table exists and the db is truly readable -;; (sqlite3:execute db "SELECT * FROM tests WHERE id=?;" (* run-id 30000)) -;; )))) ;; add strings db to rundb, not in use yet -;; (olddb (if *megatest-db* -;; *megatest-db* -;; (let ((db (db:open-megatest-db))) -;; (set! *megatest-db* db) -;; db))) -;; (write-access (file-write-access? dbfile))) -;; (if (and dbexists (not write-access)) -;; (set! *db-write-access* #f)) ;; only unset so other db's also can use this control -;; (dbr:dbstruct-rundb-set! dbstruct (cons db dbfile)) -;; (dbr:dbstruct-inuse-set! dbstruct #t) -;; (dbr:dbstruct-olddb-set! dbstruct olddb) -;; ;;; (mutex-unlock! *rundb-mutex*) ;;; why did we need a mutex on opening db's? -;; (db:sync-tables db:sync-tests-only *megatest-db* db) -;; db)) - -;; This routine creates the db if not already present. It is only called if the db is not already opened -;; -(define (db:open-db dbstruct #!key (areapath #f)(do-sync #t)) ;; TODO: actually use areapath - (let ((tmpdb-stack (dbr:dbstruct-dbstack dbstruct))) ;; RA => Returns the first reference in dbstruct - (if (stack? tmpdb-stack) - (db:get-db tmpdb-stack) ;; get previously opened db (will create new db handle if all in the stack are already used - (let* ((dbpath (db:dbfile-path )) ;; path to tmp db area - (dbexists (common:file-exists? dbpath)) - (tmpdbfname (conc dbpath "/megatest.db")) - (dbfexists (common:file-exists? tmpdbfname)) ;; (conc dbpath "/megatest.db"))) - (mtdbexists (common:file-exists? (conc *toppath* "/megatest.db"))) - - (mtdbmodtime (if mtdbexists (common:lazy-sqlite-db-modification-time (conc *toppath* "/megatest.db")) #f)) - (tmpdbmodtime (if dbfexists (common:lazy-sqlite-db-modification-time tmpdbfname) #f)) - (mtdb (db:open-megatest-db)) - (mtdbpath (db:dbdat-get-path mtdb)) - (tmpdb (db:open-megatest-db path: dbpath)) ;; lock-create-open dbpath db:initialize-main-db)) - (refndb (db:open-megatest-db path: dbpath name: "megatest_ref.db")) - (write-access (file-write-access? mtdbpath)) - ;(mtdbmodtime (if mtdbexists (common:lazy-sqlite-db-modification-time mtdbpath) #f)) ; moving this before db:open-megatest-db is called. if wal mode is on -WAL and -shm file get created with causing the tmpdbmodtime timestamp always greater than mtdbmodtime - ;(tmpdbmodtime (if dbfexists (common:lazy-sqlite-db-modification-time tmpdbfname) #f)) - ;if wal mode is on -WAL and -shm file get created when db:open-megatest-db is called. modtimedelta will always be < 10 so db in tmp not get synced - ;(tmpdbmodtime (if dbfexists (db:get-last-update-time (car tmpdb)) #f)) - ;(fmt (file-modification-time tmpdbfname)) - (modtimedelta (and mtdbmodtime tmpdbmodtime (- mtdbmodtime tmpdbmodtime)))) - - (when write-access - (sqlite3:execute (car mtdb) "drop trigger if exists update_tests_trigger") - (sqlite3:execute (car mtdb) "drop trigger if exists update_runs_trigger")) - - ;(print "mtdbmodtime " mtdbmodtime " tmpdbmodtime " tmpdbmodtime " mtdbpath " mtdbpath " " (conc *toppath* "/megatest.db")) - ;;(debug:print-info 13 *default-log-port* "db:open-db>> mtdbpath="mtdbpath" mtdbexists="mtdbexists" and write-access="write-access) - (if (and dbexists (not write-access)) - (begin - (set! *db-write-access* #f) - (dbr:dbstruct-read-only-set! dbstruct #t))) - (dbr:dbstruct-mtdb-set! dbstruct mtdb) - (dbr:dbstruct-tmpdb-set! dbstruct tmpdb) - (dbr:dbstruct-dbstack-set! dbstruct (make-stack)) ;; BB: why a stack? Why would the number of db's be indeterminate? Is this a legacy of 1.db 2.db .. ? - (stack-push! (dbr:dbstruct-dbstack dbstruct) tmpdb) ;; olddb is already a (cons db path) - (dbr:dbstruct-refndb-set! dbstruct refndb) - ;; (mutex-unlock! *rundb-mutex*) - (if (and (or (not dbfexists) - (and modtimedelta - (> modtimedelta 10))) ;; if db in tmp is over ten seconds older than the file in MTRA then do a sync back - do-sync) - (begin - (debug:print 1 *default-log-port* "filling db " (db:dbdat-get-path tmpdb) " with data \n from " (db:dbdat-get-path mtdb) " mod time delta: " modtimedelta) - (db:sync-tables (db:sync-all-tables-list dbstruct) #f mtdb refndb tmpdb) - ;touch tmp db to avoid wal mode wierdness - (set! (file-modification-time tmpdbfname) (current-seconds)) - (debug:print-info 13 *default-log-port* "db:sync-all-tables-list done.") - ) - (debug:print 4 *default-log-port* " db, " (db:dbdat-get-path tmpdb) " already exists or fresh enough, not propogating data from\n " (db:dbdat-get-path mtdb) " mod time delta: " modtimedelta) ) - ;; (db:multi-db-sync dbstruct 'old2new)) ;; migrate data from megatest.db automatically - tmpdb)))) - - -(define (db:get-last-update-time db) -; (db:with-db -; dbstruct #f #f -; (lambda (db) - (let ((last-update-time #f)) - (sqlite3:for-each-row - (lambda (lup) - (set! last-update-time lup)) - db - "select max(lup) from ( select max(last_update) as lup from tests union select max(last_update) as lup from runs);") - last-update-time)) -;)) - -;; Make the dbstruct, setup up auxillary db's and call for main db at least once -;; -;; called in http-transport and replicated in rmt.scm for *local* access. -;; -(define (db:setup do-sync #!key (areapath #f)) - ;; - (cond - (*dbstruct-db* *dbstruct-db*);; TODO: when multiple areas are supported, this optimization will be a hazard - (else ;;(common:on-homehost?) - (debug:print-info 13 *default-log-port* "db:setup entered (first time, not cached.)") - (let* ((dbstruct (make-dbr:dbstruct))) - (when (not *toppath*) - (debug:print-info 13 *default-log-port* "in db:setup, *toppath* not set; calling launch:setup") - (launch:setup areapath: areapath)) - (debug:print-info 13 *default-log-port* "Begin db:open-db") - (db:open-db dbstruct areapath: areapath do-sync: do-sync) - (debug:print-info 13 *default-log-port* "Done db:open-db") - (set! *dbstruct-db* dbstruct) - ;;(debug:print-info 13 *default-log-port* "new dbstruct = "(dbr:dbstruct->alist dbstruct)) - dbstruct)))) - ;; (else - ;; (debug:print 0 *default-log-port* "ERROR: attempt to open database when not on homehost. Exiting. Homehost: " (common:get-homehost)) - ;; (exit 1)))) - -;; Open the classic megatest.db file (defaults to open in toppath) -;; -;; NOTE: returns a dbdat not a dbstruct! -;; -(define (db:open-megatest-db #!key (path #f)(name #f)) - (let* ((dbdir (or path *toppath*)) - (dbpath (conc dbdir "/" (or name "megatest.db"))) - (dbexists (common:file-exists? dbpath)) - (db (db:lock-create-open dbpath - (lambda (db) - (db:initialize-main-db db) - ;;(db:initialize-run-id-db db) - ))) - (write-access (file-write-access? dbpath))) - (debug:print-info 13 *default-log-port* "db:open-megatest-db "dbpath) - (if (and dbexists (not write-access)) - (set! *db-write-access* #f)) - (cons db dbpath))) - -;; sync run to disk if touched -;; -(define (db:sync-touched dbstruct run-id #!key (force-sync #f)) - (let ((tmpdb (db:get-db dbstruct)) - (mtdb (dbr:dbstruct-mtdb dbstruct)) - (refndb (dbr:dbstruct-refndb dbstruct)) - (start-t (current-seconds))) - (debug:print-info 4 *default-log-port* "Syncing for run-id: " run-id) - (mutex-lock! *db-multi-sync-mutex*) - (let ((update_info (cons (if force-sync 0 *db-last-sync*) "last_update"))) - (mutex-unlock! *db-multi-sync-mutex*) - (db:sync-tables (db:sync-all-tables-list dbstruct) update_info tmpdb refndb mtdb)) - (mutex-lock! *db-multi-sync-mutex*) - (set! *db-last-sync* start-t) - (set! *db-last-access* start-t) - (mutex-unlock! *db-multi-sync-mutex*) - (stack-push! (dbr:dbstruct-dbstack dbstruct) tmpdb))) - -(define (db:safely-close-sqlite3-db db #!key (try-num 3)) - (if (<= try-num 0) - #f - (handle-exceptions - exn - (begin - (thread-sleep! 3) - (sqlite3:interrupt! db) - (db:safely-close-sqlite3-db db try-num: (- try-num 1))) - (if (sqlite3:database? db) - (begin - (sqlite3:finalize! db) - #t) - #f)))) - -;; close all opened run-id dbs -(define (db:close-all dbstruct) - (if (dbr:dbstruct? dbstruct) - (handle-exceptions - exn - (begin - (debug:print 0 *default-log-port* "WARNING: Finalizing failed, " ((condition-property-accessor 'exn 'message) exn)) - (print-call-chain *default-log-port*)) - ;; (db:sync-touched dbstruct 0 force-sync: #t) ;; NO. Do not do this here. Instead we rely on a server to be started when there are writes, even if the server itself is not going to be used as a server. - (let ((tdbs (map db:dbdat-get-db - (stack->list (dbr:dbstruct-dbstack dbstruct)))) - (mdb (db:dbdat-get-db (dbr:dbstruct-mtdb dbstruct))) - (rdb (db:dbdat-get-db (dbr:dbstruct-refndb dbstruct)))) - (map (lambda (db) - (db:safely-close-sqlite3-db db)) -;; (if (sqlite3:database? db) -;; (sqlite3:finalize! db))) - tdbs) - (db:safely-close-sqlite3-db mdb) ;; (if (sqlite3:database? mdb) (sqlite3:finalize! mdb)) - (db:safely-close-sqlite3-db rdb))))) ;; (if (sqlite3:database? rdb) (sqlite3:finalize! rdb)))))) - -;; (let ((locdbs (dbr:dbstruct-locdbs dbstruct))) -;; (if (hash-table? locdbs) -;; (for-each (lambda (run-id) -;; (db:close-run-db dbstruct run-id)) -;; (hash-table-keys locdbs))))) - -;; (define (db:open-inmem-db) -;; (let* ((db (sqlite3:open-database ":memory:")) -;; (handler (make-busy-timeout 3600))) -;; (sqlite3:set-busy-handler! db handler) -;; (db:initialize-run-id-db db) -;; (cons db #f))) - -;; just tests, test_steps and test_data tables -(define db:sync-tests-only - (list - ;; (list "strs" - ;; '("id" #f) - ;; '("str" #f)) - (list "tests" - '("id" #f) - '("run_id" #f) - '("testname" #f) - '("host" #f) - '("cpuload" #f) - '("diskfree" #f) - '("uname" #f) - '("rundir" #f) - '("shortdir" #f) - '("item_path" #f) - '("state" #f) - '("status" #f) - '("attemptnum" #f) - '("final_logf" #f) - '("logdat" #f) - '("run_duration" #f) - '("comment" #f) - '("event_time" #f) - '("fail_count" #f) - '("pass_count" #f) - '("archived" #f) - '("last_update" #f)) - (list "test_steps" - '("id" #f) - '("test_id" #f) - '("stepname" #f) - '("state" #f) - '("status" #f) - '("event_time" #f) - '("comment" #f) - '("logfile" #f) - '("last_update" #f)) - (list "test_data" - '("id" #f) - '("test_id" #f) - '("category" #f) - '("variable" #f) - '("value" #f) - '("expected" #f) - '("tol" #f) - '("units" #f) - '("comment" #f) - '("status" #f) - '("type" #f) - '("last_update" #f)))) - -;; needs db to get keys, this is for syncing all tables -;; -(define (db:sync-main-list dbstruct) - (let ((keys (db:get-keys dbstruct))) - (list - (list "keys" - '("id" #f) - '("fieldname" #f) - '("fieldtype" #f)) - (list "metadat" '("var" #f) '("val" #f)) - (append (list "runs" - '("id" #f)) - (map (lambda (k)(list k #f)) - (append keys - (list "runname" "state" "status" "owner" "event_time" "comment" "fail_count" "pass_count" "contour" "last_update")))) - (list "test_meta" - '("id" #f) - '("testname" #f) - '("owner" #f) - '("description" #f) - '("reviewed" #f) - '("iterated" #f) - '("avg_runtime" #f) - '("avg_disk" #f) - '("tags" #f) - '("jobgroup" #f))))) - -(define (db:sync-all-tables-list dbstruct) - (append (db:sync-main-list dbstruct) - db:sync-tests-only)) - -;; use bunch of Unix commands to try to break the lock and recreate the db -;; -(define (db:move-and-recreate-db dbdat) - (let* ((dbpath (db:dbdat-get-path dbdat)) - (dbdir (pathname-directory dbpath)) - (fname (pathname-strip-directory dbpath)) - (fnamejnl (conc fname "-journal")) - (tmpname (conc fname "." (current-process-id))) - (tmpjnl (conc fnamejnl "." (current-process-id)))) - (debug:print-error 0 *default-log-port* "" fname " appears corrupted. Making backup \"old/" fname "\"") - (system (conc "cd " dbdir ";mkdir -p old;cat " fname " > old/" tmpname)) - (system (conc "rm -f " dbpath)) - (if (common:file-exists? fnamejnl) - (begin - (debug:print-error 0 *default-log-port* "" fnamejnl " found, moving it to old dir as " tmpjnl) - (system (conc "cd " dbdir ";mkdir -p old;cat " fnamejnl " > old/" tmpjnl)) - (system (conc "rm -f " dbdir "/" fnamejnl)))) - ;; attempt to recreate database - (system (conc "cd " dbdir ";sqlite3 old/" tmpname " .dump | sqlite3 " fname)))) - -;; return #f to indicate the dbdat should be closed/reopened -;; else return dbdat -;; -(define (db:repair-db dbdat #!key (numtries 1)) - (let* ((dbpath (db:dbdat-get-path dbdat)) - (dbdir (pathname-directory dbpath)) - (fname (pathname-strip-directory dbpath))) - (debug:print-info 0 *default-log-port* "Checking db " dbpath " for errors.") - (cond - ((not (file-write-access? dbdir)) - (debug:print 0 *default-log-port* "WARNING: can't write to " dbdir ", can't fix " fname) - #f) - - ;; handle special cases, megatest.db and monitor.db - ;; - ;; NOPE: apply this same approach to all db files - ;; - (else ;; ((equal? fname "megatest.db") ;; this file can be regenerated if needed - (handle-exceptions - exn - (begin - ;; (db:move-and-recreate-db dbdat) - (if (> numtries 0) - (db:repair-db dbdat numtries: (- numtries 1)) - #f) - (debug:print 0 *default-log-port* "FATAL: file " dbpath " was found corrupted, an attempt to fix has been made but you must start over.") - (debug:print 0 *default-log-port* - " check the following:\n" - " 1. full directories, look in ~/ /tmp and " dbdir "\n" - " 2. write access to " dbdir "\n\n" - " if the automatic recovery failed you may be able to recover data by doing \"" - (if (member fname '("megatest.db" "monitor.db")) - "megatest -cleanup-db" - "megatest -import-megatest.db;megatest -cleanup-db") - "\"\n") - (exit) ;; we can not safely continue when a db was corrupted - even if fixed. - ) - ;; test read/write access to the database - (let ((db (sqlite3:open-database dbpath))) - (cond - ((equal? fname "megatest.db") - (sqlite3:execute db "DELETE FROM tests WHERE state='DELETED';")) - ((equal? fname "main.db") - (sqlite3:execute db "DELETE FROM runs WHERE state='deleted';")) - ((string-match "\\d.db" fname) - (sqlite3:execute db "UPDATE tests SET state='DELETED' WHERE state='DELETED';")) - ((equal? fname "monitor.db") - (sqlite3:execute "DELETE FROM servers WHERE state LIKE 'defunct%';")) - (else - (sqlite3:execute db "vacuum;"))) - - (finalize! db) - #t)))))) - -;; tbls is ( ("tablename" ( "field1" [#f|proc1] ) ( "field2" [#f|proc2] ) .... ) ) -;; db's are dbdat's -;; -;; if last-update specified ("field-name" . time-in-seconds) -;; then sync only records where field-name >= time-in-seconds -;; IFF field-name exists -;; -(define (db:sync-tables tbls last-update fromdb todb . slave-dbs) - (handle-exceptions - exn - (begin - (debug:print 0 *default-log-port* "EXCEPTION: database probably overloaded or unreadable in db:sync-tables.") - (print-call-chain (current-error-port)) - (debug:print 0 *default-log-port* " message: " ((condition-property-accessor 'exn 'message) exn)) - (debug:print 5 *default-log-port* "exn=" (condition->list exn)) - (debug:print 0 *default-log-port* " status: " ((condition-property-accessor 'sqlite3 'status) exn)) - (debug:print 0 *default-log-port* " src db: " (db:dbdat-get-path fromdb)) - (for-each (lambda (dbdat) - (let ((dbpath (db:dbdat-get-path dbdat))) - (debug:print 0 *default-log-port* " dbpath: " dbpath) - (if (not (db:repair-db dbdat)) - (begin - (debug:print-error 0 *default-log-port* "Failed to rebuild " dbpath ", exiting now.") - (exit))))) - (cons todb slave-dbs)) - - 0) - ;; this is the work to be done - (cond - ((not fromdb) (debug:print 3 *default-log-port* "WARNING: db:sync-tables called with fromdb missing") - -1) - ((not todb) (debug:print 3 *default-log-port* "WARNING: db:sync-tables called with todb missing") - -2) - ((not (sqlite3:database? (db:dbdat-get-db fromdb))) - (debug:print-error 0 *default-log-port* "db:sync-tables called with fromdb not a database " fromdb) - -3) - ((not (sqlite3:database? (db:dbdat-get-db todb))) - (debug:print-error 0 *default-log-port* "db:sync-tables called with todb not a database " todb) - -4) - - ((not (file-write-access? (db:dbdat-get-path todb))) - (debug:print-error 0 *default-log-port* "db:sync-tables called with todb not a read-only database " todb) - -5) - ((not (null? (let ((readonly-slave-dbs - (filter - (lambda (dbdat) - (not (file-write-access? (db:dbdat-get-path todb)))) - slave-dbs))) - (for-each - (lambda (bad-dbdat) - (debug:print-error - 0 *default-log-port* "db:sync-tables called with todb not a read-only database " bad-dbdat)) - readonly-slave-dbs) - readonly-slave-dbs))) -6) - (else - (let ((stmts (make-hash-table)) ;; table-field => stmt - (all-stmts '()) ;; ( ( stmt1 value1 ) ( stml2 value2 )) - (numrecs (make-hash-table)) - (start-time (current-milliseconds)) - (tot-count 0)) - (for-each ;; table - (lambda (tabledat) - (let* ((tablename (car tabledat)) - (fields (cdr tabledat)) - (has-last-update (member "last_update" fields)) - (use-last-update (cond - ((and has-last-update - (member "last_update" fields)) - #t) ;; if given a number, just use it for all fields - ((number? last-update) #f) ;; if not matched first entry then ignore last-update for this table - ((and (pair? last-update) - (member (car last-update) ;; last-update field name - (map car fields))) #t) - (last-update - (debug:print 0 *default-log-port* "ERROR: parameter last-update for db:sync-tables must be a pair or a number, received: " last-update) ;; found in fields - #f) - (else - #f))) - (last-update-value (if use-last-update ;; no need to check for has-last-update - it is already accounted for - (if (number? last-update) - last-update - (cdr last-update)) - #f)) - (last-update-field (if use-last-update - (if (number? last-update) - "last_update" - (car last-update)) - #f)) - (num-fields (length fields)) - (field->num (make-hash-table)) - (num->field (apply vector (map car fields))) ;; BBHERE - (full-sel (conc "SELECT " (string-intersperse (map car fields) ",") - " FROM " tablename (if use-last-update ;; apply last-update criteria - (conc " WHERE " last-update-field " >= " last-update-value) - "") - ";")) - (full-ins (conc "INSERT OR REPLACE INTO " tablename " ( " (string-intersperse (map car fields) ",") " ) " - " VALUES ( " (string-intersperse (make-list num-fields "?") ",") " );")) - (fromdat '()) - (fromdats '()) - (totrecords 0) - (batch-len (string->number (or (configf:lookup *configdat* "sync" "batchsize") "100"))) - (todat (make-hash-table)) - (count 0) - - (delay-handicap (string->number (or (configf:lookup *configdat* "sync" "delay-handicap") "0"))) - ) - - ;; set up the field->num table - (for-each - (lambda (field) - (hash-table-set! field->num field count) - (set! count (+ count 1))) - fields) - - ;; read the source table - (sqlite3:for-each-row - (lambda (a . b) - (set! fromdat (cons (apply vector a b) fromdat)) - (if (> (length fromdat) batch-len) - (begin - (set! fromdats (cons fromdat fromdats)) - (set! fromdat '()) - (set! totrecords (+ totrecords 1))))) - (db:dbdat-get-db fromdb) - full-sel) - - ;; tack on remaining records in fromdat - (if (not (null? fromdat)) - (set! fromdats (cons fromdat fromdats))) - - (if (common:low-noise-print 120 "sync-records") - (debug:print-info 4 *default-log-port* "found " totrecords " records to sync")) - - ;; read the target table; BBHERE - (sqlite3:for-each-row - (lambda (a . b) - (hash-table-set! todat a (apply vector a b))) - (db:dbdat-get-db todb) - full-sel) - - (when (and delay-handicap (> delay-handicap 0)) - (debug:print-info 0 *default-log-port* "imposing synthetic sync delay of "delay-handicap" seconds since sync/delay-handicap is configured") - (thread-sleep! delay-handicap) - (debug:print-info 0 *default-log-port* "synthetic sync delay of "delay-handicap" seconds completed") - ) - - ;; first pass implementation, just insert all changed rows - (for-each - (lambda (targdb) - (let* ((db (db:dbdat-get-db targdb)) - (stmth (sqlite3:prepare db full-ins))) - (db:delay-if-busy targdb) ;; NO WAITING - (for-each - (lambda (fromdat-lst) - (sqlite3:with-transaction - db - (lambda () - (for-each ;; - (lambda (fromrow) - (let* ((a (vector-ref fromrow 0)) - (curr (hash-table-ref/default todat a #f)) - (same #t)) - (let loop ((i 0)) - (if (or (not curr) - (not (equal? (vector-ref fromrow i)(vector-ref curr i)))) - (set! same #f)) - (if (and same - (< i (- num-fields 1))) - (loop (+ i 1)))) - (if (not same) - (begin - (apply sqlite3:execute stmth (vector->list fromrow)) - (hash-table-set! numrecs tablename (+ 1 (hash-table-ref/default numrecs tablename 0))))))) - fromdat-lst)) - )) - fromdats) - (sqlite3:finalize! stmth))) - (append (list todb) slave-dbs)))) - tbls) - (let* ((runtime (- (current-milliseconds) start-time)) - (should-print (or (debug:debug-mode 12) - (common:low-noise-print 120 "db sync" (> runtime 500))))) ;; low and high sync times treated as separate. - (if should-print (debug:print 3 *default-log-port* "INFO: db sync, total run time " runtime " ms")) - (for-each - (lambda (dat) - (let ((tblname (car dat)) - (count (cdr dat))) - (set! tot-count (+ tot-count count)) - (if (> count 0) - (if should-print (debug:print 0 *default-log-port* (format #f " ~10a ~5a" tblname count)))))) - (sort (hash-table->alist numrecs)(lambda (a b)(> (cdr a)(cdr b)))))) - tot-count))))) - -(define (db:patch-schema-rundb frundb) - ;; - ;; remove this some time after September 2016 (added in version v1.6031 - ;; - (for-each - (lambda (table-name) - (handle-exceptions - exn - (if (string-match ".*duplicate.*" ((condition-property-accessor 'exn 'message) exn)) - (debug:print 0 *default-log-port* "Column last_update already added to " table-name " table") - (db:general-sqlite-error-dump exn "alter table " table-name " ..." #f "none")) - (sqlite3:execute - frundb - (conc "ALTER TABLE " table-name " ADD COLUMN last_update INTEGER DEFAULT 0"))) - (sqlite3:execute - frundb - (conc "DROP TRIGGER IF EXISTS update_" table-name "_trigger;")) - (sqlite3:execute - frundb - (conc "CREATE TRIGGER IF NOT EXISTS update_" table-name "_trigger AFTER UPDATE ON " table-name " - FOR EACH ROW - BEGIN - UPDATE " table-name " SET last_update=(strftime('%s','now')) - WHERE id=old.id; - END;")) - ) - '("tests" "test_steps" "test_data"))) - -(define (db:patch-schema-maindb maindb) - ;; - ;; remove all these some time after september 2016 (added in v1.6031 - ;; - (for-each - (lambda (column type default) - (handle-exceptions - exn - (if (string-match ".*duplicate.*" ((condition-property-accessor 'exn 'message) exn)) - (debug:print 0 *default-log-port* "Column " column " already added to runs table") - (db:general-sqlite-error-dump exn "alter table runs ..." #f "none")) - (sqlite3:execute - maindb - (conc "ALTER TABLE runs ADD COLUMN " column " " type " DEFAULT " default)))) - (list "last_update" "contour") - (list "INTEGER" "TEXT" ) - (list "0" "''" )) - ;; these schema changes don't need exception handling - (sqlite3:execute - maindb - "CREATE TRIGGER IF NOT EXISTS update_runs_trigger AFTER UPDATE ON runs +(define (db:initialize-db db) + (sqlite3:with-transaction + db + (lambda () + (sqlite3:execute db "CREATE TABLE IF NOT EXISTS ttype ( + id SERIAL PRIMARY KEY, + target_spec TEXT DEFAULT '');") + (sqlite3:execute db "CREATE TABLE IF NOT EXISTS runs ( + id INTEGER PRIMARY KEY, + target TEXT DEFAULT 'nodata', + ttype_id INTEGER DEFAULT 0, + run_name TEXT DEFAULT 'norun', + contour TEXT DEFAULT '', + state TEXT DEFAULT '', + status TEXT DEFAULT '', + owner TEXT DEFAULT '', + event_time TIMESTAMP DEFAULT (strftime('%s','now')), + comment TEXT DEFAULT '', + fail_count INTEGER DEFAULT 0, + pass_count INTEGER DEFAULT 0, + last_update INTEGER DEFAULT (strftime('%s','now')), + CONSTRAINT runsconstraint UNIQUE (target,ttype_id,run_name, area_id));") + (sqlite3:execute db "CREATE TRIGGER IF NOT EXISTS update_runs_trigger AFTER UPDATE ON runs FOR EACH ROW BEGIN UPDATE runs SET last_update=(strftime('%s','now')) WHERE id=old.id; END;") - (sqlite3:execute maindb "CREATE TABLE IF NOT EXISTS run_stats ( + (sqlite3:execute db "CREATE TABLE IF NOT EXISTS run_stats ( id INTEGER PRIMARY KEY, run_id INTEGER, state TEXT, status TEXT, count INTEGER, last_update INTEGER DEFAULT (strftime('%s','now')))") - (sqlite3:execute maindb "CREATE TRIGGER IF NOT EXISTS update_run_stats_trigger AFTER UPDATE ON run_stats - FOR EACH ROW - BEGIN - UPDATE run_stats SET last_update=(strftime('%s','now')) - WHERE id=old.id; - END;") - (sqlite3:execute maindb "CREATE TABLE IF NOT EXISTS test_rundat ( - id INTEGER PRIMARY KEY, - test_id INTEGER, - update_time TIMESTAMP, - cpuload INTEGER DEFAULT -1, - diskfree INTEGER DEFAULT -1, - diskusage INTGER DEFAULT -1, - run_duration INTEGER DEFAULT 0);")) - -(define (db:adj-target db) - (let ((fields (configf:get-section *configdat* "fields")) - (field-num 0)) - ;; because we will be refreshing the keys table it is best to clear it here - (sqlite3:execute db "DELETE FROM keys;") - (for-each - (lambda (field) - (let ((column (car field)) - (spec (cadr field))) - (handle-exceptions - exn - (if (string-match ".*duplicate.*" ((condition-property-accessor 'exn 'message) exn)) - (debug:print 0 *default-log-port* "Target field " column " already exists in the runs table") - (db:general-sqlite-error-dump exn "alter table runs ..." #f "none")) - ;; Add the column if needed - (sqlite3:execute - db - (conc "ALTER TABLE runs ADD COLUMN " column " " spec))) - ;; correct the entry in the keys column - (sqlite3:execute - db - "INSERT INTO keys (id,fieldname,fieldtype) VALUES (?,?,?);" - field-num column spec) - ;; fill in blanks (not allowed as it would be part of the path - (sqlite3:execute - db - (conc "UPDATE runs SET " column "='x' WHERE " column "='';")) - (set! field-num (+ field-num 1)))) - fields))) - -(define *global-db-store* (make-hash-table)) - -(define (db:get-access-mode) - (if (args:get-arg "-use-db-cache") 'cached 'rmt)) - -;; Add db direct -;; -(define (db:dispatch-query access-mode rmt-cmd db-cmd . params) - (if (eq? access-mode 'cached) - (debug:print 2 *default-log-port* "not doing cached calls right now")) -;; (apply db:call-with-cached-db db-cmd params) - (apply rmt-cmd params)) -;;) - -;; return the target db handle so it can be used -;; -(define (db:cache-for-read-only source target #!key (use-last-update #f)) - (if (and (hash-table-ref/default *global-db-store* target #f) - (>= (file-modification-time target)(file-modification-time source))) - (hash-table-ref *global-db-store* target) - (let* ((toppath (launch:setup)) - (targ-db-last-mod (if (common:file-exists? target) - (file-modification-time target) - 0)) - (cache-db (or (hash-table-ref/default *global-db-store* target #f) - (db:open-megatest-db path: target))) - (source-db (db:open-megatest-db path: source)) - (curr-time (current-seconds)) - (res '()) - (last-update (if use-last-update (cons "last_update" targ-db-last-mod) #f))) - (db:sync-tables (db:sync-main-list source-db) last-update source-db cache-db) - (db:sync-tables db:sync-tests-only last-update source-db cache-db) - (hash-table-set! *global-db-store* target cache-db) - cache-db))) - -;; ;; call a proc with a cached db -;; ;; -;; (define (db:call-with-cached-db proc . params) -;; ;; first cache the db in /tmp -;; (let* ((cname-part (conc "megatest_cache/" (common:get-testsuite-name))) -;; (fname (conc (common:get-area-path-signature) ".db")) -;; (cache-dir (common:get-create-writeable-dir -;; (list (conc "/tmp/" (current-user-name) "/" cname-part) -;; (conc "/tmp/" (current-user-name) "-" cname-part) -;; (conc "/tmp/" (current-user-name) "_" cname-part)))) -;; (megatest-db (conc *toppath* "/megatest.db"))) -;; ;; (debug:print-info 0 *default-log-port* "Using cache dir " cache-dir) -;; (if (not cache-dir) -;; (begin -;; (debug:print 0 *default-log-port* "ERROR: Failed to find an area to write the cache db") -;; (exit 1)) -;; (let* ((th1 (make-thread -;; (lambda () -;; (if (and (common:file-exists? megatest-db) -;; (file-write-access? megatest-db)) -;; (begin -;; (db:sync-to-megatest.db dbstruct 'timestamps) ;; internally mutexes on *db-local-sync* -;; (debug:print-info 2 *default-log-port* "Done syncing to megatest.db")))) -;; "call-with-cached-db sync-to-megatest.db")) -;; (cache-db (db:cache-for-read-only -;; megatest-db -;; (conc cache-dir "/" fname) -;; use-last-update: #t))) -;; (thread-start! th1) -;; (apply proc cache-db params) -;; )))) - -;; options: -;; -;; 'killservers - kills all servers -;; 'dejunk - removes junk records -;; 'adj-testids - move test-ids into correct ranges -;; 'old2new - sync megatest.db to /tmp/.../megatest.db and /tmp/.../megatest_ref.db -;; 'new2old - sync /tmp/.../megatest.db to megatest.db and /tmp/.../megatest_ref.db (and update data_synced) -;; 'closeall - close all opened dbs -;; 'schema - attempt to apply schema changes -;; run-ids: '(1 2 3 ...) or #f (for all) -;; -(define (db:multi-db-sync dbstruct . options) - ;; (if (not (launch:setup)) - ;; (debug:print 0 *default-log-port* "ERROR: not able to setup up for megatest.") - (let* ((mtdb (dbr:dbstruct-mtdb dbstruct)) - (tmpdb (db:get-db dbstruct)) - (refndb (dbr:dbstruct-refndb dbstruct)) - (allow-cleanup #t) ;; (if run-ids #f #t)) - (servers (server:get-list *toppath*)) ;; (tasks:get-all-servers (db:delay-if-busy tdbdat))) - (data-synced 0)) ;; count of changed records (I hope) - - (for-each - (lambda (option) - - (case option - ;; kill servers - ((killservers) - (for-each - (lambda (server) - (match-let (((mod-time host port start-time pid) server)) - (if (and host pid) - (tasks:kill-server host pid)))) - servers)) - - ;; clear out junk records - ;; - ((dejunk) - (db:delay-if-busy mtdb) ;; ok to delay on mtdb - (db:clean-up mtdb) - (db:clean-up tmpdb) - (db:clean-up refndb)) - - ;; sync runs, test_meta etc. - ;; - ((old2new) - (set! data-synced - (+ (db:sync-tables (db:sync-all-tables-list dbstruct) #f mtdb tmpdb refndb) - data-synced))) - - ;; now ensure all newdb data are synced to megatest.db - ;; do not use the run-ids list passed in to the function - ;; - ((new2old) - (set! data-synced - (+ (db:sync-tables (db:sync-all-tables-list dbstruct) #f tmpdb refndb mtdb) - data-synced))) - - ((adj-target) - (db:adj-target (db:dbdat-get-db mtdb)) - (db:adj-target (db:dbdat-get-db tmpdb)) - (db:adj-target (db:dbdat-get-db refndb))) - - ((schema) - (db:patch-schema-maindb (db:dbdat-get-db mtdb)) - (db:patch-schema-maindb (db:dbdat-get-db tmpdb)) - (db:patch-schema-maindb (db:dbdat-get-db refndb)) - (db:patch-schema-rundb (db:dbdat-get-db mtdb)) - (db:patch-schema-rundb (db:dbdat-get-db tmpdb)) - (db:patch-schema-rundb (db:dbdat-get-db refndb)))) - - (stack-push! (dbr:dbstruct-dbstack dbstruct) tmpdb)) - options) - data-synced)) - -(define (db:tmp->megatest.db-sync dbstruct last-update) - (let* ((mtdb (dbr:dbstruct-mtdb dbstruct)) - (tmpdb (db:get-db dbstruct)) - (refndb (dbr:dbstruct-refndb dbstruct)) - (res (db:sync-tables (db:sync-all-tables-list dbstruct) last-update tmpdb refndb mtdb))) - (stack-push! (dbr:dbstruct-dbstack dbstruct) tmpdb) - res)) - -;;;; run-ids -;; if #f use *db-local-sync* : or 'local-sync-flags -;; if #t use timestamps : or 'timestamps -;; -;; NB// no-sync-db is the db handle, not a flag! -;; -(define (db:sync-to-megatest.db dbstruct #!key (no-sync-db #f)) - (let* ((start-time (current-seconds)) - (last-full-update (if no-sync-db - (db:no-sync-get/default no-sync-db "LAST_FULL_UPDATE" 0) - 0)) - (full-sync-needed (> (- start-time last-full-update) 3600)) ;; every hour do a full sync - (last-update (if full-sync-needed - 0 - (if no-sync-db - (db:no-sync-get/default no-sync-db "LAST_UPDATE" 0) - 0))) ;; (or (db:get-var dbstruct "LAST_UPDATE") 0)) - (sync-needed (> (- start-time last-update) 6)) - (res (if (or sync-needed ;; don't sync if a sync already occurred in the past 6 seconds - full-sync-needed) - (begin - (if no-sync-db - (begin - (if full-sync-needed (db:no-sync-set no-sync-db "LAST_FULL_UPDATE" start-time)) - (db:no-sync-set no-sync-db "LAST_UPDATE" start-time))) - (db:tmp->megatest.db-sync dbstruct last-update)) - 0)) - (sync-time (- (current-seconds) start-time))) - (debug:print-info 3 *default-log-port* "Sync of newdb to olddb completed in " sync-time " seconds pid="(current-process-id)) - (if (common:low-noise-print 30 "sync new to old") - (if sync-needed - (debug:print-info 0 *default-log-port* "Sync of " res " records from newdb to olddb completed in " sync-time " seconds pid="(current-process-id)) - (debug:print-info 0 *default-log-port* "No sync needed, last updated " (- start-time last-update) " seconds ago"))) - res)) - -;; keeping it around for debugging purposes only -(define (open-run-close-no-exception-handling proc idb . params) - (debug:print-info 11 *default-log-port* "open-run-close-no-exception-handling START given a db=" (if idb "yes " "no ") ", params=" params) - (print "I don't work anymore. open-run-close-no-exception-handling needs fixing or removing...") - (exit) - (if (or *db-write-access* - (not #t)) ;; was: (member proc * db:all-write-procs *))) - (let* ((db (cond - ((pair? idb) (db:dbdat-get-db idb)) - ((sqlite3:database? idb) idb) - ((not idb) (debug:print-error 0 *default-log-port* "cannot open-run-close with #f anymore")) - ((procedure? idb) (idb)) - (else (debug:print-error 0 *default-log-port* "cannot open-run-close with #f anymore")))) - (res #f)) - (set! res (apply proc db params)) - (if (not idb)(sqlite3:finalize! dbstruct)) - (debug:print-info 11 *default-log-port* "open-run-close-no-exception-handling END" ) - res) - #f)) - -(define (open-run-close-exception-handling proc idb . params) - (handle-exceptions - exn - (let ((sleep-time (random 30)) - (err-status ((condition-property-accessor 'sqlite3 'status #f) exn))) - (case err-status - ((busy) - (thread-sleep! sleep-time)) - (else - (debug:print 0 *default-log-port* "EXCEPTION: database probably overloaded or unreadable.") - (debug:print 0 *default-log-port* " message: " ((condition-property-accessor 'exn 'message) exn)) - (debug:print 5 *default-log-port* "exn=" (condition->list exn)) - (debug:print 0 *default-log-port* " status: " ((condition-property-accessor 'sqlite3 'status) exn)) - (print-call-chain (current-error-port)) - (thread-sleep! sleep-time) - (debug:print-info 0 *default-log-port* "trying db call one more time....this may never recover, if necessary kill process " (current-process-id) " on host " (get-host-name) " to clean up"))) - (apply open-run-close-exception-handling proc idb params)) - (apply open-run-close-no-exception-handling proc idb params))) - -;; (define open-run-close -(define open-run-close open-run-close-exception-handling) - ;; open-run-close-no-exception-handling -;; open-run-close-exception-handling) -;;) - -(define (db:initialize-main-db dbdat) - (when (not *configinfo*) - (launch:setup)) ;; added because Elena was getting stack dump because *configinfo* below was #f. - (let* ((configdat (car *configinfo*)) ;; tut tut, global warning... - (keys (keys:config-get-fields configdat)) - (havekeys (> (length keys) 0)) - (keystr (keys->keystr keys)) - (fieldstr (keys:make-key/field-string configdat)) - (db (db:dbdat-get-db dbdat))) - (for-each (lambda (key) - (let ((keyn key)) - (if (member (string-downcase keyn) - (list "runname" "state" "status" "owner" "event_time" "comment" "fail_count" - "pass_count" "contour")) - (begin - (print "ERROR: your key cannot be named " keyn " as this conflicts with the same named field in the runs table, you must remove your megatest.db and /.db before trying again.") - (exit 1))))) - keys) - (sqlite3:with-transaction - db - (lambda () - ;; handle-exceptions - ;; exn - ;; (begin - ;; (debug:print 0 "ERROR: Failed to create tables. Look at your [fields] section, should be: fieldname TEXT DEFAULT 'yourdefault'") - ;; (exit)) - (sqlite3:execute db "CREATE TABLE IF NOT EXISTS keys (id INTEGER PRIMARY KEY, fieldname TEXT, fieldtype TEXT, CONSTRAINT keyconstraint UNIQUE (fieldname));") - (for-each (lambda (key) - (sqlite3:execute db "INSERT OR REPLACE INTO keys (fieldname,fieldtype) VALUES (?,?);" key "TEXT")) - keys) - (sqlite3:execute db (conc - "CREATE TABLE IF NOT EXISTS runs (id INTEGER PRIMARY KEY, \n " - fieldstr (if havekeys "," "") " - runname TEXT DEFAULT 'norun', - contour TEXT DEFAULT '', - state TEXT DEFAULT '', - status TEXT DEFAULT '', - owner TEXT DEFAULT '', - event_time TIMESTAMP DEFAULT (strftime('%s','now')), - comment TEXT DEFAULT '', - fail_count INTEGER DEFAULT 0, - pass_count INTEGER DEFAULT 0, - last_update INTEGER DEFAULT (strftime('%s','now')), - CONSTRAINT runsconstraint UNIQUE (runname" (if havekeys "," "") keystr "));")) - (sqlite3:execute db "CREATE TRIGGER IF NOT EXISTS update_runs_trigger AFTER UPDATE ON runs - FOR EACH ROW - BEGIN - UPDATE runs SET last_update=(strftime('%s','now')) - WHERE id=old.id; - END;") - (sqlite3:execute db "CREATE TABLE IF NOT EXISTS run_stats ( - id INTEGER PRIMARY KEY, - run_id INTEGER, - state TEXT, - status TEXT, - count INTEGER, - last_update INTEGER DEFAULT (strftime('%s','now')))") - (sqlite3:execute db "CREATE TRIGGER IF NOT EXISTS update_run_stats_trigger AFTER UPDATE ON run_stats - FOR EACH ROW - BEGIN - UPDATE run_stats SET last_update=(strftime('%s','now')) - WHERE id=old.id; - END;") - (sqlite3:execute db "CREATE TABLE IF NOT EXISTS test_meta ( + (sqlite3:execute db "CREATE TRIGGER IF NOT EXISTS update_run_stats_trigger AFTER UPDATE ON run_stats + FOR EACH ROW + BEGIN + UPDATE run_stats SET last_update=(strftime('%s','now')) + WHERE id=old.id; + END;") + (sqlite3:execute db "CREATE TABLE IF NOT EXISTS test_meta ( id INTEGER PRIMARY KEY, testname TEXT DEFAULT '', author TEXT DEFAULT '', owner TEXT DEFAULT '', description TEXT DEFAULT '', @@ -1251,11 +180,11 @@ avg_runtime REAL, avg_disk REAL, tags TEXT DEFAULT '', jobgroup TEXT DEFAULT 'default', CONSTRAINT test_meta_constraint UNIQUE (testname));") - (sqlite3:execute db "CREATE TABLE IF NOT EXISTS tasks_queue (id INTEGER PRIMARY KEY, + (sqlite3:execute db "CREATE TABLE IF NOT EXISTS tasks_queue (id INTEGER PRIMARY KEY, action TEXT DEFAULT '', owner TEXT, state TEXT DEFAULT 'new', target TEXT DEFAULT '', name TEXT DEFAULT '', @@ -1262,57 +191,54 @@ testpatt TEXT DEFAULT '', keylock TEXT, params TEXT, creation_time TIMESTAMP DEFAULT (strftime('%s','now')), execution_time TIMESTAMP);") - ;; archive disk areas, cached info from [archive-disks] - (sqlite3:execute db "CREATE TABLE IF NOT EXISTS archive_disks ( + ;; archive disk areas, cached info from [archive-disks] + (sqlite3:execute db "CREATE TABLE IF NOT EXISTS archive_disks ( id INTEGER PRIMARY KEY, archive_area_name TEXT, disk_path TEXT, last_df INTEGER DEFAULT -1, last_df_time TIMESTAMP DEFAULT (strftime('%s','now')), creation_time TIMESTAMP DEFAULT (strftime('%','now')));") - ;; individual bup (or tar) data chunks - (sqlite3:execute db "CREATE TABLE IF NOT EXISTS archive_blocks ( + ;; individual bup (or tar) data chunks + (sqlite3:execute db "CREATE TABLE IF NOT EXISTS archive_blocks ( id INTEGER PRIMARY KEY, archive_disk_id INTEGER, disk_path TEXT, last_du INTEGER DEFAULT -1, last_du_time TIMESTAMP DEFAULT (strftime('%s','now')), creation_time TIMESTAMP DEFAULT (strftime('%','now')));") - ;; tests allocated to what chunks. reusing a chunk for a test/item_path is very efficient - ;; NB// the per run/test recording of where the archive is stored is done in the test - ;; record. - (sqlite3:execute db "CREATE TABLE IF NOT EXISTS archive_allocations ( + ;; tests allocated to what chunks. reusing a chunk for a test/item_path is very efficient + ;; NB// the per run/test recording of where the archive is stored is done in the test + ;; record. + (sqlite3:execute db "CREATE TABLE IF NOT EXISTS archive_allocations ( id INTEGER PRIMARY KEY, archive_block_id INTEGER, testname TEXT, item_path TEXT, creation_time TIMESTAMP DEFAULT (strftime('%','now')));") - ;; move this clean up call somewhere else - (sqlite3:execute db "DELETE FROM tasks_queue WHERE state='done' AND creation_time < ?;" (- (current-seconds)(* 24 60 60))) ;; remove older than 24 hrs - (sqlite3:execute db (conc "CREATE INDEX IF NOT EXISTS runs_index ON runs (runname" (if havekeys "," "") keystr ");")) - ;; (sqlite3:execute db "CREATE VIEW runs_tests AS SELECT * FROM runs INNER JOIN tests ON runs.id=tests.run_id;") - (sqlite3:execute db "CREATE TABLE IF NOT EXISTS extradat (id INTEGER PRIMARY KEY, run_id INTEGER, key TEXT, val TEXT);") - (sqlite3:execute db "CREATE TABLE IF NOT EXISTS metadat (id INTEGER PRIMARY KEY, var TEXT, val TEXT, + ;; move this clean up call somewhere else + (sqlite3:execute db "DELETE FROM tasks_queue WHERE state='done' AND creation_time < ?;" (- (current-seconds)(* 24 60 60))) ;; remove older than 24 hrs + (sqlite3:execute db (conc "CREATE INDEX IF NOT EXISTS runs_index ON runs (runname);")) ;; (if havekeys "," "") keystr ");")) + ;; (sqlite3:execute db "CREATE VIEW runs_tests AS SELECT * FROM runs INNER JOIN tests ON runs.id=tests.run_id;") + (sqlite3:execute db "CREATE TABLE IF NOT EXISTS extradat (id INTEGER PRIMARY KEY, run_id INTEGER, key TEXT, val TEXT);") + (sqlite3:execute db "CREATE TABLE IF NOT EXISTS metadat (id INTEGER PRIMARY KEY, var TEXT, val TEXT, CONSTRAINT metadat_constraint UNIQUE (var));") - (sqlite3:execute db "CREATE TABLE IF NOT EXISTS access_log (id INTEGER PRIMARY KEY, user TEXT, accessed TIMESTAMP, args TEXT);") - ;; Must do this *after* running patch db !! No more. - ;; cannot use db:set-var since it will deadlock, hardwire the code here - (sqlite3:execute db "INSERT OR REPLACE INTO metadat (var,val) VALUES (?,?);" "MEGATEST_VERSION" (common:version-signature)) - (debug:print-info 11 *default-log-port* "db:initialize END") ;; )))) - - ;;====================================================================== - ;; R U N S P E C I F I C D B - ;;====================================================================== - - ;; (define (db:initialize-run-id-db db) - ;; (sqlite3:with-transaction - ;; db - ;; (lambda () - (sqlite3:execute db "CREATE TABLE IF NOT EXISTS tests + (sqlite3:execute db "CREATE TABLE IF NOT EXISTS access_log (id INTEGER PRIMARY KEY, user TEXT, accessed TIMESTAMP, args TEXT);") + ;; Must do this *after* running patch db !! No more. + ;; cannot use db:set-var since it will deadlock, hardwire the code here + + ;; ERROR: Cannot do this here - must update from Megatest itself, not from mtserver + ;; (sqlite3:execute db "INSERT OR REPLACE INTO metadat (var,val) VALUES (?,?);" "MEGATEST_VERSION" (common:version-signature)) + + ;;====================================================================== + ;; R U N S P E C I F I C D B + ;;====================================================================== + + (sqlite3:execute db "CREATE TABLE IF NOT EXISTS tests (id INTEGER PRIMARY KEY, run_id INTEGER DEFAULT -1, testname TEXT DEFAULT 'noname', host TEXT DEFAULT 'n/a', cpuload REAL DEFAULT -1, @@ -1332,11 +258,16 @@ fail_count INTEGER DEFAULT 0, pass_count INTEGER DEFAULT 0, archived INTEGER DEFAULT 0, -- 0=no, > 1=archive block id where test data can be found last_update INTEGER DEFAULT (strftime('%s','now')), CONSTRAINT testsconstraint UNIQUE (run_id, testname, item_path));") - (sqlite3:execute db "CREATE INDEX IF NOT EXISTS tests_index ON tests (run_id, testname, item_path, uname);") + ;; deprecated -- (sqlite3:execute db "CREATE INDEX IF NOT EXISTS tests_index ON tests (run_id, testname, item_path, uname);") + + (sqlite3:execute db "CREATE INDEX IF NOT EXISTS tests_run_id_index ON tests (run_id);") ;; new + (sqlite3:execute db "CREATE INDEX IF NOT EXISTS tests_testname_index ON tests (testname,item_path);") ;; new + (sqlite3:execute db "CREATE INDEX IF NOT EXISTS tests_state_status_index ON tests (state, status); ") ;; new + (sqlite3:execute db "CREATE TRIGGER IF NOT EXISTS update_tests_trigger AFTER UPDATE ON tests FOR EACH ROW BEGIN UPDATE tests SET last_update=(strftime('%s','now')) WHERE id=old.id; @@ -1393,3281 +324,561 @@ state TEXT DEFAULT 'new', status TEXT DEFAULT 'n/a', archive_type TEXT DEFAULT 'bup', du INTEGER, archive_path TEXT);"))) - db)) ;; ) - -;;====================================================================== -;; A R C H I V E S -;;====================================================================== - -;; dneeded is minimum space needed, scan for existing archives that -;; are on disks with adequate space and already have this test/itempath -;; archived -;; -(define (db:archive-get-allocations dbstruct testname itempath dneeded) - (let* ((dbdat (db:get-db dbstruct)) ;; archive tables are in main.db - (db (db:dbdat-get-db dbdat)) - (res '()) - (blocks '())) ;; a block is an archive chunck that can be added too if there is space - (sqlite3:for-each-row - (lambda (id archive-disk-id disk-path last-du last-du-time) - (set! res (cons (vector id archive-disk-id disk-path last-du last-du-time) res))) - db - "SELECT b.id,b.archive_disk_id,b.disk_path,b.last_du,b.last_du_time FROM archive_blocks AS b - INNER JOIN archive_allocations AS a ON a.archive_block_id=b.id - WHERE a.testname=? AND a.item_path=?;" - testname itempath) - ;; Now res has list of candidate paths, look in archive_disks for candidate with potential free space - (if (null? res) - '() - (sqlite3:for-each-row - (lambda (id archive-area-name disk-path last-df last-df-time) - (set! blocks (cons (vector id archive-area-name disk-path last-df last-df-time) blocks))) - db - (conc - "SELECT d.id,d.archive_area_name,disk_path,last_df,last_df_time FROM archive_disks AS d - INNER JOIN archive_blocks AS b ON d.id=b.archive_disk_id - WHERE b.id IN (" (string-intersperse (map conc res) ",") ") AND - last_df > ?;") - dneeded)) - (stack-push! (dbr:dbstruct-dbstack dbstruct) dbdat) - blocks)) - -;; returns id of the record, register a disk allocated to archiving and record it's last known -;; available space -;; -(define (db:archive-register-disk dbstruct bdisk-name bdisk-path df) - (let* ((dbdat (db:get-db dbstruct)) ;; archive tables are in main.db - (db (db:dbdat-get-db dbdat)) - (res #f)) - (sqlite3:for-each-row - (lambda (id) - (set! res id)) - db - "SELECT id FROM archive_disks WHERE archive_area_name=? AND disk_path=?;" - bdisk-name bdisk-path) - (if res ;; record exists, update df and return id - (begin - (sqlite3:execute db "UPDATE archive_disks SET last_df=?,last_df_time=(strftime('%s','now')) - WHERE archive_area_name=? AND disk_path=?;" - df bdisk-name bdisk-path) - (stack-push! (dbr:dbstruct-dbstack dbstruct) dbdat) - res) - (begin - (sqlite3:execute - db - "INSERT OR REPLACE INTO archive_disks (archive_area_name,disk_path,last_df) - VALUES (?,?,?);" - bdisk-name bdisk-path df) - (stack-push! (dbr:dbstruct-dbstack dbstruct) dbdat) - (db:archive-register-disk dbstruct bdisk-name bdisk-path df))))) - -;; record an archive path created on a given archive disk (identified by it's bdisk-id) -;; if path starts with / then it is full, otherwise it is relative to the archive disk -;; preference is to store the relative path. -;; -(define (db:archive-register-block-name dbstruct bdisk-id archive-path #!key (du #f)) - (let* ((dbdat (db:get-db dbstruct)) ;; archive tables are in main.db - (db (db:dbdat-get-db dbdat)) - (res #f)) - ;; first look to see if this path is already registered - (sqlite3:for-each-row - (lambda (id) - (set! res id)) - db - "SELECT id FROM archive_blocks WHERE archive_disk_id=? AND disk_path=?;" - bdisk-id archive-path) - (if res ;; record exists, update du if applicable and return res - (begin - (if du (sqlite3:exectute db "UPDATE archive_blocks SET last_du=?,last_du_time=(strftime('%s','now')) - WHERE archive_disk_id=? AND disk_path=?;" - bdisk-id archive-path du)) - res) - (begin - (sqlite3:execute db "INSERT OR REPLACE INTO archive_blocks (archive_disk_id,disk_path,last_du) - VALUES (?,?,?);" - bdisk-id archive-path (or du 0)) - (db:archive-register-block-name dbstruct bdisk-id archive-path du: du))) - (stack-push! (dbr:dbstruct-dbstack dbstruct) dbdat) - res)) - - -;; The "archived" field in tests is overloaded; 0 = not archived, > 0 archived in block with given id -;; -(define (db:test-set-archive-block-id dbstruct run-id test-id archive-block-id) - (db:with-db - dbstruct - run-id - #f - (lambda (db) - (sqlite3:execute db "UPDATE tests SET archived=? WHERE id=?;" - archive-block-id test-id)))) - -;; Look up the archive block info given a block-id -;; -(define (db:test-get-archive-block-info dbstruct archive-block-id) - (db:with-db - dbstruct - #f - #f - (lambda (db) - (let ((res #f)) - (sqlite3:for-each-row - ;; 0 1 2 3 4 5 - (lambda (id archive-disk-id disk-path last-du last-du-time creation-time) - (set! res (vector id archive-disk-id disk-path last-du last-du-time creation-time))) - db - "SELECT id,archive_disk_id,disk_path,last_du,last_du_time,creation_time FROM archive_blocks WHERE id=?;" - archive-block-id) - res)))) - -;; (define (db:archive-allocate-testsuite/area-to-block block-id testsuite-name areakey) -;; (let* ((dbdat (db:get-db dbstruct #f)) ;; archive tables are in main.db -;; (db (db:dbdat-get-db dbdat)) -;; (res '()) -;; (blocks '())) ;; a block is an archive chunck that can be added too if there is space -;; (sqlite3:for-each-row #f) - -;;====================================================================== -;; L O G G I N G D B -;;====================================================================== - -(define (open-logging-db) - (let* ((dbpath (conc (if *toppath* (conc *toppath* "/") "") "logging.db")) ;; fname) - (dbexists (common:file-exists? dbpath)) - (db (sqlite3:open-database dbpath)) - (handler (make-busy-timeout (if (args:get-arg "-override-timeout") - (string->number (args:get-arg "-override-timeout")) - 136000)))) ;; 136000))) - (sqlite3:set-busy-handler! db handler) - (if (not dbexists) - (begin - (sqlite3:execute db "CREATE TABLE IF NOT EXISTS log (id INTEGER PRIMARY KEY,event_time TIMESTAMP DEFAULT (strftime('%s','now')),logline TEXT,pwd TEXT,cmdline TEXT,pid INTEGER);") - (db:set-sync db) ;; (sqlite3:execute db (conc "PRAGMA synchronous = 0;")) - )) - db)) - -(define (db:log-local-event . loglst) - (let ((logline (apply conc loglst))) - (db:log-event logline))) - -(define (db:log-event logline) - (let ((db (open-logging-db))) - (sqlite3:execute db "INSERT INTO log (logline,pwd,cmdline,pid) VALUES (?,?,?,?);" - logline - (current-directory) - (string-intersperse (argv) " ") - (current-process-id)) - (sqlite3:finalize! db) - logline)) - -;;====================================================================== -;; D B U T I L S -;;====================================================================== - -;;====================================================================== -;; M A I N T E N A N C E -;;====================================================================== - -(define (db:have-incompletes? dbstruct run-id ovr-deadtime) - (let* ((incompleted '()) - (oldlaunched '()) - (toplevels '()) - (deadtime-str (configf:lookup *configdat* "setup" "deadtime")) - (deadtime (if (and deadtime-str - (string->number deadtime-str)) - (string->number deadtime-str) - 72000))) ;; twenty hours - (db:with-db - dbstruct #f #f - (lambda (db) - (if (number? ovr-deadtime)(set! deadtime ovr-deadtime)) - - ;; in RUNNING or REMOTEHOSTSTART for more than 10 minutes - ;; - ;; HOWEVER: this code in run:test seems to work fine - ;; (> (- (current-seconds)(+ (db:test-get-event_time testdat) - ;; (db:test-get-run_duration testdat))) - ;; 600) - ;; (db:delay-if-busy dbdat) - (sqlite3:for-each-row - (lambda (test-id run-dir uname testname item-path) - (if (and (equal? uname "n/a") - (equal? item-path "")) ;; this is a toplevel test - ;; what to do with toplevel? call rollup? - (begin - (set! toplevels (cons (list test-id run-dir uname testname item-path run-id) toplevels)) - (debug:print-info 0 *default-log-port* "Found old toplevel test in RUNNING state, test-id=" test-id)) - (set! incompleted (cons (list test-id run-dir uname testname item-path run-id) incompleted)))) - db - "SELECT id,rundir,uname,testname,item_path FROM tests WHERE run_id=? AND (strftime('%s','now') - event_time) > (run_duration + ?) AND state IN ('RUNNING','REMOTEHOSTSTART');" - run-id deadtime) - - ;; in LAUNCHED for more than one day. Could be long due to job queues TODO/BUG: Need override for this in config - ;; - ;; (db:delay-if-busy dbdat) - (sqlite3:for-each-row - (lambda (test-id run-dir uname testname item-path) - (if (and (equal? uname "n/a") - (equal? item-path "")) ;; this is a toplevel test - ;; what to do with toplevel? call rollup? - (set! toplevels (cons (list test-id run-dir uname testname item-path run-id) toplevels)) - (set! oldlaunched (cons (list test-id run-dir uname testname item-path run-id) oldlaunched)))) - db - "SELECT id,rundir,uname,testname,item_path FROM tests WHERE run_id=? AND (strftime('%s','now') - event_time) > 86400 AND state IN ('LAUNCHED');" - run-id) - - (debug:print-info 18 *default-log-port* "Found " (length oldlaunched) " old LAUNCHED items, " (length toplevels) " old LAUNCHED toplevel tests and " (length incompleted) " tests marked RUNNING but apparently dead.") - (if (and (null? incompleted) - (null? oldlaunched) - (null? toplevels)) - #f - #t))))) - -;; given a launch delay (minimum time from last launch) return amount of time to wait -;; -;; (define (db:launch-delay-left dbstruct run-id launch-delay) - - -;; select end_time-now from -;; (select testname,item_path,event_time+run_duration as -;; end_time,strftime('%s','now') as now from tests where state in -;; ('RUNNING','REMOTEHOSTSTART','LAUNCHED')); - -(define (db:find-and-mark-incomplete dbstruct run-id ovr-deadtime) - (let* ((incompleted '()) - (oldlaunched '()) - (toplevels '()) - (deadtime-str (configf:lookup *configdat* "setup" "deadtime")) ;; FIXME suspect test run time & deadtime are not well matched; resulting in COMPLETED/DEAD status of an a-ok running test - (deadtime (if (and deadtime-str - (string->number deadtime-str)) - (string->number deadtime-str) - 7200))) ;; two hours - (db:with-db - dbstruct #f #f - (lambda (db) - (if (number? ovr-deadtime)(set! deadtime ovr-deadtime)) - - ;; in RUNNING or REMOTEHOSTSTART for more than 10 minutes - ;; - ;; HOWEVER: this code in run:test seems to work fine - ;; (> (- (current-seconds)(+ (db:test-get-event_time testdat) - ;; (db:test-get-run_duration testdat))) - ;; 600) - ;; (db:delay-if-busy dbdat) - (sqlite3:for-each-row - (lambda (test-id run-dir uname testname item-path) - (if (and (equal? uname "n/a") - (equal? item-path "")) ;; this is a toplevel test - ;; what to do with toplevel? call rollup? - (begin - (set! toplevels (cons (list test-id run-dir uname testname item-path run-id) toplevels)) - (debug:print-info 0 *default-log-port* "Found old toplevel test in RUNNING state, test-id=" test-id)) - (set! incompleted (cons (list test-id run-dir uname testname item-path run-id) incompleted)))) - db - "SELECT id,rundir,uname,testname,item_path FROM tests WHERE run_id=? AND (strftime('%s','now') - event_time) > (run_duration + ?) AND state IN ('RUNNING','REMOTEHOSTSTART');" - run-id deadtime) - - ;; in LAUNCHED for more than one day. Could be long due to job queues TODO/BUG: Need override for this in config - ;; - ;; (db:delay-if-busy dbdat) - (sqlite3:for-each-row - (lambda (test-id run-dir uname testname item-path) - (if (and (equal? uname "n/a") - (equal? item-path "")) ;; this is a toplevel test - ;; what to do with toplevel? call rollup? - (set! toplevels (cons (list test-id run-dir uname testname item-path run-id) toplevels)) - (set! oldlaunched (cons (list test-id run-dir uname testname item-path run-id) oldlaunched)))) - db - "SELECT id,rundir,uname,testname,item_path FROM tests WHERE run_id=? AND (strftime('%s','now') - event_time) > 86400 AND state IN ('LAUNCHED');" - run-id) - - (debug:print-info 18 *default-log-port* "Found " (length oldlaunched) " old LAUNCHED items, " (length toplevels) " old LAUNCHED toplevel tests and " (length incompleted) " tests marked RUNNING but apparently dead.") - - ;; These are defunct tests, do not do all the overhead of set-state-status. Force them to INCOMPLETE. - ;; - ;; (db:delay-if-busy dbdat) - (let* (;; (min-incompleted (filter (lambda (x) - ;; (let* ((testpath (cadr x)) - ;; (tdatpath (conc testpath "/testdat.db")) - ;; (dbexists (common:file-exists? tdatpath))) - ;; (or (not dbexists) ;; if no file then something wrong - mark as incomplete - ;; (> (- (current-seconds)(file-modification-time tdatpath)) 600)))) ;; no change in 10 minutes to testdat.db - she's dead Jim - ;; incompleted)) - (min-incompleted-ids (map car incompleted)) ;; do 'em all - (all-ids (append min-incompleted-ids (map car oldlaunched)))) - (if (> (length all-ids) 0) - (begin - (debug:print 0 *default-log-port* "WARNING: Marking test(s); " (string-intersperse (map conc all-ids) ", ") " as INCOMPLETE") - (for-each - (lambda (test-id) - (db:test-set-state-status dbstruct run-id test-id "COMPLETED" "DEAD" "Test failed to complete")) ;; fix for one aspect of Randy's ticket 1405717332 ;; TODO - fix problem where test goes to COMPLETED/DEAD while in progress, only later to go to COMPLETED/PASS. ref ticket 220546828 - - all-ids)))))))) - -;; ALL REPLACED BY THE BLOCK ABOVE -;; -;; (sqlite3:execute -;; db -;; (conc "UPDATE tests SET state='INCOMPLETE' WHERE run_id=? AND id IN (" -;; (string-intersperse (map conc all-ids) ",") -;; ");") -;; run-id)))) -;; -;; ;; Now do rollups for the toplevel tests -;; ;; -;; ;; (db:delay-if-busy dbdat) -;; (for-each -;; (lambda (toptest) -;; (let ((test-name (list-ref toptest 3))) -;; ;; (run-id (list-ref toptest 5))) -;; (db:top-test-set-per-pf-counts dbstruct run-id test-name))) -;; toplevels))) - -;; BUG: Probably broken - does not explicitly use run-id in the query -;; -(define (db:top-test-set-per-pf-counts dbstruct run-id test-name) - (db:general-call dbstruct 'top-test-set-per-pf-counts (list test-name test-name test-name test-name test-name test-name test-name test-name test-name test-name test-name test-name test-name test-name test-name test-name test-name))) - -;; Clean out old junk and vacuum the database -;; -;; Ultimately do something like this: -;; -;; 1. Look at test records either deleted or part of deleted run: -;; a. If test dir exists, set the the test to state='UNKNOWN', Set the run to 'unknown' -;; b. If test dir gone, delete the test record -;; 2. Look at run records -;; a. If have tests that are not deleted, set state='unknown' -;; b. .... -;; -(define (db:clean-up dbdat) - ;; (debug:print 0 *default-log-port* "WARNING: db clean up not fully ported to v1.60, cleanup action will be on megatest.db") - (let* ((keep-record-age ( - (current-seconds) (common:hms-string->seconds (or (configf:lookup *configdat* "setup" "delete-record-age") "30d")))) - (db (db:dbdat-get-db dbdat)) - (count-stmt (sqlite3:prepare db "SELECT (SELECT count(id) FROM tests)+(SELECT count(id) FROM runs);")) - (statements - (map (lambda (stmt) - (sqlite3:prepare db stmt)) - (list - ;; delete all tests that belong to runs that are 'deleted' - (conc "DELETE FROM tests WHERE run_id in (SELECT id FROM runs WHERE state='deleted') and last_update < " keep-record-age ";") - ;; delete all tests that are 'DELETED' - (conc "DELETE FROM tests WHERE state='DELETED' and last_update < " keep-record-age " ;") - ;; delete all tests that have no run - (conc "DELETE FROM tests WHERE run_id NOT IN (SELECT DISTINCT id FROM runs) and last_update < " keep-record-age "; ") - ;; delete all runs that are state='deleted' - (conc "DELETE FROM runs WHERE state='deleted' and last_update < " keep-record-age ";") - ;; delete empty runs - (conc "DELETE FROM runs WHERE id NOT IN (SELECT DISTINCT r.id FROM runs AS r INNER JOIN tests AS t ON t.run_id=r.id) and last_update < " keep-record-age ";") - ;; remove orphaned test_rundat entries - (conc "DELETE FROM test_rundat where test_id NOT IN (SELECT id FROM tests);") - ;; remove orphaned test_steps entries - (conc "DELETE FROM test_steps WHERE test_id NOT IN (SELECT id FROM tests);") - ;; remove orphaned test_dat entries - (conc "DELETE FROM test_data WHERE test_id NOT IN (SELECT id FROM tests);") - - )))) - ;; (db:delay-if-busy dbdat) - ;(debug:print-info 0 *default-log-port* statements) - (sqlite3:with-transaction - db - (lambda () - (sqlite3:for-each-row (lambda (tot) - (debug:print-info 0 *default-log-port* "Records count before clean: " tot)) - count-stmt) - (map sqlite3:execute statements) - (sqlite3:for-each-row (lambda (tot) - (debug:print-info 0 *default-log-port* "Records count after clean: " tot)) - count-stmt))) - (map sqlite3:finalize! statements) - (sqlite3:finalize! count-stmt) - ;; (db:find-and-mark-incomplete db) - ;; (db:delay-if-busy dbdat) - (sqlite3:execute db "VACUUM;"))) - -;; Clean out old junk and vacuum the database -;; -;; Ultimately do something like this: -;; -;; 1. Look at test records either deleted or part of deleted run: -;; a. If test dir exists, set the the test to state='UNKNOWN', Set the run to 'unknown' -;; b. If test dir gone, delete the test record -;; 2. Look at run records -;; a. If have tests that are not deleted, set state='unknown' -;; b. .... -;; -(define (db:clean-up-rundb dbdat) - ;; (debug:print 0 *default-log-port* "WARNING: db clean up not fully ported to v1.60, cleanup action will be on megatest.db") - (let* ((db (db:dbdat-get-db dbdat)) - (count-stmt (sqlite3:prepare db "SELECT (SELECT count(id) FROM tests);")) - (statements - (map (lambda (stmt) - (sqlite3:prepare db stmt)) - (list - ;; delete all tests that belong to runs that are 'deleted' - ;; (conc "DELETE FROM tests WHERE run_id NOT IN (" (string-intersperse (map conc valid-runs) ",") ");") - ;; delete all tests that are 'DELETED' - "DELETE FROM tests WHERE state='DELETED';" - )))) - ;; (db:delay-if-busy dbdat) - (sqlite3:with-transaction - db - (lambda () - (sqlite3:for-each-row (lambda (tot) - (debug:print-info 0 *default-log-port* "Records count before clean: " tot)) - count-stmt) - (map sqlite3:execute statements) - (sqlite3:for-each-row (lambda (tot) - (debug:print-info 0 *default-log-port* "Records count after clean: " tot)) - count-stmt))) - (map sqlite3:finalize! statements) - (sqlite3:finalize! count-stmt) - ;; (db:find-and-mark-incomplete db) - ;; (db:delay-if-busy dbdat) - (sqlite3:execute db "VACUUM;"))) - -;; Clean out old junk and vacuum the database -;; -;; Ultimately do something like this: -;; -;; 1. Look at test records either deleted or part of deleted run: -;; a. If test dir exists, set the the test to state='UNKNOWN', Set the run to 'unknown' -;; b. If test dir gone, delete the test record -;; 2. Look at run records -;; a. If have tests that are not deleted, set state='unknown' -;; b. .... -;; -(define (db:clean-up-maindb dbdat) - ;; (debug:print 0 *default-log-port* "WARNING: db clean up not fully ported to v1.60, cleanup action will be on megatest.db") - (let* ((db (db:dbdat-get-db dbdat)) - (count-stmt (sqlite3:prepare db "SELECT (SELECT count(id) FROM runs);")) - (statements - (map (lambda (stmt) - (sqlite3:prepare db stmt)) - (list - ;; delete all tests that belong to runs that are 'deleted' - ;; (conc "DELETE FROM tests WHERE run_id NOT IN (" (string-intersperse (map conc valid-runs) ",") ");") - ;; delete all tests that are 'DELETED' - "DELETE FROM runs WHERE state='deleted';" - ))) - (dead-runs '())) - (sqlite3:for-each-row - (lambda (run-id) - (set! dead-runs (cons run-id dead-runs))) - db - "SELECT id FROM runs WHERE state='deleted';") - ;; (db:delay-if-busy dbdat) - (sqlite3:with-transaction - db - (lambda () - (sqlite3:for-each-row (lambda (tot) - (debug:print-info 0 *default-log-port* "Records count before clean: " tot)) - count-stmt) - (map sqlite3:execute statements) - (sqlite3:for-each-row (lambda (tot) - (debug:print-info 0 *default-log-port* "Records count after clean: " tot)) - count-stmt))) - (map sqlite3:finalize! statements) - (sqlite3:finalize! count-stmt) - ;; (db:find-and-mark-incomplete db) - ;; (db:delay-if-busy dbdat) - (sqlite3:execute db "VACUUM;") - dead-runs)) - -;;====================================================================== -;; M E T A G E T A N D S E T V A R S -;;====================================================================== - -;; returns number if string->number is successful, string otherwise -;; also updates *global-delta* -;; -(define (db:get-var dbstruct var) - (let* ((res #f)) - (db:with-db - dbstruct #f #f - (lambda (db) - (sqlite3:for-each-row - (lambda (val) - (set! res val)) - db - "SELECT val FROM metadat WHERE var=?;" var) - ;; convert to number if can - (if (string? res) - (let ((valnum (string->number res))) - (if valnum (set! res valnum)))) - res)))) - -;; This was part of db:get-var. It was used to estimate the load on -;; the database files. -;; -;; scale by 10, average with current value. -;; (set! *global-delta* (/ (+ *global-delta* (* (- (current-milliseconds) start-ms) -;; (if throttle throttle 0.01))) -;; 2)) -;; (if (> (abs (- *last-global-delta-printed* *global-delta*)) 0.08) ;; don't print all the time, only if it changes a bit -;; (begin -;; (debug:print-info 4 *default-log-port* "launch throttle factor=" *global-delta*) -;; (set! *last-global-delta-printed* *global-delta*))) - -(define (db:set-var dbstruct var val) - (db:with-db dbstruct #f #t - (lambda (db) - (sqlite3:execute db "INSERT OR REPLACE INTO metadat (var,val) VALUES (?,?);" var val)))) - -(define (db:del-var dbstruct var) - (db:with-db dbstruct #f #t - (lambda (db) - (sqlite3:execute db "DELETE FROM metadat WHERE var=?;" var)))) - -;;====================================================================== -;; no-sync.db - small bits of data to be shared between servers -;;====================================================================== - -(define (db:open-no-sync-db) - (let* ((dbpath (db:dbfile-path)) - (dbname (conc dbpath "/no-sync.db")) - (db-exists (common:file-exists? dbname)) - (db (sqlite3:open-database dbname))) - (sqlite3:set-busy-handler! db (make-busy-timeout 136000)) - (if (not db-exists) - (begin - (sqlite3:execute db "PRAGMA synchronous = 0;") - (sqlite3:execute db "CREATE TABLE IF NOT EXISTS no_sync_metadat (var TEXT,val TEXT, CONSTRAINT no_sync_metadat_constraint UNIQUE (var));") - (sqlite3:execute db "PRAGMA journal_mode=WAL;"))) - db)) - -;; if we are not a server create a db handle. this is not finalized -;; so watch for problems. I'm still not clear if it is needed to manually -;; finalize sqlite3 dbs with the sqlite3 egg. -;; -(define (db:no-sync-db db-in) - (mutex-lock! *db-access-mutex*) - (let ((res (if db-in - db-in - (let ((db (db:open-no-sync-db))) - (set! *no-sync-db* db) - db)))) - (mutex-unlock! *db-access-mutex*) - res)) - -(define (db:no-sync-set db var val) - (sqlite3:execute (db:no-sync-db db) "INSERT OR REPLACE INTO no_sync_metadat (var,val) VALUES (?,?);" var val)) - -(define (db:no-sync-del! db var) - (sqlite3:execute (db:no-sync-db db) "DELETE FROM no_sync_metadat WHERE var=?;" var)) - -(define (db:no-sync-get/default db var default) - (let ((res default)) - (sqlite3:for-each-row - (lambda (val) - (set! res val)) - (db:no-sync-db db) - "SELECT val FROM no_sync_metadat WHERE var=?;" - var) - (if res - (let ((newres (if (string? res) - (string->number res) - #f))) - (if newres - newres - res)) - res))) - -(define (db:no-sync-close-db db) - (db:safely-close-sqlite3-db db)) - -;; transaction protected lock aquisition -;; either: -;; fails returns (#f . lock-creation-time) -;; succeeds (returns (#t . lock-creation-time) -;; use (db:no-sync-del! db keyname) to release the lock -;; -(define (db:no-sync-get-lock db-in keyname) - (let ((db (db:no-sync-db db-in))) - (sqlite3:with-transaction - db - (lambda () - (handle-exceptions - exn - (let ((lock-time (current-seconds))) - (sqlite3:execute db "INSERT INTO no_sync_metadat (var,val) VALUES(?,?);" keyname lock-time) - `(#t . ,lock-time)) - `(#f . ,(sqlite3:first-result db "SELECT val FROM no_sync_metadat WHERE var=?;" keyname))))))) - - - -;; use a global for some primitive caching, it is just silly to -;; re-read the db over and over again for the keys since they never -;; change - -;; why get the keys from the db? why not get from the *configdat* -;; using keys:config-get-fields? - -(define (db:get-keys dbstruct) - (if *db-keys* *db-keys* - (let ((res '())) - (db:with-db dbstruct #f #f - (lambda (db) - (sqlite3:for-each-row - (lambda (key) - (set! res (cons key res))) - db - "SELECT fieldname FROM keys ORDER BY id DESC;"))) - (set! *db-keys* res) - res))) - -;; look up values in a header/data structure -(define (db:get-value-by-header row header field) - (if (or (null? header) (not row)) - #f - (let loop ((hed (car header)) - (tal (cdr header)) - (n 0)) - (if (equal? hed field) - (handle-exceptions - exn - (begin - (debug:print 0 *default-log-port* "WARNING: attempt to read non-existant field, row=" row " header=" header " field=" field) - #f) - (vector-ref row n)) - (if (null? tal) #f (loop (car tal)(cdr tal)(+ n 1))))))) - -;; Accessors for the header/data structure -;; get rows and header from -(define (db:get-header vec)(vector-ref vec 0)) -(define (db:get-rows vec)(vector-ref vec 1)) - -;;====================================================================== -;; R U N S -;;====================================================================== - - - - - -(define (db:get-run-times dbstruct run-patt target-patt) -(let ((res `()) - (qry (conc "select runname, (max(end_time)-min(event_time))/60 as runtime, target from (select runname, run_id,tests.event_time,tests.event_time+run_duration AS end_time, " (string-join (db:get-keys dbstruct) " || '/' || ") " as target from tests inner join runs on tests.run_id = runs.id where runs.runname like ? and target like ?) group by run_id ;"))) -;(print qry) -(db:with-db - dbstruct - #f ;; this is for the main runs db - #f ;; does not modify db - (lambda (db) - (sqlite3:for-each-row - (lambda (runname runtime target ) - (set! res (cons (vector runname runtime target) res))) - db - qry - run-patt target-patt) - - res)))) - - - -(define (db:get-run-name-from-id dbstruct run-id) - (db:with-db - dbstruct - #f ;; this is for the main runs db - #f ;; does not modify db - (lambda (db) - (let ((res #f)) - (sqlite3:for-each-row - (lambda (runname) - (set! res runname)) - db - "SELECT runname FROM runs WHERE id=?;" - run-id) - res)))) - -(define (db:get-run-key-val dbstruct run-id key) - (db:with-db - dbstruct - #f - #f - (lambda (db) - (let ((res #f)) - (sqlite3:for-each-row - (lambda (val) - (set! res val)) - db - (conc "SELECT " key " FROM runs WHERE id=?;") - run-id) - res)))) - -;; keys list to key1,key2,key3 ... -(define (runs:get-std-run-fields keys remfields) - (let* ((header (append keys remfields)) - (keystr (conc (keys->keystr keys) "," - (string-intersperse remfields ",")))) - (list keystr header))) - -;; make a query (fieldname like 'patt1' OR fieldname -(define (db:patt->like fieldname pattstr #!key (comparator " OR ")) - (let ((patts (if (string? pattstr) - (string-split pattstr ",") - '("%")))) - (string-intersperse (map (lambda (patt) - (let ((wildtype (if (substring-index "%" patt) "LIKE" "GLOB"))) - (conc fieldname " " wildtype " '" patt "'"))) - (if (null? patts) - '("") - patts)) - comparator))) - - -;; register a test run with the db, this accesses the main.db and does NOT -;; use server api -;; -(define (db:register-run dbstruct keyvals runname state status user contour-in) - (let* ((keys (map car keyvals)) - (keystr (keys->keystr keys)) - (contour (or contour-in "")) ;; empty string to force no hierarcy and be backwards compatible. - (comma (if (> (length keys) 0) "," "")) - (andstr (if (> (length keys) 0) " AND " "")) - (valslots (keys->valslots keys)) ;; ?,?,? ... - (allvals (append (list runname state status user contour) (map cadr keyvals))) - (qryvals (append (list runname) (map cadr keyvals))) - (key=?str (string-intersperse (map (lambda (k)(conc k "=?")) keys) " AND "))) - (debug:print 3 *default-log-port* "keys: " keys " allvals: " allvals " keyvals: " keyvals " key=?str is " key=?str) - (debug:print 2 *default-log-port* "NOTE: using target " (string-intersperse (map cadr keyvals) "/") " for this run") - (if (and runname (null? (filter (lambda (x)(not x)) keyvals))) ;; there must be a better way to "apply and" - (db:with-db - dbstruct #f #f - (lambda (db) - (let ((res #f)) - (apply sqlite3:execute db (conc "INSERT OR IGNORE INTO runs (runname,state,status,owner,event_time,contour" comma keystr ") VALUES (?,?,?,?,strftime('%s','now'),?" comma valslots ");") - allvals) - (apply sqlite3:for-each-row - (lambda (id) - (set! res id)) - db - (let ((qry (conc "SELECT id FROM runs WHERE (runname=? " andstr key=?str ");"))) - qry) - qryvals) - (sqlite3:execute db "UPDATE runs SET state=?,status=?,event_time=strftime('%s','now') WHERE id=? AND state='deleted';" state status res) - res))) - (begin - (debug:print-error 0 *default-log-port* "Called without all necessary keys") - #f)))) - -;; replace header and keystr with a call to runs:get-std-run-fields -;; -;; keypatts: ( (KEY1 "abc%def")(KEY2 "%") ) -;; runpatts: patt1,patt2 ... -;; -(define (db:get-runs dbstruct runpatt count offset keypatts) - (let* ((res '()) - (keys (db:get-keys dbstruct)) - (runpattstr (db:patt->like "runname" runpatt)) - (remfields (list "id" "runname" "state" "status" "owner" "event_time")) - (header (append keys remfields)) - (keystr (conc (keys->keystr keys) "," - (string-intersperse remfields ","))) - (qrystr (conc "SELECT " keystr " FROM runs WHERE (" runpattstr ") " ;; runname LIKE ? " - ;; Generate: " AND x LIKE 'keypatt' ..." - (if (null? keypatts) "" - (conc " AND " - (string-join - (map (lambda (keypatt) - (let ((key (car keypatt)) - (patt (cadr keypatt))) - (db:patt->like key patt))) - keypatts) - " AND "))) - " AND state != 'deleted' ORDER BY event_time DESC " - (if (number? count) - (conc " LIMIT " count) - "") - (if (number? offset) - (conc " OFFSET " offset) - "")))) - (debug:print-info 11 *default-log-port* "db:get-runs START qrystr: " qrystr " keypatts: " keypatts " offset: " offset " limit: " count) - (db:with-db dbstruct #f #f - (lambda (db) - (sqlite3:for-each-row - (lambda (a . x) - (set! res (cons (apply vector a x) res))) - db - qrystr - ))) - (debug:print-info 11 *default-log-port* "db:get-runs END qrystr: " qrystr " keypatts: " keypatts " offset: " offset " limit: " count) - (vector header res))) - - -(define-record simple-run target id runname state status owner event_time) -(define-record-printer (simple-run x out) - (fprintf out "#,(simple-run ~S ~S ~S ~S)" - (simple-run-target x) (simple-run-id x) (simple-run-runname x) (time->string (seconds->local-time (simple-run-event_time x) )))) - -;; simple get-runs -;; -(define (db:simple-get-runs dbstruct runpatt count offset target) - (let* ((res '()) - (keys (db:get-keys dbstruct)) - (runpattstr (db:patt->like "runname" runpatt)) - (remfields (list "id" "runname" "state" "status" "owner" "event_time")) - (targstr (string-intersperse keys "||'/'||")) - (keystr (conc targstr " AS target," - (string-intersperse remfields ","))) - (qrystr (conc "SELECT " keystr " FROM runs WHERE (" runpattstr ") " ;; runname LIKE ? " - ;; Generate: " AND x LIKE 'keypatt' ..." - " AND target LIKE '" target "'" - " AND state != 'deleted' ORDER BY event_time DESC " - (if (number? count) - (conc " LIMIT " count) - "") - (if (number? offset) - (conc " OFFSET " offset) - "")))) - (debug:print-info 11 *default-log-port* "db:get-runs START qrystr: " qrystr " target: " target " offset: " offset " limit: " count) - (db:with-db dbstruct #f #f - (lambda (db) - (sqlite3:for-each-row - (lambda (target id runname state status owner event_time) - (set! res (cons (make-simple-run target id runname state status owner event_time) res))) - db - qrystr - ))) - (debug:print-info 11 *default-log-port* "db:get-runs END qrystr: " qrystr " target: " target " offset: " offset " limit: " count) - res)) - -;; TODO: Switch this to use max(update_time) from each run db? Then if using a server there is no disk traffic (using inmem db) -;; -(define (db:get-changed-run-ids since-time) - (let* ((dbdir (db:dbfile-path)) ;; (configf:lookup *configdat* "setup" "dbdir")) - (alldbs (glob (conc dbdir "/[0-9]*.db"))) - (changed (filter (lambda (dbfile) - (> (file-modification-time dbfile) since-time)) - alldbs))) - (delete-duplicates - (map (lambda (dbfile) - (let* ((res (string-match ".*\\/(\\d)*\\.db" dbfile))) - (if res - (string->number (cadr res)) - (begin - (debug:print 2 *default-log-port* "WARNING: Failed to process " dbfile " for run-id") - 0)))) - changed)))) - -;; Get all targets from the db -;; -(define (db:get-targets dbstruct) - (let* ((res '()) - (keys (db:get-keys dbstruct)) - (header keys) ;; (map key:get-fieldname keys)) - (keystr (keys->keystr keys)) - (qrystr (conc "SELECT " keystr " FROM runs WHERE state != 'deleted';")) - (seen (make-hash-table))) - (db:with-db - dbstruct - #f - #f - (lambda (db) - (sqlite3:for-each-row - (lambda (a . x) - (let ((targ (cons a x))) - (if (not (hash-table-ref/default seen targ #f)) - (begin - (hash-table-set! seen targ #t) - (set! res (cons (apply vector targ) res)))))) - db - qrystr) - (debug:print-info 11 *default-log-port* "db:get-targets END qrystr: " qrystr ) - (vector header res))))) - -;; just get count of runs -(define (db:get-num-runs dbstruct runpatt) - (db:with-db - dbstruct - #f - #f - (lambda (db) - (let ((numruns 0)) - (debug:print-info 11 *default-log-port* "db:get-num-runs START " runpatt) - (sqlite3:for-each-row - (lambda (count) - (set! numruns count)) - db - "SELECT COUNT(id) FROM runs WHERE runname LIKE ? AND state != 'deleted';" runpatt) - (debug:print-info 11 *default-log-port* "db:get-num-runs END " runpatt) - numruns)))) - -;; just get count of runs -(define (db:get-runs-cnt-by-patt dbstruct runpatt targetpatt keys) - (db:with-db - dbstruct - #f - #f - (lambda (db) - (let ((numruns 0) - (qry-str #f) - (key-patt "") - (keyvals (if targetpatt (keys:target->keyval keys targetpatt) '()))) - - (for-each (lambda (keyval) - (let* ((key (car keyval)) - (patt (cadr keyval)) - (fulkey (conc ":" key)) - (wildtype (if (substring-index "%" patt) "like" "glob"))) - - (if patt - (set! key-patt (conc key-patt " AND " key " " wildtype " '" patt "'")) - (begin - (debug:print-error 0 *default-log-port* "searching for runs with no pattern set for " fulkey) - (exit 6))))) - keyvals) - ;(print runpatt " -- " key-patt) - (set! qry-str (conc "SELECT COUNT(id) FROM runs WHERE state != 'deleted' AND runname like '" runpatt "'" key-patt)) - ;(print qry-str ) - - (sqlite3:for-each-row - (lambda (count) - (set! numruns count)) - db - qry-str) - (debug:print-info 11 *default-log-port* "db:get-num-runs END " runpatt) - numruns)))) - - -;; (sqlite3#fold-row proc3670 init3671 db-or-stmt3672 . params3673)> -;; -(define (db:get-raw-run-stats dbstruct run-id) - (db:with-db - dbstruct - run-id - #f - (lambda (db) - (sqlite3:fold-row - (lambda (res state status count) - (cons (list state status count) res)) - '() - db - "SELECT state,status,count(id) AS count FROM tests WHERE run_id=? AND NOT(uname='n/a' AND item_path='') GROUP BY state,status;" - run-id)))) - -;; Update run_stats for given run_id -;; input data is a list (state status count) -;; -(define (db:update-run-stats dbstruct run-id stats) - ;; (mutex-lock! *db-transaction-mutex*) - (db:with-db - dbstruct - #f - #f - - (lambda (db) - ;; remove previous data - - (let* ((stmt1 (sqlite3:prepare db "DELETE FROM run_stats WHERE run_id=? AND state=? AND status=?;")) - (stmt2 (sqlite3:prepare db "INSERT INTO run_stats (run_id,state,status,count) VALUES (?,?,?,?);")) - (res - (sqlite3:with-transaction - db - (lambda () - (for-each - (lambda (dat) - (sqlite3:execute stmt1 run-id (car dat)(cadr dat)) - (apply sqlite3:execute stmt2 run-id dat)) - stats))))) - (sqlite3:finalize! stmt1) - (sqlite3:finalize! stmt2) - ;; (mutex-unlock! *db-transaction-mutex*) - res)))) - -(define (db:get-main-run-stats dbstruct run-id) - (db:with-db - dbstruct - #f ;; this data comes from main - #f - (lambda (db) - (sqlite3:fold-row - (lambda (res state status count) - (cons (list state status count) res)) - '() - db - "SELECT state,status,count FROM run_stats WHERE run_id=? AND run_id IN (SELECT id FROM runs WHERE state NOT IN ('DELETED','deleted'));" - run-id)))) - -(define (db:print-current-query-stats) - ;; generate stats from *db-api-call-time* - (let ((ordered-keys (sort (hash-table-keys *db-api-call-time*) - (lambda (a b) - (let ((sum-a (common:sum (hash-table-ref *db-api-call-time* a))) - (sum-b (common:sum (hash-table-ref *db-api-call-time* b)))) - (> sum-a sum-b))))) - (total 0)) - (for-each - (lambda (cmd-key) - (let* ((dat (hash-table-ref *db-api-call-time* cmd-key)) - (num (length dat)) - (avg (if (> num 0) - (/ (common:sum dat)(length dat))))) - (set! total (+ total num)) - (debug:print-info 0 *default-log-port* cmd-key "\tavg: " avg " max: " (common:max dat) " min: " (common:min-max < dat) " num: " (length dat)))) - ordered-keys) - (debug:print-info 0 *default-log-port* "TOTAL: " total " api calls since start."))) - -(define (db:get-all-run-ids dbstruct) - (db:with-db - dbstruct - #f - #f - (lambda (db) - (let ((run-ids '())) - (sqlite3:for-each-row - (lambda (run-id) - (set! run-ids (cons run-id run-ids))) - db - "SELECT id FROM runs WHERE state != 'deleted' ORDER BY event_time DESC;") - (reverse run-ids))))) - -;; get some basic run stats -;; -;; data structure: -;; -;; ( (runname (( state count ) ... )) -;; ( ... -;; -(define (db:get-run-stats dbstruct) - (let* ((totals (make-hash-table)) - (curr (make-hash-table)) - (res '()) - (runs-info '())) - ;; First get all the runname/run-ids - (db:with-db - dbstruct #f #f - (lambda (db) - (sqlite3:for-each-row - (lambda (run-id runname) - (set! runs-info (cons (list run-id runname) runs-info))) - db - "SELECT id,runname FROM runs WHERE state != 'deleted' ORDER BY event_time DESC;"))) ;; If you change this to the more logical ASC please adjust calls to db:get-run-stats - ;; for each run get stats data - (for-each - (lambda (run-info) - ;; get the net state/status counts for this run - (let* ((run-id (car run-info)) - (run-name (cadr run-info))) - (db:with-db - dbstruct - run-id - #f - (lambda (db) - (sqlite3:for-each-row - (lambda (state status count) - (let ((netstate (if (equal? state "COMPLETED") status state))) - (if (string? netstate) - (begin - (hash-table-set! totals netstate (+ (hash-table-ref/default totals netstate 0) count)) - (hash-table-set! curr netstate (+ (hash-table-ref/default curr netstate 0) count)))))) - db - "SELECT state,status,count(id) FROM tests AS t WHERE run_id=? GROUP BY state,status ORDER BY state,status DESC;" - run-id) - ;; add the per run counts to res - (for-each (lambda (state) - (set! res (cons (list run-name state (hash-table-ref curr state)) res))) - (sort (hash-table-keys curr) string>=)) - (set! curr (make-hash-table)))))) - runs-info) - (for-each (lambda (state) - (set! res (cons (list "Totals" state (hash-table-ref totals state)) res))) - (sort (hash-table-keys totals) string>=)) - res)) - -;; db:get-runs-by-patt -;; get runs by list of criteria -;; register a test run with the db -;; -;; Use: (db:get-value-by-header (db:get-header runinfo)(db:get-rows runinfo)) -;; to extract info from the structure returned -;; -(define (db:get-runs-by-patt dbstruct keys runnamepatt targpatt offset limit fields last-update sort-order ) ;; test-name) - (let* ((tmp (runs:get-std-run-fields keys (or fields '("id" "runname" "state" "status" "owner" "event_time")))) - (keystr (car tmp)) - (header (cadr tmp)) - (key-patt "") - (runwildtype (if (substring-index "%" runnamepatt) "like" "glob")) - (qry-str #f) - (keyvals (if targpatt (keys:target->keyval keys targpatt) '()))) - (for-each (lambda (keyval) - (let* ((key (car keyval)) - (patt (cadr keyval)) - (fulkey (conc ":" key)) - (wildtype (if (substring-index "%" patt) "like" "glob"))) - (if patt - (set! key-patt (conc key-patt " AND " key " " wildtype " '" patt "'")) - (begin - (debug:print-error 0 *default-log-port* "searching for runs with no pattern set for " fulkey) - (exit 6))))) - keyvals) - (set! qry-str (conc "SELECT " keystr " FROM runs WHERE state != 'deleted' AND runname " runwildtype " ? " key-patt - (if last-update - (conc " AND last_update >= " last-update " ") - " ") - " ORDER BY event_time " sort-order " " - (if limit (conc " LIMIT " limit) "") - (if offset (conc " OFFSET " offset) "") - ";")) - (debug:print-info 4 *default-log-port* "runs:get-runs-by-patt qry=" qry-str " " runnamepatt) - ;(print "runs:get-runs-by-patt qry=" qry-str " " runnamepatt) - - (vector header - (reverse - (db:with-db dbstruct #f #f ;; reads db, does not write to it. - (lambda (db) - (sqlite3:fold-row - (lambda (res . r) - (cons (list->vector r) res)) - '() - db - qry-str - runnamepatt))))))) - -;; use (get-value-by-header (db:get-header runinfo)(db:get-rows runinfo)) -;; NOTE: Does NOT return a list of rows (or one row) for the first slot of the vector -;; this is inconsistent with get-runs but it makes some sense. -;; -(define (db:get-run-info dbstruct run-id) - ;;(if (hash-table-ref/default *run-info-cache* run-id #f) - ;; (hash-table-ref *run-info-cache* run-id) - (let* ((res (vector #f #f #f #f)) - (keys (db:get-keys dbstruct)) - (remfields (list "id" "runname" "state" "status" "owner" "event_time" "comment" "fail_count" "pass_count" "contour" "last_update")) ;; "area_id")) - (header (append keys remfields)) - (keystr (conc (keys->keystr keys) "," - (string-intersperse remfields ",")))) - (debug:print-info 11 *default-log-port* "db:get-run-info run-id: " run-id " header: " header " keystr: " keystr) - - (db:with-db - dbstruct #f #f - (lambda (db) - (sqlite3:for-each-row - (lambda (a . x) - (set! res (apply vector a x))) - db - (conc "SELECT " keystr " FROM runs WHERE id=?;") - run-id))) - (debug:print-info 11 *default-log-port* "db:get-run-info run-id: " run-id " header: " header " keystr: " keystr) - (let ((finalres (vector header res))) - ;; (hash-table-set! *run-info-cache* run-id finalres) - finalres))) - -(define (db:set-comment-for-run dbstruct run-id comment) - (db:with-db - dbstruct #f #f - (lambda (db) - (sqlite3:execute db "UPDATE runs SET comment=? WHERE id=?;" comment ;; (sdb:qry 'getid comment) - run-id)))) - -;; does not (obviously!) removed dependent data. But why not!!? -(define (db:delete-run dbstruct run-id) - (db:with-db - dbstruct #f #f - (lambda (db) - (sqlite3:with-transaction - db - (lambda () - (sqlite3:execute db "DELETE FROM test_steps WHERE test_id IN (SELECT id FROM tests WHERE run_id=?);" run-id) - (sqlite3:execute db "DELETE FROM test_data WHERE test_id IN (SELECT id FROM tests WHERE run_id=?);" run-id) - (sqlite3:execute db "UPDATE tests SET state='DELETED',comment='' WHERE run_id=?;" run-id) - ;; (db:delay-if-busy dbdat) - (sqlite3:execute db "UPDATE runs SET state='deleted',comment='' WHERE id=?;" run-id)))))) - -(define (db:update-run-event_time dbstruct run-id) - (db:with-db - dbstruct #f #t - (lambda (db) - (sqlite3:execute db "UPDATE runs SET event_time=strftime('%s','now') WHERE id=?;" run-id)))) - -(define (db:lock/unlock-run dbstruct run-id lock unlock user) - (db:with-db - dbstruct #f #t - (lambda (db) - (let ((newlockval (if lock "locked" - (if unlock - "unlocked" - "locked")))) ;; semi-failsafe - (sqlite3:execute db "UPDATE runs SET state=? WHERE id=?;" newlockval run-id) - (sqlite3:execute db "INSERT INTO access_log (user,accessed,args) VALUES(?,strftime('%s','now'),?);" - user (conc newlockval " " run-id)) - (debug:print-info 1 *default-log-port* "" newlockval " run number " run-id))))) - -(define (db:set-run-status dbstruct run-id status msg) - (db:with-db - dbstruct #f #f - (lambda (db) - (if msg - (sqlite3:execute db "UPDATE runs SET status=?,comment=? WHERE id=?;" status msg run-id) - (sqlite3:execute db "UPDATE runs SET status=? WHERE id=?;" status run-id))))) - -(define (db:get-run-status dbstruct run-id) - (let ((res "n/a")) - (db:with-db - dbstruct #f #f - (lambda (db) - (sqlite3:for-each-row - (lambda (status) - (set! res status)) - db - "SELECT status FROM runs WHERE id=?;" - run-id) - res)))) - -;;====================================================================== -;; K E Y S -;;====================================================================== - -;; get key val pairs for a given run-id -;; ( (FIELDNAME1 keyval1) (FIELDNAME2 keyval2) ... ) -(define (db:get-key-val-pairs dbstruct run-id) - (let* ((keys (db:get-keys dbstruct)) - (res '())) - (db:with-db - dbstruct #f #f - (lambda (db) - (for-each - (lambda (key) - (let ((qry (conc "SELECT " key " FROM runs WHERE id=?;"))) - (sqlite3:for-each-row - (lambda (key-val) - (set! res (cons (list key (if (string? key-val) key-val "")) res))) ;; replace non-string bad values with empty string to prevent crashes. This scenario can happen when Megatest is killed on updating the db - db qry run-id))) - keys))) - (reverse res))) - -;; get key vals for a given run-id -(define (db:get-key-vals dbstruct run-id) - (let* ((keys (db:get-keys dbstruct)) - (res '())) - (db:with-db - dbstruct #f #f - (lambda (db) - (for-each - (lambda (key) - (let ((qry (conc "SELECT " key " FROM runs WHERE id=?;"))) - ;; (db:delay-if-busy dbdat) - (sqlite3:for-each-row - (lambda (key-val) - (set! res (cons (if (string? key-val) key-val "") res))) ;; check that the key-val is a string for cases where a crash injected bad data in the megatest.db - db qry run-id))) - keys))) - (let ((final-res (reverse res))) - (hash-table-set! *keyvals* run-id final-res) - final-res))) - -;; The target is keyval1/keyval2..., cached in *target* as it is used often -(define (db:get-target dbstruct run-id) - (let* ((keyvals (db:get-key-vals dbstruct run-id)) - (thekey (string-intersperse (map (lambda (x)(if x x "-na-")) keyvals) "/"))) - thekey)) - -;; Get run-ids for runs with same target but different runnames and NOT run-id -;; -(define (db:get-prev-run-ids dbstruct run-id) - (let* ((keyvals (rmt:get-key-val-pairs run-id)) - (kvalues (map cadr keyvals)) - (keys (rmt:get-keys)) - (qrystr (string-intersperse (map (lambda (x)(conc x "=?")) keys) " AND "))) - (let ((prev-run-ids '())) - (if (null? keyvals) - '() - (begin - (db:with-db dbstruct #f #f ;; #f means work with the zeroth db - i.e. the runs db - (lambda (db) - (apply sqlite3:for-each-row - (lambda (id) - (set! prev-run-ids (cons id prev-run-ids))) - db - (conc "SELECT id FROM runs WHERE " qrystr " AND state != 'deleted' AND id != ?;") - (append kvalues (list run-id))))) - prev-run-ids))))) - -;;====================================================================== -;; T E S T S -;;====================================================================== - -;; states and statuses are lists, turn them into ("PASS","FAIL"...) and use NOT IN -;; i.e. these lists define what to NOT show. -;; states and statuses are required to be lists, empty is ok -;; not-in #t = above behaviour, #f = must match -;; mode: -;; 'dashboard - use state = 'COMPLETED' AND status in ( statuses ) OR state in ( states ) -;; -(define (db:get-tests-for-run dbstruct run-id testpatt states statuses offset limit not-in sort-by sort-order qryvals last-update mode) - (let* ((qryvalstr (case qryvals - ((shortlist) "id,run_id,testname,item_path,state,status") - ((#f) db:test-record-qry-selector) ;; "id,run_id,testname,state,status,event_time,host,cpuload,diskfree,uname,rundir,item_path,run_duration,final_logf,comment") - (else qryvals))) - (res '()) - ;; if states or statuses are null then assume match all when not-in is false - (states-qry (if (null? states) - #f - (conc " state " - (if (eq? mode 'dashboard) - " IN ('" - (if not-in - " NOT IN ('" - " IN ('")) - (string-intersperse states "','") - "')"))) - (statuses-qry (if (null? statuses) - #f - (conc " status " - (if (eq? mode 'dashboard) - " IN ('" - (if not-in - " NOT IN ('" - " IN ('") ) - (string-intersperse statuses "','") - "')"))) - (interim-qry (conc " AND " (if not-in "NOT " "") "( state='COMPLETED' " (if statuses-qry (conc " AND " statuses-qry " ) ") " ) ") - (if states-qry - (conc (if not-in " AND " " OR ") states-qry ) ;; " ) ") - ""))) - (states-statuses-qry - (cond - ((and states-qry statuses-qry) - (case mode - ((dashboard) - (if not-in - (conc " AND (state='COMPLETED' AND status NOT IN ('" (string-intersperse statuses "','") "')) " - " OR (state != 'COMPLETED' AND state NOT IN ('" (string-intersperse states "','") "')) ") - (conc " AND (state='COMPLETED' AND status IN ('" (string-intersperse statuses "','") "')) " - " OR (state NOT IN ('COMPLETED','DELETED') AND state IN ('" (string-intersperse states "','") "')) "))) - (else (conc " AND ( " states-qry " AND " statuses-qry " ) ")))) - (states-qry - (case mode - ((dashboard) (conc " AND " (if not-in "NOT " "") " state IN ('" (string-intersperse states "','") "') ")) ;; interim-qry) - (else (conc " AND " states-qry)))) - (statuses-qry - (case mode - ((dashboard) (conc " AND " (if not-in "NOT " "") " status IN ('" (string-intersperse statuses "','") "') ")) ;; interim-qry) - (else (conc " AND " statuses-qry)))) - (else ""))) - (tests-match-qry (tests:match->sqlqry testpatt)) - (qry (conc "SELECT " qryvalstr - (if run-id - " FROM tests WHERE run_id=? " - " FROM tests WHERE ? > 0 ") ;; should work? - (if last-update " " " AND state != 'DELETED' ") ;; if using last-update we want deleted tests? - states-statuses-qry - (if tests-match-qry (conc " AND (" tests-match-qry ") ") "") - (if last-update (conc " AND last_update >= " last-update " ") "") - (case sort-by - ((rundir) " ORDER BY length(rundir) ") - ((testname) (conc " ORDER BY testname " (if sort-order (conc sort-order ",") "") " item_path ")) - ((statestatus) (conc " ORDER BY state " (if sort-order (conc sort-order ",") "") " status ")) - ((event_time) " ORDER BY event_time ") - (else (if (string? sort-by) - (conc " ORDER BY " sort-by " ") - " "))) - (if sort-order sort-order " ") - (if limit (conc " LIMIT " limit) " ") - (if offset (conc " OFFSET " offset) " ") - ";" - ))) - (debug:print-info 8 *default-log-port* "db:get-tests-for-run run-id=" run-id ", qry=" qry) - (db:with-db dbstruct run-id #f - (lambda (db) - (sqlite3:for-each-row - (lambda (a . b) ;; id run-id testname state status event-time host cpuload diskfree uname rundir item-path run-duration final-logf comment) - (set! res (cons (apply vector a b) res))) ;; id run-id testname state status event-time host cpuload diskfree uname rundir item-path run-duration final-logf comment) res))) - db - qry - (or run-id 1) ;; 1 > 0 , for the case where we are seeking tests matching criteral for all runs - ))) - (case qryvals - ((shortlist)(map db:test-short-record->norm res)) - ((#f) res) - (else res)))) - -(define (db:test-short-record->norm inrec) - ;; "id,run_id,testname,item_path,state,status" - ;; "id,run_id,testname,state,status,event_time,host,cpuload,diskfree,uname,rundir,item_path,run_duration,final_logf,comment - (vector (vector-ref inrec 0) ;; id - (vector-ref inrec 1) ;; run_id - (vector-ref inrec 2) ;; testname - (vector-ref inrec 4) ;; state - (vector-ref inrec 5) ;; status - -1 "" -1 -1 "" "-" - (vector-ref inrec 3) ;; item-path - -1 "-" "-")) - -(define (db:get-tests-for-run-state-status dbstruct run-id testpatt) - (let* ((res '()) - (tests-match-qry (tests:match->sqlqry testpatt)) - (qry (conc "SELECT id,testname,item_path,state,status FROM tests WHERE run_id=? " - (if tests-match-qry (conc " AND (" tests-match-qry ") ") "")))) - (debug:print-info 8 *default-log-port* "db:get-tests-for-run qry=" qry) - (db:with-db dbstruct run-id #f - (lambda (db) - (sqlite3:for-each-row - (lambda (id testname item-path state status) - ;; id,run_id,testname,state,status,event_time,host,cpuload,diskfree,uname,rundir,item_path,run_duration,final_logf,comment - (set! res (cons (vector id run-id testname state status -1 "" -1 -1 "" "-" item-path -1 "-" "-") res))) - db - qry - run-id))) - res)) - -(define (db:get-testinfo-state-status dbstruct run-id test-id) - (let ((res #f)) - (db:with-db dbstruct run-id #f - (lambda (db) - (sqlite3:for-each-row - (lambda (run-id testname item-path state status) - ;; id,run_id,testname,state,status,event_time,host,cpuload,diskfree,uname,rundir,item_path,run_duration,final_logf,comment - (set! res (vector test-id run-id testname state status -1 "" -1 -1 "" "-" item-path -1 "-" "-"))) - db - "SELECT run_id,testname,item_path,state,status FROM tests WHERE id=?;" - test-id))) - res)) - -;; get a useful subset of the tests data (used in dashboard -;; use db:mintest-get-{id ,run_id,testname ...} -;; -(define (db:get-tests-for-run-mindata dbstruct run-id testpatt states statuses not-in) - (db:get-tests-for-run dbstruct run-id testpatt states statuses #f #f not-in #f #f "id,run_id,testname,state,status,event_time,item_path" 0 #f)) - -;; do not use. -;; -(define (db:get-tests-for-runs dbstruct run-ids testpatt states statuses #!key (not-in #f)(qryvals #f)) - ;; (db:delay-if-busy) - (let ((res '())) - (for-each - (lambda (run-id) - (set! res (append - res - (db:get-tests-for-run dbstruct run-id testpatt states statuses #f #f not-in #f #f qryvals #f 'normal)))) - (if run-ids - run-ids - (db:get-all-run-ids dbstruct))) - res)) - -;; Convert calling routines to get list of run-ids and loop, do not use the get-tests-for-runs -;; - -(define (db:delete-test-records dbstruct run-id test-id) - (db:general-call dbstruct 'delete-test-step-records (list test-id)) - (db:general-call dbstruct 'delete-test-data-records (list test-id)) - (db:with-db - dbstruct #f #f - (lambda (db) - (sqlite3:execute db "UPDATE tests SET state='DELETED',status='n/a',comment='' WHERE id=?;" test-id)))) - -;; -(define (db:delete-old-deleted-test-records dbstruct) - (let (;; (run-ids (db:get-all-run-ids dbstruct)) - (targtime (- (current-seconds)(* 30 24 60 60)))) ;; one month in the past - (db:with-db - dbstruct - 0 - #t - (lambda (db) - (sqlite3:with-transaction - db - (lambda () - (sqlite3:execute db "DELETE FROM test_steps WHERE test_id IN (SELECT id FROM tests WHERE state='DELETED' AND event_timenumber fieldname fields) - (if (null? fields) - #f - (let loop ((hed (car fields)) - (tal (cdr fields)) - (indx 0)) - (if (equal? fieldname hed) - indx - (if (null? tal) - #f - (loop (car tal)(cdr tal)(+ indx 1))))))) - -(define db:test-record-qry-selector (string-intersperse db:test-record-fields ",")) - - -;; NOTE: Use db:test-get* to access records -;; NOTE: This needs rundir decoding? Decide, decode here or where used? For the moment decode where used. -(define (db:get-all-tests-info-by-run-id dbstruct run-id) - (let* ((res '())) - (db:with-db - dbstruct #f #f - (lambda (db) - (sqlite3:for-each-row - (lambda (id run-id testname state status event-time host cpuload diskfree uname rundir item-path run-duration final-logf comment shortdir attemptnum archived) - ;; 0 1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 - (set! res (cons (vector id run-id testname state status event-time host cpuload diskfree uname rundir item-path run-duration final-logf comment shortdir attemptnum archived) - res))) - db - (conc "SELECT " db:test-record-qry-selector " FROM tests WHERE state != 'DELETED' AND run_id=?;") - run-id))) - res)) - -(define (db:replace-test-records dbstruct run-id testrecs) - (db:with-db dbstruct run-id #t - (lambda (db) - (let* ((qmarks (string-intersperse (make-list (length db:test-record-fields) "?") ",")) - (qrystr (conc "INSERT OR REPLACE INTO tests (" db:test-record-qry-selector ") VALUES (" qmarks ") WHERE run_id=?;")) - (qry (sqlite3:prepare db qrystr))) - (debug:print 0 *default-log-port* "INFO: migrating test records for run with id " run-id) - (sqlite3:with-transaction - db - (lambda () - (for-each - (lambda (rec) - ;; (debug:print 0 *default-log-port* "INFO: Inserting values: " (string-intersperse (map conc (vector->list rec)) ",") "\n") - (apply sqlite3:execute qry (append (vector->list rec)(list run-id)))) - testrecs))) - (sqlite3:finalize! qry))))) - -;; map a test-id into the proper range -;; -(define (db:adj-test-id mtdb min-test-id test-id) - (if (>= test-id min-test-id) - test-id - (let loop ((new-id min-test-id)) - (let ((test-id-found #f)) - (sqlite3:for-each-row - (lambda (id) - (set! test-id-found id)) - (db:dbdat-get-db mtdb) - "SELECT id FROM tests WHERE id=?;" - new-id) - ;; if test-id-found then need to try again - (if test-id-found - (loop (+ new-id 1)) - (begin - (debug:print-info 0 *default-log-port* "New test id " new-id " selected for test with id " test-id) - (sqlite3:execute mtdb "UPDATE tests SET id=? WHERE id=?;" new-id test-id))))))) - -;; move test ids into the 30k * run_id range -;; -(define (db:prep-megatest.db-adj-test-ids mtdb run-id testrecs) - (debug:print-info 0 *default-log-port* "Adjusting test ids in megatest.db for run " run-id) - (let ((min-test-id (* run-id 30000))) - (for-each - (lambda (testrec) - (let* ((test-id (vector-ref testrec (db:field->number "id" db:test-record-fields)))) - (db:adj-test-id (db:dbdat-get-db mtdb) min-test-id test-id))) - testrecs))) - -;; 1. move test ids into the 30k * run_id range -;; 2. move step ids into the 30k * run_id range -;; -(define (db:prep-megatest.db-for-migration mtdb) - (let* ((run-ids (db:get-all-run-ids mtdb))) - (for-each - (lambda (run-id) - (let ((testrecs (db:get-all-tests-info-by-run-id mtdb run-id))) - (db:prep-megatest.db-adj-test-ids (db:dbdat-get-db mtdb) run-id testrecs))) - run-ids))) - -;; Get test data using test_id, run-id is not used -;; -(define (db:get-test-info-by-id dbstruct run-id test-id) - (db:with-db - dbstruct - #f ;; run-id - #f - (lambda (db) - (let ((res #f)) - (sqlite3:for-each-row ;; attemptnum added to hold pid of top process (not Megatest) controlling a test - (lambda (id run-id testname state status event-time host cpuload diskfree uname rundir-id item-path run_duration final-logf-id comment short-dir-id attemptnum archived last-update) - ;; 0 1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 - (set! res (vector id run-id testname state status event-time host cpuload diskfree uname rundir-id item-path run_duration final-logf-id comment short-dir-id attemptnum archived last-update))) - db - (conc "SELECT " db:test-record-qry-selector " FROM tests WHERE id=?;") - test-id) - res)))) - -;; Use db:test-get* to access -;; Get test data using test_ids. NB// Only works within a single run!! -;; -(define (db:get-test-info-by-ids dbstruct run-id test-ids) - (db:with-db - dbstruct - run-id - #f - (lambda (db) - (let ((res '())) - (sqlite3:for-each-row - (lambda (a . b) - ;; 0 1 2 3 4 5 6 7 8 9 10 11 12 13 14 - (set! res (cons (apply vector a b) res))) - db - (conc "SELECT " db:test-record-qry-selector " FROM tests WHERE id in (" - (string-intersperse (map conc test-ids) ",") ");")) - res)))) - -(define (db:get-test-info dbstruct run-id test-name item-path) - (db:with-db - dbstruct - run-id - #f - (lambda (db) - (let ((res #f)) - (sqlite3:for-each-row - (lambda (a . b) - (set! res (apply vector a b))) - db - (conc "SELECT " db:test-record-qry-selector " FROM tests WHERE testname=? AND item_path=? AND run_id=?;") - test-name item-path run-id) - res)))) - -(define (db:test-get-rundir-from-test-id dbstruct run-id test-id) - (db:with-db - dbstruct - run-id - #f - (lambda (db) - (db:first-result-default - db - "SELECT rundir FROM tests WHERE id=?;" - #f ;; default result - test-id)))) - -(define (db:get-test-times dbstruct run-name target) - (let ((res `()) - (qry (conc "select testname, item_path, run_duration, " (string-join (db:get-keys dbstruct) " || '/' || ") " as target from tests inner join runs on tests.run_id = runs.id where runs.runname = ? and target = ? ;"))) - - (db:with-db - dbstruct - #f ;; this is for the main runs db - #f ;; does not modify db - (lambda (db) - (sqlite3:for-each-row - (lambda (test-name item-path test-time target ) - (set! res (cons (vector test-name item-path test-time) res))) - db - qry - run-name target) - res)))) - -(define (db:get-test-times dbstruct run-name target) - (let ((res `()) - (qry (conc "select testname, item_path, run_duration, " (string-join (db:get-keys dbstruct) " || '/' || ") " as target from tests inner join runs on tests.run_id = runs.id where runs.runname = ? and target = ? ;"))) - - (db:with-db - dbstruct - #f ;; this is for the main runs db - #f ;; does not modify db - (lambda (db) - (sqlite3:for-each-row - (lambda (test-name item-path test-time target ) - (set! res (cons (vector test-name item-path test-time) res))) - db - qry - run-name target) - res)))) - -;;====================================================================== -;; S T E P S -;;====================================================================== - -(define (db:teststep-set-status! dbstruct run-id test-id teststep-name state-in status-in comment logfile) - (db:with-db - dbstruct - run-id - #t - (lambda (db) - (sqlite3:execute - db - "INSERT OR REPLACE into test_steps (test_id,stepname,state,status,event_time,comment,logfile) VALUES(?,?,?,?,?,?,?);" - test-id teststep-name state-in status-in (current-seconds) - (if comment comment "") - (if logfile logfile ""))))) - -;; db-get-test-steps-for-run -(define (db:get-steps-for-test dbstruct run-id test-id) - (db:with-db - dbstruct - run-id - #f - (lambda (db) - (let* ((res '())) - (sqlite3:for-each-row - (lambda (id test-id stepname state status event-time logfile comment) - (set! res (cons (vector id test-id stepname state status event-time (if (string? logfile) logfile "") comment) res))) - db - "SELECT id,test_id,stepname,state,status,event_time,logfile,comment FROM test_steps WHERE status != 'DELETED' AND test_id=? ORDER BY id ASC;" ;; event_time DESC,id ASC; - test-id) - (reverse res))))) - - (define (db:get-steps-info-by-id dbstruct test-step-id) - (db:with-db - dbstruct - #f - #f - (lambda (db) - (let* ((res (vector #f #f #f #f #f #f #f #f #f))) - (sqlite3:for-each-row - (lambda (id test-id stepname state status event-time logfile comment last-update) - (set! res (vector id test-id stepname state status event-time (if (string? logfile) logfile "") comment last-update))) - db - "SELECT id,test_id,stepname,state,status,event_time,logfile,comment,last_update FROM test_steps WHERE id=? ORDER BY id ASC;" ;; event_time DESC,id ASC; - test-step-id) - res)))) - -(define (db:get-steps-data dbstruct run-id test-id) - (db:with-db - dbstruct - run-id - #f - (lambda (db) - (let ((res '())) - (sqlite3:for-each-row - (lambda (id test-id stepname state status event-time logfile) - (set! res (cons (vector id test-id stepname state status event-time (if (string? logfile) logfile "")) res))) - db - "SELECT id,test_id,stepname,state,status,event_time,logfile FROM test_steps WHERE status != 'DELETED' AND test_id=? ORDER BY id ASC;" ;; event_time DESC,id ASC; - test-id) - (reverse res))))) - -;;====================================================================== -;; T E S T D A T A -;;====================================================================== - - (define (db:get-data-info-by-id dbstruct test-data-id) - (db:with-db - dbstruct - #f - #f - (lambda (db) - (let* ((res (vector #f #f #f #f #f #f #f #f #f #f #f #f))) - (sqlite3:for-each-row - (lambda (id test-id category variable value expected tol units comment status type last-update) - (set! res (vector id test-id category variable value expected tol units comment status type last-update))) - db - "SELECT id,test_id, category, variable, value, expected, tol, units, comment, status, type, last_update FROM test_data WHERE id=? ORDER BY id ASC;" ;; event_time DESC,id ASC; - test-data-id) - res)))) - - -;; WARNING: Do NOT call this for the parent test on an iterated test -;; Roll up test_data pass/fail results -;; look at the test_data status field, -;; if all are pass (any case) and the test status is PASS or NULL or '' then set test status to PASS. -;; if one or more are fail (any case) then set test status to PASS, non "pass" or "fail" are ignored -(define (db:test-data-rollup dbstruct run-id test-id status) - (let* ((fail-count 0) - (pass-count 0)) - (db:with-db - dbstruct #f #f - (lambda (db) - (sqlite3:for-each-row - (lambda (fcount pcount) - (set! fail-count fcount) - (set! pass-count pcount)) - db - "SELECT (SELECT count(id) FROM test_data WHERE test_id=? AND status like 'fail') AS fail_count, - (SELECT count(id) FROM test_data WHERE test_id=? AND status like 'pass') AS pass_count;" - test-id test-id) - ;; Now rollup the counts to the central megatest.db - (db:general-call dbstruct 'pass-fail-counts (list pass-count fail-count test-id)) - ;; if the test is not FAIL then set status based on the fail and pass counts. - (db:general-call dbstruct 'test_data-pf-rollup (list test-id test-id test-id test-id)))))) - -;; each section is a rule except "final" which is the final result -;; -;; [rule-5] -;; operator in -;; section LogFileBody -;; desc Output voltage -;; status OK -;; expected 1.9 -;; measured 1.8 -;; type +/- -;; tolerance 0.1 -;; pass 1 -;; fail 0 -;; -;; [final] -;; exit-code 6 -;; exit-status SKIP -;; message If flagged we are asking for this to exit with code 6 -;; -;; recorded in steps table: -;; category: stepname -;; variable: rule-N -;; value: measured -;; expected: expected -;; tol: tolerance -;; units: - -;; comment: desc or message -;; status: status -;; type: type -;; -(define (db:logpro-dat->csv dat stepname) - (let ((res '())) - (for-each - (lambda (entry-name) - (if (equal? entry-name "final") - (set! res (append - res - (list - (list stepname - entry-name - (configf:lookup dat entry-name "exit-code") ;; 0 ;; Value - 0 ;; 1 ;; Expected - 0 ;; 2 ;; Tolerance - "n/a" ;; 3 ;; Units - (configf:lookup dat entry-name "message") ;; 4 ;; Comment - (configf:lookup dat entry-name "exit-status") ;; 5 ;; Status - "logpro" ;; 6 ;; Type - )))) - (let* ((value (or (configf:lookup dat entry-name "measured") "n/a")) - (expected (or (configf:lookup dat entry-name "expected") 0.0)) - (tolerance (or (configf:lookup dat entry-name "tolerance") 0.0)) - (comment (or (configf:lookup dat entry-name "comment") - (configf:lookup dat entry-name "desc") "n/a")) - (status (or (configf:lookup dat entry-name "status") "n/a")) - (type (or (configf:lookup dat entry-name "expected") "n/a"))) - (set! res (append - res - (list (list stepname - entry-name - value ;; 0 - expected ;; 1 - tolerance ;; 2 - "n/a" ;; 3 Units - comment ;; 4 - status ;; 5 - type ;; 6 - ))))))) - (hash-table-keys dat)) - res)) - -;; $MT_MEGATEST -load-test-data << EOF -;; foo,bar, 1.2, 1.9, > -;; foo,rab, 1.0e9, 10e9, 1e9 -;; foo,bla, 1.2, 1.9, < -;; foo,bal, 1.2, 1.2, < , ,Check for overload -;; foo,alb, 1.2, 1.2, <= , Amps,This is the high power circuit test -;; foo,abl, 1.2, 1.3, 0.1 -;; foo,bra, 1.2, pass, silly stuff -;; faz,bar, 10, 8mA, , ,"this is a comment" -;; EOF - -(define (db:csv->test-data dbstruct run-id test-id csvdata) - (debug:print 4 *default-log-port* "test-id " test-id ", csvdata: " csvdata) - (db:with-db - dbstruct #f #f - (lambda (db) - (let* ((csvlist (csv->list (make-csv-reader - (open-input-string csvdata) - '((strip-leading-whitespace? #t) - (strip-trailing-whitespace? #t)))))) ;; (csv->list csvdata))) - (for-each - (lambda (csvrow) - (let* ((padded-row (take (append csvrow (list #f #f #f #f #f #f #f #f #f)) 9)) - (category (list-ref padded-row 0)) - (variable (list-ref padded-row 1)) - (value (any->number-if-possible (list-ref padded-row 2))) - (expected (any->number-if-possible (list-ref padded-row 3))) - (tol (any->number-if-possible (list-ref padded-row 4))) ;; >, <, >=, <=, or a number - (units (list-ref padded-row 5)) - (comment (list-ref padded-row 6)) - (status (let ((s (list-ref padded-row 7))) - (if (and (string? s)(or (string-match (regexp "^\\s*$") s) - (string-match (regexp "^n/a$") s))) - #f - s))) ;; if specified on the input then use, else calculate - (type (list-ref padded-row 8))) - ;; look up expected,tol,units from previous best fit test if they are all either #f or '' - (debug:print 4 *default-log-port* "BEFORE: category: " category " variable: " variable " value: " value - ", expected: " expected " tol: " tol " units: " units " status: " status " comment: " comment " type: " type) - - (if (and (or (not expected)(equal? expected "")) - (or (not tol) (equal? expected "")) - (or (not units) (equal? expected ""))) - (let-values (((new-expected new-tol new-units)(tdb:get-prev-tol-for-test #f test-id category variable))) - (set! expected new-expected) - (set! tol new-tol) - (set! units new-units))) - - (debug:print 4 *default-log-port* "AFTER: category: " category " variable: " variable " value: " value - ", expected: " expected " tol: " tol " units: " units " status: " status " comment: " comment) - ;; calculate status if NOT specified - (if (and (not status)(number? expected)(number? value)) ;; need expected and value to be numbers - (if (number? tol) ;; if tol is a number then we do the standard comparison - (let* ((max-val (+ expected tol)) - (min-val (- expected tol)) - (result (and (>= value min-val)(<= value max-val)))) - (debug:print 4 *default-log-port* "max-val: " max-val " min-val: " min-val " result: " result) - (set! status (if result "pass" "fail"))) - (set! status ;; NB// need to assess each one (i.e. not return operator since need to act if not valid op. - (case (string->symbol tol) ;; tol should be >, <, >=, <= - ((>) (if (> value expected) "pass" "fail")) - ((<) (if (< value expected) "pass" "fail")) - ((>=) (if (>= value expected) "pass" "fail")) - ((<=) (if (<= value expected) "pass" "fail")) - (else (conc "ERROR: bad tol comparator " tol)))))) - (debug:print 4 *default-log-port* "AFTER2: category: " category " variable: " variable " value: " value - ", expected: " expected " tol: " tol " units: " units " status: " status " comment: " comment) - ;; (db:delay-if-busy dbdat) - (sqlite3:execute db "INSERT OR REPLACE INTO test_data (test_id,category,variable,value,expected,tol,units,comment,status,type) VALUES (?,?,?,?,?,?,?,?,?,?);" - test-id category variable value expected tol units (if comment comment "") status type))) - csvlist))))) - -;; This routine moved from tdb.scm, tdb:read-test-data -;; -(define (db:read-test-data dbstruct run-id test-id categorypatt) - (let* ((res '())) - (db:with-db - dbstruct #f #f - (lambda (db) - (sqlite3:for-each-row - (lambda (id test_id category variable value expected tol units comment status type) - (set! res (cons (vector id test_id category variable value expected tol units comment status type) res))) - db - "SELECT id,test_id,category,variable,value,expected,tol,units,comment,status,type FROM test_data WHERE test_id=? AND category LIKE ? ORDER BY category,variable;" test-id categorypatt) - (reverse res))))) - -;; This routine moved from tdb.scm, :read-test-data -;; -(define (db:read-test-data* dbstruct run-id test-id categorypatt varpatt) - (let* ((res '())) - (db:with-db - dbstruct #f #f - (lambda (db) - (sqlite3:for-each-row - (lambda (id test_id category variable value expected tol units comment status type) - (set! res (cons (vector id test_id category variable value expected tol units comment status type) res))) - db - "SELECT id,test_id,category,variable,value,expected,tol,units,comment,status,type FROM test_data WHERE test_id=? AND category LIKE ? AND variable LIKE ? ORDER BY category,variable;" test-id categorypatt varpatt) - (reverse res))))) - - -;;====================================================================== -;; Misc. test related queries -;;====================================================================== - -(define (db:get-run-ids-matching-target dbstruct keynames target res runname testpatt statepatt statuspatt) - (db:with-db - dbstruct #f #f - (lambda (db) - (let* ((row-ids '()) - (keystr (string-intersperse - (map (lambda (key val) - (conc key " like '" val "'")) - keynames - (string-split target "/")) - " AND ")) - ;; (testqry (tests:match->sqlqry testpatt)) - (runsqry (sqlite3:prepare db (conc "SELECT id FROM runs WHERE " keystr " AND runname LIKE '" runname "';")))) - ;; (debug:print 8 *default-log-port* "db:test-get-paths-matching-keynames-target-new\n runsqry=" runsqry "\n tstsqry=" testqry) - (sqlite3:for-each-row - (lambda (rid) - (set! row-ids (cons rid row-ids))) - runsqry) - (sqlite3:finalize! runsqry) - row-ids)))) - -;; finds latest matching all patts for given run-id -;; -(define (db:test-get-paths-matching-keynames-target-new dbstruct run-id keynames target res testpatt statepatt statuspatt runname) - (let* ((testqry (tests:match->sqlqry testpatt)) - (tstsqry (conc "SELECT rundir FROM tests WHERE run_id=? AND " testqry " AND state LIKE '" statepatt "' AND status LIKE '" statuspatt "' ORDER BY event_time ASC;"))) - (db:with-db - dbstruct - run-id - #f - (lambda (db) - (sqlite3:for-each-row - (lambda (p) - (set! res (cons p res))) - db - tstsqry - run-id) - res)))) - -(define (db:test-toplevel-num-items dbstruct run-id testname) - (db:with-db - dbstruct - run-id - #f - (lambda (db) - (let ((res 0)) - (sqlite3:for-each-row - (lambda (num-items) - (set! res num-items)) - db - "SELECT count(id) FROM tests WHERE run_id=? AND testname=? AND item_path != '' AND state NOT IN ('DELETED');" - run-id - testname) - res)))) - -;;====================================================================== -;; QUEUE UP META, TEST STATUS AND STEPS REMOTE ACCESS -;;====================================================================== - -;; NOTE: Can remove the regex and base64 encoding for zmq -(define (db:obj->string obj #!key (transport 'http)) - (case transport - ;; ((fs) obj) - ((http fs) - (string-substitute - (regexp "=") "_" - (base64:base64-encode - (z3:encode-buffer - (with-output-to-string - (lambda ()(serialize obj))))) ;; BB: serialize - this is what causes problems between different builds of megatest communicating. serialize is sensitive to binary image of mtest. - #t)) - ((zmq nmsg)(with-output-to-string (lambda ()(serialize obj)))) - (else obj))) ;; rpc - -(define (db:string->obj msg #!key (transport 'http)) - (case transport - ;; ((fs) msg) - ((http fs) - (if (string? msg) - (with-input-from-string - (z3:decode-buffer - (base64:base64-decode - (string-substitute - (regexp "_") "=" msg #t))) - (lambda ()(deserialize))) - (begin - (debug:print-error 0 *default-log-port* "reception failed. Received \"" msg "\" but cannot translate it.") - (print-call-chain (current-error-port)) - msg))) ;; crude reply for when things go awry - ((zmq nmsg)(with-input-from-string msg (lambda ()(deserialize)))) - (else msg))) ;; rpc - -;; ; This is to be the big daddy call NOPE: Replaced by db:set-state-status-and-roll-up-items -;; ; -;; define (db:test-set-state-status dbstruct run-id test-id state status msg) -;; (let ((dbdat (db:get-db dbstruct run-id))) -;; (if (member state '("LAUNCHED" "REMOTEHOSTSTART")) -;; (db:general-call dbdat 'set-test-start-time (list test-id))) -;; ;; (if msg -;; ;; (db:general-call dbdat 'state-status-msg (list state status msg test-id)) -;; ;; (db:general-call dbdat 'state-status (list state status test-id))) -;; (db:set-state-status-and-roll-up-items dbstruct run-id test-id #f state status msg) -;; ;; process the test_data table -;; (if (and test-id state status (equal? status "AUTO")) -;; (db:test-data-rollup dbstruct run-id test-id status)) -;; (mt:process-triggers dbstruct run-id test-id state status))) - -;; state is the priority rollup of all states -;; status is the priority rollup of all completed statesfu -;; -;; if test-name is an integer work off that instead of test-name test-path -;; -(define (db:set-state-status-and-roll-up-items dbstruct run-id test-name item-path state status comment) - ;; establish info on incoming test followed by info on top level test - ;; BBnote - for mode itemwait, linkage between upstream test & matching item status is propagated to run queue in db:prereqs-not-met - - (let* ((testdat (if (number? test-name) - (db:get-test-info-by-id dbstruct run-id test-name) ;; test-name is actually a test-id - (db:get-test-info dbstruct run-id test-name item-path))) - (test-id (db:test-get-id testdat)) - (test-name (if (number? test-name) - (db:test-get-testname testdat) - test-name)) - (item-path (db:test-get-item-path testdat)) - (tl-testdat (db:get-test-info dbstruct run-id test-name "")) - (tl-test-id (if tl-testdat - (db:test-get-id tl-testdat) - #f))) - (if (member state '("LAUNCHED" "REMOTEHOSTSTART")) - (db:general-call dbstruct 'set-test-start-time (list test-id))) - (mutex-lock! *db-transaction-mutex*) - (db:with-db - dbstruct #f #f - (lambda (db) - (let ((tr-res - (sqlite3:with-transaction - db - (lambda () - ;; NB// Pass the db so it is part fo the transaction - (db:test-set-state-status db run-id test-id state status comment) ;; this call sets the item state/status - (if (not (equal? item-path "")) ;; only roll up IF incoming test is an item - (let* ((state-status-counts (db:get-all-state-status-counts-for-test dbstruct run-id test-name item-path state status)) ;; item-path is used to exclude current state/status of THIS test - (running (length (filter (lambda (x) - (member (dbr:counts-state x) *common:running-states*)) - state-status-counts))) - (bad-not-started (length (filter (lambda (x) - (and (equal? (dbr:counts-state x) "NOT_STARTED") - (not (member (dbr:counts-status x) - *common:not-started-ok-statuses*)))) - state-status-counts))) - ;; (non-completes (filter (lambda (x) - ;; (not (equal? (dbr:counts-state x) "COMPLETED"))) - ;; state-status-counts)) - (all-curr-states (common:special-sort ;; worst -> best (sort of) - (delete-duplicates - (if (not (member state *common:dont-roll-up-states*)) - (cons state (map dbr:counts-state state-status-counts)) - (map dbr:counts-state state-status-counts))) - *common:std-states* >)) - (all-curr-statuses (common:special-sort ;; worst -> best - (delete-duplicates - (if (not (member state *common:dont-roll-up-states*)) - (cons status (map dbr:counts-status state-status-counts)) - (map dbr:counts-status state-status-counts))) - *common:std-statuses* >)) - (non-completes (filter (lambda (x) - (not (member x (cons "COMPLETED" *common:dont-roll-up-states*)))) - all-curr-states)) - (preq-fails (filter (lambda (x) - (equal? x "PREQ_FAIL")) - all-curr-statuses)) - (num-non-completes (length non-completes)) - (newstate (cond - ((> running 0) "RUNNING") ;; anything running, call the situation running - ((> (length preq-fails) 0) - "NOT_STARTED") - ((> bad-not-started 0) "COMPLETED") ;; we have an ugly situation, it is completed in the sense we cannot do more. - ((> num-non-completes 0) (car non-completes)) ;; (remove (lambda (x)(equal? "COMPLETED" x)) all-curr-states))) ;; only rollup DELETED if all DELETED - (else (car all-curr-states)))) - ;; (if (> running 0) - ;; "RUNNING" - ;; (if (> bad-not-started 0) - ;; "COMPLETED" - ;; (car all-curr-states)))) - (newstatus (cond - ((> (length preq-fails) 0) - "PREQ_FAIL") - ((or (> bad-not-started 0) - (and (equal? newstate "NOT_STARTED") - (> num-non-completes 0))) - "STARTED") - (else - (car all-curr-statuses))))) - - (debug:print-info 2 *default-log-port* - "\n--> probe db:set-state-status-and-roll-up-items: " - "\n--> state-status-counts: "(map dbr:counts->alist state-status-counts) - "\n--> running: "running - "\n--> bad-not-started: "bad-not-started - "\n--> non-non-completes: "num-non-completes - "\n--> non-completes: "non-completes - "\n--> all-curr-states: "all-curr-states - "\n--> all-curr-statuses: "all-curr-statuses - "\n--> newstate "newstate - "\n--> newstatus "newstatus - "\n\n") - - ;; (print "bad-not-supported: " bad-not-support " all-curr-states: " all-curr-states " all-curr-statuses: " all-curr-states) - ;; " newstate: " newstate " newstatus: " newstatus) - ;; NB// Pass the db so it is part of the transaction - (debug:print 4 *default-log-port* "BB> tl-test-id="tl-test-id" ; "test-name":"item-path"> bad-not-started="bad-not-started" newstate="newstate" newstatus="newstatus" num-non-completes="num-non-completes" non-completes="non-completes "len(sscs)="(length state-status-counts) " state-status-counts: " - (apply conc - (map (lambda (x) - (conc - (with-output-to-string (lambda () (pp (dbr:counts->alist x)))) " | ")) - state-status-counts)) - - ); end debug:print - (if tl-test-id - (db:test-set-state-status db run-id tl-test-id newstate newstatus #f)) ;; we are still in the transaction - must access the db and not the dbstruct - )))))) - - (mutex-unlock! *db-transaction-mutex*) - (if (and test-id state status (equal? status "AUTO")) - (db:test-data-rollup dbstruct run-id test-id status)) - tr-res))))) -;; BBnote: db:get-all-state-status-counts-for-test returns dbr:counts object aggregating state and status of items of a given test, *not including rollup state/status* -(define (db:get-all-state-status-counts-for-test dbstruct run-id test-name item-path item-state-in item-status-in) - - - (let* ((test-info (db:get-test-info dbstruct run-id test-name item-path)) - (item-state (or item-state-in (db:test-get-state test-info))) - (item-status (or item-status-in (db:test-get-status test-info))) - (other-items-count-recs (db:with-db - dbstruct #f #f - (lambda (db) - (sqlite3:map-row - (lambda (state status count) - (make-dbr:counts state: state status: status count: count)) - db - ;; ignore current item because we have changed its value in the current transation so this select will see the old value. - "SELECT state,status,count(id) FROM tests WHERE run_id=? AND testname=? AND item_path != '' AND item_path !=? GROUP BY state,status;" - run-id test-name item-path)))) - - ;; add current item to tally outside of sql query - (match-countrec-lambda (lambda (countrec) - (and (equal? (dbr:counts-state countrec) item-state) - (equal? (dbr:counts-status countrec) item-status)))) - - (already-have-count-rec-list - (filter match-countrec-lambda other-items-count-recs)) ;; will have either 0 or 1 count recs depending if another item shares this item's state/status - - (updated-count-rec (if (null? already-have-count-rec-list) - (make-dbr:counts state: item-state status: item-status count: 1) - (let* ((our-count-rec (car already-have-count-rec-list)) - (new-count (add1 (dbr:counts-count our-count-rec)))) - (make-dbr:counts state: item-state status: item-status count: new-count)))) - - (nonmatch-countrec-lambda (lambda (countrec) (not (match-countrec-lambda countrec)))) - - (unrelated-rec-list - (filter nonmatch-countrec-lambda other-items-count-recs))) - - (cons updated-count-rec unrelated-rec-list))) - -;; (define (db:get-all-item-states db run-id test-name) -;; (sqlite3:map-row -;; (lambda (a) a) -;; db -;; "SELECT DISTINCT state FROM tests WHERE item_path != '' AND state != 'DELETED' AND run_id=? AND testname=?" -;; run-id test-name)) -;; -;; (define (db:get-all-item-statuses db run-id test-name) -;; (sqlite3:map-row -;; (lambda (a) a) -;; db -;; "SELECT DISTINCT status FROM tests WHERE item_path != '' AND state != 'DELETED' AND state='COMPLETED' AND run_id=? AND testname=?" -;; run-id test-name)) - -(define (db:test-get-logfile-info dbstruct run-id test-name) - (db:with-db - dbstruct - run-id - #f - (lambda (db) - (let ((res #f)) - (sqlite3:for-each-row - (lambda (path final_logf) - ;; (let ((path (sdb:qry 'getstr path-id)) - ;; (final_logf (sdb:qry 'getstr final_logf-id))) - (set! logf final_logf) - (set! res (list path final_logf)) - (if (directory? path) - (debug:print 2 *default-log-port* "Found path: " path) - (debug:print 2 *default-log-port* "No such path: " path))) ;; ) - db - "SELECT rundir,final_logf FROM tests WHERE testname=? AND item_path='' AND run_id=?;" - test-name run-id) - res)))) - -;;====================================================================== -;; A G R E G A T E D T R A N S A C T I O N D B W R I T E S -;;====================================================================== - -(define db:queries - (list '(update-run-duration "UPDATE tests SET run_duration=? WHERE id=?;") - - ;; TESTS - '(register-test "INSERT OR IGNORE INTO tests (run_id,testname,event_time,item_path,state,status) VALUES (?,?,strftime('%s','now'),?,'NOT_STARTED','n/a');") - ;; Test state and status - '(set-test-state "UPDATE tests SET state=? WHERE id=?;") - '(set-test-status "UPDATE tests SET state=? WHERE id=?;") - '(state-status "UPDATE tests SET state=?,status=? WHERE id=?;") ;; DONE - '(state-status-msg "UPDATE tests SET state=?,status=?,comment=? WHERE id=?;") ;; DONE - ;; Test comment - '(set-test-comment "UPDATE tests SET comment=? WHERE id=?;") - '(set-test-start-time "UPDATE tests SET event_time=strftime('%s','now') WHERE id=?;") ;; DONE - '(pass-fail-counts "UPDATE tests SET pass_count=?,fail_count=? WHERE id=?;") - ;; test_data-pf-rollup is used to set a tests PASS/FAIL based on the pass/fail info from the steps - '(test_data-pf-rollup "UPDATE tests - SET status=CASE WHEN (SELECT fail_count FROM tests WHERE id=?) > 0 - THEN 'FAIL' - WHEN (SELECT pass_count FROM tests WHERE id=?) > 0 AND - (SELECT status FROM tests WHERE id=?) NOT IN ('WARN','FAIL') - THEN 'PASS' - ELSE status - END WHERE id=?;") ;; DONE - '(test-set-log "UPDATE tests SET final_logf=? WHERE id=?;") ;; DONE - ;; '(test-set-rundir-by-test-id "UPDATE tests SET rundir=? WHERE id=?") ;; DONE - ;; '(test-set-rundir "UPDATE tests SET rundir=? AND testname=? AND item_path=?;") ;; DONE - '(test-set-rundir-shortdir "UPDATE tests SET rundir=?,shortdir=? WHERE testname=? AND item_path=? AND run_id=?;") ;; BROKEN!!! NEEDS run-id - '(delete-tests-in-state ;; "DELETE FROM tests WHERE state=?;") ;; DONE - "UPDATE tests SET state='DELETED' WHERE state=?") - '(tests:test-set-toplog "UPDATE tests SET final_logf=? WHERE run_id=? AND testname=? AND item_path='';") - '(update-cpuload-diskfree "UPDATE tests SET cpuload=?,diskfree=? WHERE id=?;") ;; DONE - '(update-uname-host "UPDATE tests SET uname=?,host=? WHERE id=?;") ;; DONE - '(update-test-rundat "INSERT INTO test_rundat (test_id,update_time,cpuload,diskfree,diskusage,run_duration) VALUES (?,?,?,?,?,?);") - '(update-test-state "UPDATE tests SET state=? WHERE state=? AND run_id=? AND testname=? AND NOT (item_path='' AND testname IN (SELECT DISTINCT testname FROM tests WHERE testname=? AND item_path != ''));") - '(update-test-status "UPDATE tests SET status=? WHERE status like ? AND run_id=? AND testname=? AND NOT (item_path='' AND testname IN (SELECT DISTINCT testname FROM tests WHERE testname=? AND item_path != ''));") - ;; stuff for set-state-status-and-roll-up-items - '(update-pass-fail-counts "UPDATE tests - SET fail_count=(SELECT count(id) FROM tests WHERE testname=? AND item_path != '' AND status IN ('FAIL','CHECK','INCOMPLETE','ABORT')), - pass_count=(SELECT count(id) FROM tests WHERE testname=? AND item_path != '' AND status IN ('PASS','WARN','WAIVED')) - WHERE testname=? AND item_path='' AND run_id=?;") ;; DONE ;; BROKEN!!! NEEDS run-id - '(top-test-set-running "UPDATE tests SET state='RUNNING' WHERE testname=? AND item_path='' AND run_id=?;") ;; DONE ;; BROKEN!!! NEEDS run-id - - ;; NOT USED - ;; - ;; Might be the following top-test-set-per-pf-counts query could be better based off of something like this: - ;; - ;; select state,status,count(state) from tests where run_id=59 AND testname='runfirst' group by state,status; - ;; - '(top-test-set-per-pf-counts "UPDATE tests - SET state=CASE - WHEN (SELECT count(id) FROM tests - WHERE testname=? - AND item_path != '' - AND status NOT IN ('n/a') - AND state in ('NOT_STARTED')) > 0 THEN 'UNKNOWN' - WHEN (SELECT count(id) FROM tests - WHERE testname=? - AND item_path != '' - AND (status NOT IN ('TEN_STRIKES','BLOCKED') OR status IN ('INCOMPLETE')) - AND state in ('RUNNING','NOT_STARTED','LAUNCHED','REMOTEHOSTSTART')) > 0 THEN 'RUNNING' - WHEN (SELECT count(id) FROM tests - WHERE testname=? - AND item_path != '' - AND state NOT IN ('COMPLETED','DELETED')) = 0 THEN 'COMPLETED' - WHEN (SELECT count(id) FROM tests - WHERE testname=? - AND item_path != '' - AND state = 'NOT_STARTED') > 0 THEN 'NOT_STARTED' - ELSE 'UNKNOWN' END, - status=CASE - WHEN fail_count > 0 THEN 'FAIL' - WHEN (SELECT count(id) FROM tests - WHERE testname=? - AND item_path != '' - AND state IN ('BLOCKED','INCOMPLETE')) > 0 THEN 'FAIL' - WHEN (SELECT count(id) FROM tests - WHERE testname=? - AND item_path != '' - AND state NOT IN ('DELETED') - AND status IN ('INCOMPLETE','ABORT')) > 0 THEN 'ABORT' - WHEN (SELECT count(id) FROM tests - WHERE testname=? - AND item_path != '' - AND state NOT IN ('DELETED') - AND status = 'AUTO') > 0 THEN 'AUTO' - WHEN (SELECT count(id) FROM tests - WHERE testname=? - AND item_path != '' - AND state NOT IN ('DELETED') - AND status IN ('STUCK/INCOMPLETE', 'INCOMPLETE')) > 0 THEN 'INCOMPLETE' - WHEN (SELECT count(id) FROM tests - WHERE testname=? - AND item_path != '' - AND state IN ('COMPLETED','STUCK/INCOMPLETE','INCOMPLETE') - AND status = 'FAIL') > 0 THEN 'FAIL' - WHEN (SELECT count(id) FROM tests - WHERE testname=? - AND item_path != '' - AND state NOT IN ('DELETED') - AND status = 'CHECK') > 0 THEN 'CHECK' - WHEN (SELECT count(id) FROM tests - WHERE testname=? - AND item_path != '' - AND state NOT IN ('DELETED') - AND status = 'SKIP') > 0 THEN 'SKIP' - WHEN (SELECT count(id) FROM tests - WHERE testname=? - AND item_path != '' - AND state NOT IN ('DELETED') - AND status = 'WARN') > 0 THEN 'WARN' - WHEN (SELECT count(id) FROM tests - WHERE testname=? - AND item_path != '' - AND state NOT IN ('DELETED') - AND status = 'WAIVED') > 0 THEN 'WAIVED' - WHEN (SELECT count(id) FROM tests - WHERE testname=? - AND item_path != '' - AND state NOT IN ('DELETED') - AND status NOT IN ('PASS','FAIL','WARN','WAIVED')) > 0 THEN 'ABORT' - WHEN (SELECT count(id) FROM tests - WHERE testname=? - AND item_path != '' - AND state='NOT_STARTED') > 0 THEN 'n/a' - WHEN (SELECT count(id) FROM tests - WHERE testname=? - AND item_path != '' - AND state = 'COMPLETED' - AND status = 'PASS') > 0 THEN 'PASS' - WHEN pass_count > 0 AND fail_count=0 THEN 'PASS' - ELSE 'UNKNOWN' END - WHERE testname=? AND item_path='';") ;; DONE ;; BROKEN!!! NEEDS run-id - - ;; STEPS - '(delete-test-step-records "UPDATE test_steps SET status='DELETED' WHERE test_id=?;") - '(delete-test-data-records "UPDATE test_data SET status='DELETED' WHERE test_id=?;") ;; using status since no state field - )) - -(define (db:lookup-query qry-name) - (let ((q (alist-ref qry-name db:queries))) - (if q (car q) #f))) - -;; do not run these as part of the transaction -(define db:special-queries '(rollup-tests-pass-fail - ;; db:set-state-status-and-roll-up-items ;; WHY NOT!? - login - immediate - flush - sync - set-verbosity - killserver - )) - -(define (db:login dbstruct calling-path calling-version client-signature) - (cond - ((not (equal? calling-path *toppath*)) - (list #f "Login failed due to mismatch paths: " calling-path ", " *toppath*)) - ;; ((not (equal? *run-id* run-id)) - ;; (list #f "Login failed due to mismatch run-id: " run-id ", " *run-id*)) - ((not (equal? megatest-version calling-version)) - (list #f "Login failed due to mismatch megatest version: " calling-version ", " megatest-version)) - (else - (hash-table-set! *logged-in-clients* client-signature (current-seconds)) - '(#t "successful login")))) - -(define (db:general-call dbstruct stmtname params) - (let ((query (let ((q (alist-ref (if (string? stmtname) - (string->symbol stmtname) - stmtname) - db:queries))) - (if q (car q) #f)))) - (db:with-db - dbstruct #f #f - (lambda (db) - (apply sqlite3:execute db query params) - #t)))) - -;; get a summary of state and status counts to calculate a rollup -;; -(define (db:get-state-status-summary dbstruct run-id testname) - (let ((res '())) - (db:with-db - dbstruct #f #f - (sqlite3:for-each-row - (lambda (state status count) - (set! res (cons (vector state status count) res))) - db - "SELECT state,status,count(state) FROM tests WHERE run_id=? AND testname=? AND item_path='' GROUP BY state,status;" - run-id testname) - res))) - -(define (db:get-latest-host-load dbstruct raw-hostname) - (let* ((hostname (string-substitute "\\..*$" "" raw-hostname)) - (res (cons -1 0))) - (db:with-db - dbstruct #f #f - (lambda (db) - (sqlite3:for-each-row - (lambda (cpuload update-time) (set! res (cons cpuload update-time))) - db - "SELECT tr.cpuload, tr.update_time FROM test_rundat tr, tests t WHERE t.host=? AND tr.cpuload != -1 AND tr.test_id=t.id ORDER BY tr.update_time DESC LIMIT 1;" - hostname))) res )) - -(define (db:set-top-level-from-items dbstruct run-id testname) - (let* ((summ (db:get-state-status-summary dbstruct run-id testname)) - (find (lambda (state status) - (if (null? summ) - #f - (let loop ((hed (car summ)) - (tal (cdr summ))) - (if (and (string-match state (vector-ref hed 0)) - (string-match status (vector-ref hed 1))) - hed - (if (null? tal) - #f - (loop (car tal)(cdr tal))))))))) - - - ;;; E D I T M E ! ! - - - (cond - ((> (find "COMPLETED" ".*") 0) #f)))) - - - -;; get the previous records for when these tests were run where all keys match but runname -;; NB// Merge this with test:get-previous-test-run-records? This one looks for all matching tests -;; can use wildcards. Also can likely be factored in with get test paths? -;; -;; Run this remotely!! -;; -(define (db:get-matching-previous-test-run-records dbstruct run-id test-name item-path) - (let* ((keys (db:get-keys dbstruct)) - (selstr (string-intersperse keys ",")) - (qrystr (string-intersperse (map (lambda (x)(conc x "=?")) keys) " AND ")) - (keyvals #f) - (tests-hash (make-hash-table))) - ;; first look up the key values from the run selected by run-id - (db:with-db - dbstruct #f #f - (lambda (db) - (sqlite3:for-each-row - (lambda (a . b) - (set! keyvals (cons a b))) - db - (conc "SELECT " selstr " FROM runs WHERE id=? ORDER BY event_time DESC;") run-id))) - (if (not keyvals) - '() - (let ((prev-run-ids '())) - (db:with-db - dbstruct #f #f - (lambda (db) - (apply sqlite3:for-each-row - (lambda (id) - (set! prev-run-ids (cons id prev-run-ids))) - db - (conc "SELECT id FROM runs WHERE " qrystr " AND id != ?;") (append keyvals (list run-id))))) - ;; collect all matching tests for the runs then - ;; extract the most recent test and return that. - (debug:print 4 *default-log-port* "selstr: " selstr ", qrystr: " qrystr ", keyvals: " keyvals - ", previous run ids found: " prev-run-ids) - (if (null? prev-run-ids) '() ;; no previous runs? return null - (let loop ((hed (car prev-run-ids)) - (tal (cdr prev-run-ids))) - (let ((results (db:get-tests-for-run dbstruct hed (conc test-name "/" item-path) '() '() #f #f #f #f #f #f #f 'normal))) - (debug:print 4 *default-log-port* "Got tests for run-id " run-id ", test-name " test-name - ", item-path " item-path " results: " (intersperse results "\n")) - ;; Keep only the youngest of any test/item combination - (for-each - (lambda (testdat) - (let* ((full-testname (conc (db:test-get-testname testdat) "/" (db:test-get-item-path testdat))) - (stored-test (hash-table-ref/default tests-hash full-testname #f))) - (if (or (not stored-test) - (and stored-test - (> (db:test-get-event_time testdat)(db:test-get-event_time stored-test)))) - ;; this test is younger, store it in the hash - (hash-table-set! tests-hash full-testname testdat)))) - results) - (if (null? tal) - (map cdr (hash-table->alist tests-hash)) ;; return a list of the most recent tests - (loop (car tal)(cdr tal)))))))))) - -;; Function recursively checks if .journal exists; if yes means db busy; call itself after delayed interval -;; return the sqlite3 db handle if possible -;; -(define (db:delay-if-busy dbdat #!key (count 6)) - (if (not (configf:lookup *configdat* "server" "delay-on-busy")) - (and dbdat (db:dbdat-get-db dbdat)) - (if dbdat - (let* ((dbpath (db:dbdat-get-path dbdat)) - (db (db:dbdat-get-db dbdat)) ;; we'll return this so (db:delay--if-busy can be called inline - (dbfj (conc dbpath "-journal"))) - (if (handle-exceptions - exn - (begin - (debug:print-info 0 *default-log-port* "WARNING: failed to test for existance of " dbfj) - (thread-sleep! 1) - (db:delay-if-busy count (- count 1))) - (common:file-exists? dbfj)) - (case count - ((6) - (thread-sleep! 0.2) - (db:delay-if-busy count: 5)) - ((5) - (thread-sleep! 0.4) - (db:delay-if-busy count: 4)) - ((4) - (thread-sleep! 0.8) - (db:delay-if-busy count: 3)) - ((3) - (thread-sleep! 1.6) - (db:delay-if-busy count: 2)) - ((2) - (thread-sleep! 3.2) - (db:delay-if-busy count: 1)) - ((1) - (thread-sleep! 6.4) - (db:delay-if-busy count: 0)) - (else - (debug:print-info 0 *default-log-port* "delaying db access due to high database load.") - (thread-sleep! 12.8)))) - db) - "bogus result from db:delay-if-busy"))) - -(define (db:test-get-records-for-index-file dbstruct run-id test-name) - (let ((res '())) - (db:with-db - dbstruct - run-id - #f - (lambda (db) - (sqlite3:for-each-row - (lambda (id itempath state status run_duration logf comment) - (set! res (cons (vector id itempath state status run_duration logf comment) res))) - db - "SELECT id,item_path,state,status,run_duration,final_logf,comment FROM tests WHERE testname=? AND item_path != '' AND run_id=?;" ;; BUG! WHY NO run_id? - test-name - run-id) - res)))) - -;;====================================================================== -;; Tests meta data -;;====================================================================== - -;; returns a hash table of tags to tests -;; -(define (db:get-tests-tags dbstruct) - (db:with-db - dbstruct #f #f - (lambda (db) - (let* ((res (make-hash-table))) - (sqlite3:for-each-row - (lambda (testname tags-in) - (let ((tags (string-split tags-in ","))) - (for-each - (lambda (tag) - (hash-table-set! res tag - (delete-duplicates - (cons testname (hash-table-ref/default res tag '()))))) - tags))) - db - "SELECT testname,tags FROM test_meta") - (hash-table->alist res))))) - -;; read the record given a testname -(define (db:testmeta-get-record dbstruct testname) - (let ((res #f)) - (db:with-db - dbstruct - #f - #f - (lambda (db) - (sqlite3:for-each-row - (lambda (id testname author owner description reviewed iterated avg_runtime avg_disk tags jobgroup) - (set! res (vector id testname author owner description reviewed iterated avg_runtime avg_disk tags jobgroup))) - db - "SELECT id,testname,author,owner,description,reviewed,iterated,avg_runtime,avg_disk,tags,jobgroup FROM test_meta WHERE testname=?;" - testname) - res)))) - -;; create a new record for a given testname -(define (db:testmeta-add-record dbstruct testname) - (db:with-db dbstruct #f #f - (lambda (db) - (sqlite3:execute - db - "INSERT OR IGNORE INTO test_meta (testname,author,owner,description,reviewed,iterated,avg_runtime,avg_disk,tags) VALUES (?,'','','','','','','','');" testname)))) - -;; update one of the testmeta fields -(define (db:testmeta-update-field dbstruct testname field value) - (db:with-db dbstruct #f #f - (lambda (db) - (sqlite3:execute - db - (conc "UPDATE test_meta SET " field "=? WHERE testname=?;") value testname)))) - -(define (db:testmeta-get-all dbstruct) - (db:with-db dbstruct #f #f - (lambda (db) - (let ((res '())) - (sqlite3:for-each-row - (lambda (a . b) - (set! res (cons (apply vector a b) res))) - db - "SELECT id,testname,author,owner,description,reviewed,iterated,avg_runtime,avg_disk,tags,jobgroup FROM test_meta;") - res)))) - -;;====================================================================== -;; M I S C M A N A G E M E N T I T E M S -;;====================================================================== - -;; A routine to map itempaths using a itemmap -;; patha and pathb must be strings or this will fail -;; -;; path-b is waiting on path-a -;; -(define (db:compare-itempaths test-b-name path-a path-b itemmaps ) - (debug:print-info 6 *default-log-port* "ITEMMAPS: " itemmaps) - (let* ((itemmap (tests:lookup-itemmap itemmaps test-b-name))) - (if itemmap - (let ((path-b-mapped (db:multi-pattern-apply path-b itemmap))) - (debug:print-info 6 *default-log-port* "ITEMMAP is " itemmap ", path: " path-b ", mapped path: " path-b-mapped) - (equal? path-a path-b-mapped)) - (equal? path-b path-a)))) - -;; A routine to convert test/itempath using a itemmap -;; NOTE: to process only an itempath (i.e. no prepended testname) -;; just call db:multi-pattern-apply -;; -(define (db:convert-test-itempath path-in itemmap) - (debug:print-info 6 *default-log-port* "ITEMMAP is " itemmap) - (let* ((path-parts (string-split path-in "/")) - (test-name (if (null? path-parts) "" (car path-parts))) - (item-path (string-intersperse (if (null? path-parts) '() (cdr path-parts)) "/"))) - (conc test-name "/" - (db:multi-pattern-apply item-path itemmap)))) - -;; patterns are: -;; "rx1" "replacement1"\n -;; "rx2" "replacement2" -;; etc. -;; -(define (db:multi-pattern-apply item-path itemmap) - (let ((all-patts (string-split itemmap "\n"))) - (if (null? all-patts) - item-path - (let loop ((hed (car all-patts)) - (tal (cdr all-patts)) - (res item-path)) - (let* ((parts (string-split hed)) - (patt (car parts)) - - (repl (if (> (length parts) 1)(cadr parts) "")) - - (newr (if (and patt repl) - (begin - (handle-exceptions - exn - (begin - (debug:print 0 *default-log-port* - "WARNING: itemmap has problem \"" itemmap "\", patt: " patt ", repl: " repl) - res) - (string-substitute patt repl res)) - - - ) - (begin - (debug:print 0 *default-log-port* - "WARNING: itemmap has problem \"" itemmap "\", patt: " patt ", repl: " repl) - res)))) - (if (null? tal) - newr - (loop (car tal)(cdr tal) newr))))))) - - - - -;; the new prereqs calculation, looks also at itempath if specified -;; all prereqs must be met -;; if prereq test with itempath='' is COMPLETED and PASS, WARN, CHECK, or WAIVED then prereq is met -;; if prereq test with itempath=ref-item-path and COMPLETED with PASS, WARN, CHECK, or WAIVED then prereq is met -;; -;; Note: mode 'normal means that tests must be COMPLETED and ok (i.e. PASS, WARN, CHECK, SKIP or WAIVED) -;; mode 'toplevel means that tests must be COMPLETED only -;; mode 'itemmatch or 'itemwait means that tests items must be COMPLETED and (PASS|WARN|WAIVED|CHECK) [[ NB// NOT IMPLEMENTED YET ]] -;; mode 'exclusive means this test/item cannot run if the same test/item is LAUNCHED,REMOTEHOSTSTART or RUNNING -;; -;; IDEA for consideration: -;; 1. collect all tests "upstream" -;; 2. any NOT completed and good? if yes => return those as prereqs not met, if no => return null list -;; -;; (define (db:get-prereqs-not-met dbstruct run-id waitons ref-item-path mode) -(define (db:get-prereqs-not-met dbstruct run-id waitons ref-test-name ref-item-path mode itemmaps) ;; #!key (mode '(normal))(itemmap #f)) - ;; BBnote - rollup of an itemized test's overall state/status done in db:set-state-status-and-roll-up-items - (append - (if (member 'exclusive mode) - (let ((running-tests (db:get-tests-for-run dbstruct - #f ;; run-id of #f means for all runs. - (if (string=? ref-item-path "") ;; testpatt - ref-test-name - (conc ref-test-name "/" ref-item-path)) - '("LAUNCHED" "REMOTEHOSTSTART" "RUNNING") ;; states - '() ;; statuses - #f ;; offset - #f ;; limit - #f ;; not-in - #f ;; sort by - #f ;; sort order - 'shortlist ;; query type - 0 ;; last update, beginning of time .... - #f ;; mode - ))) - ;;(map (lambda (testdat) - ;; (if (equal? (db:test-get-item-path testdat) "") - ;; (db:test-get-testname testdat) - ;; (conc (db:test-get-testname testdat) - ;; "/" - ;; (db:test-get-item-path testdat)))) - running-tests) ;; calling functions want the entire data - '()) - - ;; collection of: for each waiton - - ;; if this ref-test-name is an item in an itemized test and mode is itemwait/itemmatch: - ;; if waiton is not itemized - if waiton is not both completed and in ok status, add as unmet prerequisite - ;; if waiton is itemized: - ;; and waiton's items are not expanded, add as unmet prerequisite - ;; else if matching waiton item is not both completed and in an ok status, add as unmet prerequisite - ;; else - ;; if waiton toplevel is not in both completed and ok status, add as unmet prerequisite - - (if (or (not waitons) - (null? waitons)) - '() - (let* ((ref-test-itemized-mode (not (null? (lset-intersection eq? mode '(itemmatch itemwait))))) ;; how is this different from using member? - (ref-test-toplevel-mode (not (null? (lset-intersection eq? mode '(toplevel))))) - (ref-test-is-toplevel (equal? ref-item-path "")) - (ref-test-is-item (not ref-test-is-toplevel)) - (unmet-pre-reqs '()) - (result '()) - (unmet-prereq-items '()) - ) - (for-each ; waitons - (lambda (waitontest-name) - ;; by getting the tests with matching name we are looking only at the matching test - ;; and related sub items - ;; next should be using mt:get-tests-for-run? - - (let (;(waiton-is-itemized ...) - ;(waiton-items-are-expanded ...) - (waiton-tests (db:get-tests-for-run-state-status dbstruct run-id waitontest-name)) - (ever-seen #f) - (parent-waiton-met #f) - (item-waiton-met #f) - - ) - (for-each ; test expanded from waiton - (lambda (waiton-test) - (let* ((waiton-state (db:test-get-state waiton-test)) - (waiton-status (db:test-get-status waiton-test)) - (waiton-item-path (db:test-get-item-path waiton-test)) ;; BB- this is the upstream itempath - (waiton-test-name (db:test-get-testname waiton-test)) - (waiton-is-toplevel (equal? waiton-item-path "")) - (waiton-is-item (not waiton-is-toplevel)) - (waiton-is-completed (member waiton-state *common:ended-states*)) - (waiton-is-running (member waiton-state *common:running-states*)) - (waiton-is-killed (member waiton-state *common:badly-ended-states*)) - (waiton-is-ok (member waiton-status *common:well-ended-states*)) - ;; testname-b path-a path-b - (same-itempath (db:compare-itempaths ref-test-name waiton-item-path ref-item-path itemmaps)) ;; (equal? ref-item-path waiton-item-path))) - (real-ref-test-name (car (string-split ref-test-name "/"))) ;; I THINK ref-test-name SHOULD NEVER HAVE THE ITEM_PATH! - (test-and-ref-are-same (equal? real-ref-test-name waiton-test-name))) - (debug:print 4 *default-log-port* "waiton-test-name " waiton-test-name " ref-test-name: " ref-test-name " test-and-ref-are-same: " test-and-ref-are-same) - (set! ever-seen #t) - ;;(BB> "***consider waiton "waiton-test"/"waiton-item-path"***") - (cond - ;; case 0 - toplevel of an itemized test, at least one item in prereq has completed - ((and waiton-is-item ref-test-is-toplevel ref-test-itemized-mode waiton-is-completed) - (set! parent-waiton-met #t)) - - ;; case 1, non-item (parent test) is - ((and waiton-is-toplevel ;; this is the parent test of the waiton being examined - waiton-is-completed - ;;(BB> "cond1") - (or waiton-is-ok ref-test-toplevel-mode)) ;; itemmatch itemwait)))))) - (set! parent-waiton-met #t)) - ;; Special case for toplevel and KILLED - ((and waiton-is-toplevel ;; this is the parent test - waiton-is-killed - (member 'toplevel mode)) - ;;(BB> "cond2") - (set! parent-waiton-met #t)) - ;; For itemwait mode IFF the previous matching item is good the set parent-waiton-met - ((and ref-test-itemized-mode ref-test-is-item same-itempath) - ;;(BB> "cond3") - (if (and waiton-is-completed (or waiton-is-ok ref-test-toplevel-mode)) - (set! item-waiton-met #t) - (set! unmet-prereq-items (cons waiton-test unmet-prereq-items))) - (if (and waiton-is-toplevel ;; if upstream rollup test is completed, parent-waiton-met is set - (or waiton-is-completed waiton-is-running)) - (set! parent-waiton-met #t))) - ;; normal checking of parent items, any parent or parent item not ok blocks running - ((and waiton-is-completed - (or waiton-is-ok - (member 'toplevel mode)) ;; toplevel does not block on FAIL - (and waiton-is-ok (member 'itemmatch mode) ;; itemmatch blocks on not ok ;; TODO: THIS IS PROBABLY A BUG. ITEMMATCH AND ITEMWAIT ARE SYNONYMS!! WHAT HAPPENED OT ITEMWAIT??? - )) - ;;(BB> "cond4") - (set! item-waiton-met #t)) - ((and waiton-is-completed waiton-is-ok same-itempath) - ;;(BB> "cond5") - (set! item-waiton-met #t)) - ((and waiton-is-completed waiton-is-ok test-and-ref-are-same) ;; probably from [waitons] table - (set! item-waiton-met #t)) - (else - #t - ;;(BB> "condelse") - )))) - waiton-tests) - ;; both requirements, parent and item-waiton must be met to NOT add item to - ;; prereq's not met list - ;; (BB> - ;; "\n* waiton-tests "waiton-tests - ;; "\n* parent-waiton-met "parent-waiton-met - ;; "\n* item-waiton-met "item-waiton-met - ;; "\n* ever-seen "ever-seen - ;; "\n* ref-test-itemized-mode "ref-test-itemized-mode - ;; "\n* unmet-prereq-items "unmet-prereq-items - ;; "\n* result (pre) "result - ;; "\n* ever-seen "ever-seen - ;; "\n") - - (cond - ((and ref-test-itemized-mode ref-test-is-item (not (null? unmet-prereq-items))) - (set! result (append unmet-prereq-items result))) - ((not (or parent-waiton-met item-waiton-met)) - (set! result (append (if (null? waiton-tests) (list waitontest-name) waiton-tests) result))) ;; appends the string if the full record is not available - ;; if the test is not found then clearly the waiton is not met... - ;; (if (not ever-seen)(set! result (cons waitontest-name result))))) - ((not ever-seen) - (set! result (append (if (null? waiton-tests)(list waitontest-name) waiton-tests) result)))))) - waitons) - (delete-duplicates result))))) -;;====================================================================== -;; To sync individual run -;;====================================================================== -(define (db:get-run-record-ids dbstruct target run keynames test-patt) -(let ((backcons (lambda (lst item)(cons item lst)))) - (db:with-db - dbstruct #f #f - (lambda (db) - (let* ((keystr (string-intersperse - (map (lambda (key val) - (conc key " like '" val "'")) - keynames - (string-split target "/")) - " AND ")) - (run-qry (conc "SELECT id FROM runs WHERE " keystr " and runname='" run"'")) - (test-qry (conc "SELECT id FROM tests WHERE run_id in (" run-qry ") and testname like '" test-patt "'"))) - ;(print run-qry) - `((runs . ,(fold-row backcons '() db run-qry)) - (tests . ,(fold-row backcons '() db test-qry)) - (test_steps . ,(fold-row backcons '() db (conc "SELECT id FROM test_steps WHERE test_id in (" test-qry ")"))) - (test_data . ,(fold-row backcons '() db (conc "SELECT id FROM test_data WHERE test_id in (" test-qry ")" ))) - )))))) - -;;====================================================================== -;; Just for sync, procedures to make sync easy -;;====================================================================== - -;; get an alist of record ids changed since time since-time -;; '((runs . (1 2 3 ...))(steps . (5 6 7 ...) ...)) -;; -(define (db:get-changed-record-ids dbstruct since-time) - ;; no transaction, allow the db to be accessed between the big queries - (let ((backcons (lambda (lst item)(cons item lst)))) - (db:with-db - dbstruct #f #f - (lambda (db) - `((runs . ,(fold-row backcons '() db "SELECT id FROM runs WHERE last_update>=?" since-time)) - (tests . ,(fold-row backcons '() db "SELECT id FROM tests WHERE last_update>=?" since-time)) - (test_steps . ,(fold-row backcons '() db "SELECT id FROM test_steps WHERE last_update>=?" since-time)) - (test_data . ,(fold-row backcons '() db "SELECT id FROM test_data WHERE last_update>=?" since-time)) - ;; (test_meta . ,(fold-row backcons '() db "SELECT id FROM test_meta WHERE last_update>?" since-time)) - (run_stats . ,(fold-row backcons '() db "SELECT id FROM run_stats WHERE last_update>=?" since-time)) - ))))) - -;;====================================================================== -;; Extract ods file from the db -;;====================================================================== - -;; NOT REWRITTEN YET!!!!! - -;; runspatt is a comma delimited list of run patterns -;; keypatt-alist must contain *all* keys with an associated pattern: '( ("KEY1" "%") .. ) -(define (db:extract-ods-file dbstruct outputfile keypatt-alist runspatt pathmod) - (let* ((keysstr (string-intersperse (map car keypatt-alist) ",")) - (keyqry (string-intersperse (map (lambda (p)(conc (car p) " LIKE ? ")) keypatt-alist) " AND ")) - (numkeys (length keypatt-alist)) - (test-ids '()) - (dbdat (db:get-db dbstruct)) - (db (db:dbdat-get-db dbdat)) - (windows (and pathmod (substring-index "\\" pathmod))) - (tempdir (conc "/tmp/" (current-user-name) "/" runspatt "_" (random 10000) "_" (current-process-id))) - (runsheader (append (list "Run Id" "Runname") ; 0 1 - (map car keypatt-alist) ; + N = length keypatt-alist - (list "Testname" ; 2 - "Item Path" ; 3 - "Description" ; 4 - "State" ; 5 - "Status" ; 6 - "Final Log" ; 7 - "Run Duration" ; 8 - "When Run" ; 9 - "Tags" ; 10 - "Run Owner" ; 11 - "Comment" ; 12 - "Author" ; 13 - "Test Owner" ; 14 - "Reviewed" ; 15 - "Diskfree" ; 16 - "Uname" ; 17 - "Rundir" ; 18 - "Host" ; 19 - "Cpu Load" ; 20 - ))) - (results (list runsheader)) - (testdata-header (list "Run Id" "Testname" "Item Path" "Category" "Variable" "Value" "Expected" "Tol" "Units" "Status" "Comment")) - (mainqry (conc "SELECT - t.testname,r.id,runname," keysstr ",t.testname, - t.item_path,tm.description,t.state,t.status, - final_logf,run_duration, - strftime('%m/%d/%Y %H:%M:%S',datetime(t.event_time,'unixepoch'),'localtime'), - tm.tags,r.owner,t.comment, - author, - tm.owner,reviewed, - diskfree,uname,rundir, - host,cpuload - FROM tests AS t JOIN runs AS r ON t.run_id=r.id JOIN test_meta AS tm ON tm.testname=t.testname - WHERE runname LIKE ? AND " keyqry ";"))) - (debug:print 2 *default-log-port* "Using " tempdir " for constructing the ods file. keyqry: " keyqry " keystr: " keysstr " with keys: " (map cadr keypatt-alist) - "\n mainqry: " mainqry) - ;; "Expected Value" - ;; "Value Found" - ;; "Tolerance" - (apply sqlite3:for-each-row - (lambda (test-id . b) - (set! test-ids (cons test-id test-ids)) ;; test-id is now testname - (set! results (append results ;; note, drop the test-id - (list - (if pathmod - (let* ((vb (apply vector b)) - (keyvals (let loop ((i 0) - (res '())) - (if (>= i numkeys) - res - (loop (+ i 1) - (append res (list (vector-ref vb (+ i 2)))))))) - (runname (vector-ref vb 1)) - (testname (vector-ref vb (+ 2 numkeys))) - (item-path (vector-ref vb (+ 3 numkeys))) - (final-log (vector-ref vb (+ 7 numkeys))) - (run-dir (vector-ref vb (+ 18 numkeys))) - (log-fpath (conc run-dir "/" final-log))) ;; (string-intersperse keyvals "/") "/" testname "/" item-path "/" - (debug:print 4 *default-log-port* "log: " log-fpath " exists: " (common:file-exists? log-fpath)) - (vector-set! vb (+ 7 numkeys) (if (common:file-exists? log-fpath) - (let ((newpath (conc pathmod "/" - (string-intersperse keyvals "/") - "/" runname "/" testname "/" - (if (string=? item-path "") "" (conc "/" item-path)) - final-log))) - ;; for now throw away newpath and use the log-fpath conc'd with pathmod - (set! newpath (conc pathmod log-fpath)) - (if windows (string-translate newpath "/" "\\") newpath)) - (if (debug:debug-mode 1) - (conc final-log " not-found") - ""))) - (vector->list vb)) - b))))) - db - mainqry - runspatt (map cadr keypatt-alist)) - (debug:print 2 *default-log-port* "Found " (length test-ids) " records") - (set! results (list (cons "Runs" results))) - ;; now, for each test, collect the test_data info and add a new sheet - (for-each - (lambda (test-id) - (let ((test-data (list testdata-header)) - (curr-test-name #f)) - (sqlite3:for-each-row - (lambda (run-id testname item-path category variable value expected tol units status comment) - (set! curr-test-name testname) - (set! test-data (append test-data (list (list run-id testname item-path category variable value expected tol units status comment))))) - db - ;; "SELECT run_id,testname,item_path,category,variable,td.value AS value,expected,tol,units,td.status AS status,td.comment AS comment FROM test_data AS td INNER JOIN tests ON tests.id=td.test_id WHERE test_id=?;" - "SELECT run_id,testname,item_path,category,variable,td.value AS value,td.expected,td.tol,td.units,td.status AS status,td.comment AS comment FROM test_data AS td INNER JOIN tests ON tests.id=td.test_id WHERE testname=?;" - test-id) - (if curr-test-name - (set! results (append results (list (cons curr-test-name test-data))))) - )) - (sort (delete-duplicates test-ids) string<=)) - (system (conc "mkdir -p " tempdir)) - ;; (pp results) - (ods:list->ods - tempdir - (if (string-match (regexp "^[/~]+.*") outputfile) ;; full path? - outputfile - (begin - (debug:print 0 *default-log-port* "WARNING: path given, " outputfile " is relative, prefixing with current directory") - (conc (current-directory) "/" outputfile))) - results) - ;; brutal clean up - (stack-push! (dbr:dbstruct-dbstack dbstruct) dbdat) - (system "rm -rf tempdir"))) - -;; (db:extract-ods-file db "outputfile.ods" '(("sysname" "%")("fsname" "%")("datapath" "%")) "%") - - + db) + +(define (db:general-sqlite-error-dump . args) + #t + (print "Got here: db:general-sqlite-error-dump")) +(define (db:first-result-default . args) + #t + (print "Got here: db:first-result-default")) +(define (db:get-db . args) + #t + (print "Got here: db:get-db")) +(define (db:dbdat-get-db . args) + #t + (print "Got here: db:dbdat-get-db")) +(define (db:dbdat-get-path . args) + #t + (print "Got here: db:dbdat-get-path")) +(define (db:with-db . args) + #t + (print "Got here: db:with-db")) +(define (db:set-sync . args) + #t + (print "Got here: db:set-sync")) +(define (db:lock-create-open . args) + #t + (print "Got here: db:lock-create-open")) +(define (db:open-db . args) + #t + (print "Got here: db:open-db")) +(define (db:get-last-update-time . args) + #t + (print "Got here: db:get-last-update-time")) +(define (db:setup . args) + #t + (print "Got here: db:setup")) +(define (db:open-megatest-db . args) + #t + (print "Got here: db:open-megatest-db")) +(define (db:sync-touched . args) + #t + (print "Got here: db:sync-touched")) +(define (db:safely-close-sqlite3-db . args) + #t + (print "Got here: db:safely-close-sqlite3-db")) +(define (db:close-all . args) + #t + (print "Got here: db:close-all")) +(define (db:sync-main-list . args) + #t + (print "Got here: db:sync-main-list")) +(define (db:sync-all-tables-list . args) + #t + (print "Got here: db:sync-all-tables-list")) +(define (db:move-and-recreate-db . args) + #t + (print "Got here: db:move-and-recreate-db")) +(define (db:repair-db . args) + #t + (print "Got here: db:repair-db")) +(define (db:sync-tables . args) + #t + (print "Got here: db:sync-tables")) +(define (db:patch-schema-rundb . args) + #t + (print "Got here: db:patch-schema-rundb")) +(define (db:patch-schema-maindb . args) + #t + (print "Got here: db:patch-schema-maindb")) +(define (db:adj-target . args) + #t + (print "Got here: db:adj-target")) +(define (db:get-access-mode . args) + #t + (print "Got here: db:get-access-mode")) +(define (db:dispatch-query . args) + #t + (print "Got here: db:dispatch-query")) +(define (db:cache-for-read-only . args) + #t + (print "Got here: db:cache-for-read-only")) +(define (db:multi-db-sync . args) + #t + (print "Got here: db:multi-db-sync")) +(define (db:tmp->megatest.db-sync . args) + #t + (print "Got here: db:tmp->megatest.db-sync")) +(define (db:sync-to-megatest.db . args) + #t + (print "Got here: db:sync-to-megatest.db")) +(define (open-run-close-no-exception-handling . args) + #t + (print "Got here: open-run-close-no-exception-handling")) +(define (open-run-close-exception-handling . args) + #t + (print "Got here: open-run-close-exception-handling")) +(define (db:initialize-main-db . args) + #t + (print "Got here: db:initialize-main-db")) +(define (db:archive-get-allocations . args) + #t + (print "Got here: db:archive-get-allocations")) +(define (db:archive-register-disk . args) + #t + (print "Got here: db:archive-register-disk")) +(define (db:archive-register-block-name . args) + #t + (print "Got here: db:archive-register-block-name")) +(define (db:test-set-archive-block-id . args) + #t + (print "Got here: db:test-set-archive-block-id")) +(define (db:test-get-archive-block-info . args) + #t + (print "Got here: db:test-get-archive-block-info")) +(define (open-logging-db . args) + #t + (print "Got here: open-logging-db")) +(define (db:log-local-event . args) + #t + (print "Got here: db:log-local-event")) +(define (db:log-event . args) + #t + (print "Got here: db:log-event")) +(define (db:have-incompletes? . args) + #t + (print "Got here: db:have-incompletes?")) +(define (db:find-and-mark-incomplete . args) + #t + (print "Got here: db:find-and-mark-incomplete")) +(define (db:top-test-set-per-pf-counts . args) + #t + (print "Got here: db:top-test-set-per-pf-counts")) +(define (db:clean-up . args) + #t + (print "Got here: db:clean-up")) +(define (db:clean-up-rundb . args) + #t + (print "Got here: db:clean-up-rundb")) +(define (db:clean-up-maindb . args) + #t + (print "Got here: db:clean-up-maindb")) +(define (db:get-var . args) + #t + (print "Got here: db:get-var")) +(define (db:set-var . args) + #t + (print "Got here: db:set-var")) +(define (db:del-var . args) + #t + (print "Got here: db:del-var")) +(define (db:open-no-sync-db . args) + #t + (print "Got here: db:open-no-sync-db")) +(define (db:no-sync-db . args) + #t + (print "Got here: db:no-sync-db")) +(define (db:no-sync-set . args) + #t + (print "Got here: db:no-sync-set")) +(define (db:no-sync-del! . args) + #t + (print "Got here: db:no-sync-del!")) +(define (db:no-sync-get/default . args) + #t + (print "Got here: db:no-sync-get/default")) +(define (db:no-sync-close-db . args) + #t + (print "Got here: db:no-sync-close-db")) +(define (db:no-sync-get-lock . args) + #t + (print "Got here: db:no-sync-get-lock")) +(define (db:get-keys . args) + #t + (print "Got here: db:get-keys")) +(define (db:get-value-by-header . args) + #t + (print "Got here: db:get-value-by-header")) +(define (db:get-header . args) + #t + (print "Got here: db:get-header")) +(define (db:get-rows . args) + #t + (print "Got here: db:get-rows")) +(define (db:get-run-times . args) + #t + (print "Got here: db:get-run-times")) +(define (db:get-run-name-from-id . args) + #t + (print "Got here: db:get-run-name-from-id")) +(define (db:get-run-key-val . args) + #t + (print "Got here: db:get-run-key-val")) +(define (runs:get-std-run-fields . args) + #t + (print "Got here: runs:get-std-run-fields")) +(define (db:patt->like . args) + #t + (print "Got here: db:patt->like")) +(define (db:register-run . args) + #t + (print "Got here: db:register-run")) +(define (db:get-runs . args) + #t + (print "Got here: db:get-runs")) +(define (db:simple-get-runs . args) + #t + (print "Got here: db:simple-get-runs")) +(define (db:get-changed-run-ids . args) + #t + (print "Got here: db:get-changed-run-ids")) +(define (db:get-targets . args) + #t + (print "Got here: db:get-targets")) +(define (db:get-num-runs . args) + #t + (print "Got here: db:get-num-runs")) +(define (db:get-runs-cnt-by-patt . args) + #t + (print "Got here: db:get-runs-cnt-by-patt")) +(define (db:get-raw-run-stats . args) + #t + (print "Got here: db:get-raw-run-stats")) +(define (db:update-run-stats . args) + #t + (print "Got here: db:update-run-stats")) +(define (db:get-main-run-stats . args) + #t + (print "Got here: db:get-main-run-stats")) +(define (db:print-current-query-stats . args) + #t + (print "Got here: db:print-current-query-stats")) +(define (db:get-all-run-ids . args) + #t + (print "Got here: db:get-all-run-ids")) +(define (db:get-run-stats . args) + #t + (print "Got here: db:get-run-stats")) +(define (db:get-runs-by-patt . args) + #t + (print "Got here: db:get-runs-by-patt")) +(define (db:get-run-info . args) + #t + (print "Got here: db:get-run-info")) +(define (db:set-comment-for-run . args) + #t + (print "Got here: db:set-comment-for-run")) +(define (db:delete-run . args) + #t + (print "Got here: db:delete-run")) +(define (db:update-run-event_time . args) + #t + (print "Got here: db:update-run-event_time")) +(define (db:lock/unlock-run . args) + #t + (print "Got here: db:lock/unlock-run")) +(define (db:set-run-status . args) + #t + (print "Got here: db:set-run-status")) +(define (db:get-run-status . args) + #t + (print "Got here: db:get-run-status")) +(define (db:get-key-val-pairs . args) + #t + (print "Got here: db:get-key-val-pairs")) +(define (db:get-key-vals . args) + #t + (print "Got here: db:get-key-vals")) +(define (db:get-target . args) + #t + (print "Got here: db:get-target")) +(define (db:get-prev-run-ids . args) + #t + (print "Got here: db:get-prev-run-ids")) +(define (db:get-tests-for-run . args) + #t + (print "Got here: db:get-tests-for-run")) +(define (db:test-short-record->norm . args) + #t + (print "Got here: db:test-short-record->norm")) +(define (db:get-tests-for-run-state-status . args) + #t + (print "Got here: db:get-tests-for-run-state-status")) +(define (db:get-testinfo-state-status . args) + #t + (print "Got here: db:get-testinfo-state-status")) +(define (db:get-tests-for-run-mindata . args) + #t + (print "Got here: db:get-tests-for-run-mindata")) +(define (db:get-tests-for-runs . args) + #t + (print "Got here: db:get-tests-for-runs")) +(define (db:delete-test-records . args) + #t + (print "Got here: db:delete-test-records")) +(define (db:delete-old-deleted-test-records . args) + #t + (print "Got here: db:delete-old-deleted-test-records")) +(define (db:set-tests-state-status . args) + #t + (print "Got here: db:set-tests-state-status")) +(define (db:test-set-state-status . args) + #t + (print "Got here: db:test-set-state-status")) +(define (db:get-count-tests-running . args) + #t + (print "Got here: db:get-count-tests-running")) +(define (db:get-count-tests-actually-running . args) + #t + (print "Got here: db:get-count-tests-actually-running")) +(define (db:get-count-tests-running-for-run-id . args) + #t + (print "Got here: db:get-count-tests-running-for-run-id")) +(define (db:get-count-tests-running-for-testname . args) + #t + (print "Got here: db:get-count-tests-running-for-testname")) +(define (db:get-count-tests-running-in-jobgroup . args) + #t + (print "Got here: db:get-count-tests-running-in-jobgroup")) +(define (db:estimated-tests-remaining . args) + #t + (print "Got here: db:estimated-tests-remaining")) +(define (db:get-test-id . args) + #t + (print "Got here: db:get-test-id")) +(define (db:test-set-top-process-pid . args) + #t + (print "Got here: db:test-set-top-process-pid")) +(define (db:test-get-top-process-pid . args) + #t + (print "Got here: db:test-get-top-process-pid")) +(define (db:field->number . args) + #t + (print "Got here: db:field->number")) +(define (db:get-all-tests-info-by-run-id . args) + #t + (print "Got here: db:get-all-tests-info-by-run-id")) +(define (db:replace-test-records . args) + #t + (print "Got here: db:replace-test-records")) +(define (db:adj-test-id . args) + #t + (print "Got here: db:adj-test-id")) +(define (db:prep-megatest.db-adj-test-ids . args) + #t + (print "Got here: db:prep-megatest.db-adj-test-ids")) +(define (db:prep-megatest.db-for-migration . args) + #t + (print "Got here: db:prep-megatest.db-for-migration")) +(define (db:get-test-info-by-id . args) + #t + (print "Got here: db:get-test-info-by-id")) +(define (db:get-test-info-by-ids . args) + #t + (print "Got here: db:get-test-info-by-ids")) +(define (db:get-test-info . args) + #t + (print "Got here: db:get-test-info")) +(define (db:test-get-rundir-from-test-id . args) + #t + (print "Got here: db:test-get-rundir-from-test-id")) +(define (db:get-test-times . args) + #t + (print "Got here: db:get-test-times")) +(define (db:get-test-times . args) + #t + (print "Got here: db:get-test-times")) +(define (db:teststep-set-status! . args) + #t + (print "Got here: db:teststep-set-status!")) +(define (db:get-steps-for-test . args) + #t + (print "Got here: db:get-steps-for-test")) +(define (db:get-steps-info-by-id . args) + #t + (print "Got here: db:get-steps-info-by-id")) +(define (db:get-steps-data . args) + #t + (print "Got here: db:get-steps-data")) +(define (db:get-data-info-by-id . args) + #t + (print "Got here: db:get-data-info-by-id")) +(define (db:test-data-rollup . args) + #t + (print "Got here: db:test-data-rollup")) +(define (db:logpro-dat->csv . args) + #t + (print "Got here: db:logpro-dat->csv")) +(define (db:csv->test-data . args) + #t + (print "Got here: db:csv->test-data")) +(define (db:read-test-data . args) + #t + (print "Got here: db:read-test-data")) +(define (db:read-test-data* . args) + #t + (print "Got here: db:read-test-data*")) +(define (db:get-run-ids-matching-target . args) + #t + (print "Got here: db:get-run-ids-matching-target")) +(define (db:test-get-paths-matching-keynames-target-new . args) + #t + (print "Got here: db:test-get-paths-matching-keynames-target-new")) +(define (db:test-toplevel-num-items . args) + #t + (print "Got here: db:test-toplevel-num-items")) +(define (db:obj->string . args) + #t + (print "Got here: db:obj->string")) +(define (db:string->obj . args) + #t + (print "Got here: db:string->obj")) +(define (db:set-state-status-and-roll-up-items . args) + #t + (print "Got here: db:set-state-status-and-roll-up-items")) +(define (db:get-all-state-status-counts-for-test . args) + #t + (print "Got here: db:get-all-state-status-counts-for-test")) +(define (db:test-get-logfile-info . args) + #t + (print "Got here: db:test-get-logfile-info")) +(define (db:lookup-query . args) + #t + (print "Got here: db:lookup-query")) +(define (db:login . args) + #t + (print "Got here: db:login")) +(define (db:general-call . args) + #t + (print "Got here: db:general-call")) +(define (db:get-state-status-summary . args) + #t + (print "Got here: db:get-state-status-summary")) +(define (db:get-latest-host-load . args) + #t + (print "Got here: db:get-latest-host-load")) +(define (db:set-top-level-from-items . args) + #t + (print "Got here: db:set-top-level-from-items")) +(define (db:get-matching-previous-test-run-records . args) + #t + (print "Got here: db:get-matching-previous-test-run-records")) +(define (db:delay-if-busy . args) + #t + (print "Got here: db:delay-if-busy")) +(define (db:test-get-records-for-index-file . args) + #t + (print "Got here: db:test-get-records-for-index-file")) +(define (db:get-tests-tags . args) + #t + (print "Got here: db:get-tests-tags")) +(define (db:testmeta-get-record . args) + #t + (print "Got here: db:testmeta-get-record")) +(define (db:testmeta-add-record . args) + #t + (print "Got here: db:testmeta-add-record")) +(define (db:testmeta-update-field . args) + #t + (print "Got here: db:testmeta-update-field")) +(define (db:testmeta-get-all . args) + #t + (print "Got here: db:testmeta-get-all")) +(define (db:compare-itempaths . args) + #t + (print "Got here: db:compare-itempaths")) +(define (db:convert-test-itempath . args) + #t + (print "Got here: db:convert-test-itempath")) +(define (db:multi-pattern-apply . args) + #t + (print "Got here: db:multi-pattern-apply")) +(define (db:get-prereqs-not-met . args) + #t + (print "Got here: db:get-prereqs-not-met")) +(define (db:get-run-record-ids . args) + #t + (print "Got here: db:get-run-record-ids")) +(define (db:get-changed-record-ids . args) + #t + (print "Got here: db:get-changed-record-ids")) +(define (db:extract-ods-file . args) + #t + (print "Got here: db:extract-ods-file")) + +;;====================================================================== +;; Strings table (kept in the .db) +;;====================================================================== + +;; Move this into the runid db init +;; +(define (db:sdb-initialize sdb) + (sqlite3:execute sdb "CREATE TABLE IF NOT EXISTS strs + (id INTEGER PRIMARY KEY, + str TEXT, + CONSTRAINT str UNIQUE (str));") + (sqlite3:execute sdb "CREATE INDEX IF NOT EXISTS strindx ON strs (str);")) + +;; (define sumup (let ((a 0))(lambda (x)(set! a (+ x a)) a))) + +(define (db:sdb-register-string sdb str) + (sqlite3:execute sdb "INSERT OR IGNORE INTO strs (str) VALUES (?);" str)) + +(define (db:sdb-string->id sdb str-cache str) + (let ((id (hash-table-ref/default str-cache str #f))) + (if (not id) + (sqlite3:for-each-row + (lambda (sid) + (set! id sid) + (hash-table-set! str-cache str id)) + sdb + "SELECT id FROM strs WHERE str=?;" str)) + id)) + +(define (db:sdb-id->string sdb id-cache id) + (let ((str (hash-table-ref/default id-cache id #f))) + (if (not str) + (sqlite3:for-each-row + (lambda (istr) + (set! str istr) + (hash-table-set! id-cache id str)) + sdb + "SELECT str FROM strs WHERE id=?;" id)) + str)) + +;; Numbers get passed though in both directions +;; +#;(define (db:sdb-qry fname) + (let ((sdb #f) + (scache (make-hash-table)) + (icache (make-hash-table))) + (lambda (cmd var) + (case cmd + ((setup) (set! sdb (if (not sdb) + (db:sdb-open (if var var fname))))) + ((setdb) (set! sdb var)) + ((getdb) sdb) + ((finalize) (if sdb + (begin + (sqlite3:finalize! sdb) + (set! sdb #f)))) + ((getid) (let ((id (if (or (number? var) + (string->number var)) + var + (db:sdb-string->id sdb scache var)))) + (if id + id + (begin + (db:sdb-register-string sdb var) + (db:sdb-string->id sdb scache var))))) + ((getstr) (if (or (number? var) + (string->number var)) + (db:sdb-id->string sdb icache var) + var)) + ((passid) var) + ((passstr) var) + (else #f))))) +) Index: ftail.scm ================================================================== --- ftail.scm +++ ftail.scm @@ -13,11 +13,18 @@ ;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the ;; GNU General Public License for more details. ;; ;; You should have received a copy of the GNU General Public License ;; along with Megatest. If not, see . +;; +;;====================================================================== +;;====================================================================== +;; +;; log to sqlite3 db, polling to tail along with indexing to any point in +;; history is then easy +;; ;;====================================================================== (declare (unit ftail)) (module ftail Index: http-transport.scm ================================================================== --- http-transport.scm +++ http-transport.scm @@ -40,10 +40,15 @@ (include "common_records.scm") (include "db_records.scm") (include "js-path.scm") +(import portlogger) +(portlogger:set-default-log-port! *default-log-port*) +(portlogger:set-configdat! *configdat*) +(portlogger:set-printers! debug:print debug:print-error) + (require-library stml) (define (http-transport:make-server-url hostport) (if (not hostport) #f (conc "http://" (car hostport) ":" (cadr hostport)))) Index: iup-test/Makefile ================================================================== --- iup-test/Makefile +++ iup-test/Makefile @@ -1,5 +1,5 @@ -LIBSRC = "<$PATH>/chicken-4.10.0-patch" +LIBSRC = "PATH/chicken-4.10.0-patch" sample : sample.c gcc -I$(LIBSRC)/include/ -L$(LIBSRC)/lib -L$(LIBSRC)/lib64 -liup -liupimglib -o sample sample.c Index: launch.scm ================================================================== --- launch.scm +++ launch.scm @@ -610,13 +610,11 @@ (rmt:test-set-state-status run-id test-id "REMOTEHOSTSTART" "n/a" #f) ) ;; prime it for running ((member (db:test-get-state test-info) '("RUNNING" "REMOTEHOSTSTART")) (if (process:alive-on-host? test-host test-pid) (debug:print-error 0 *default-log-port* "test state is " (db:test-get-state test-info) " and process " test-pid " is still running on host " test-host ", cannot proceed") - ;; (tests:test-force-state-status! run-id test-id "REMOTEHOSTSTART" "n/a") - (rmt:test-set-state-status run-id test-id "REMOTEHOSTSTART" "n/a" #f) - )) + (exit))) ((not (member (db:test-get-state test-info) '("REMOVING" "REMOTEHOSTSTART" "RUNNING" "KILLREQ"))) ;; (tests:test-force-state-status! run-id test-id "REMOTEHOSTSTART" "n/a") (rmt:test-set-state-status run-id test-id "REMOTEHOSTSTART" "n/a" #f) ) (else ;; (member (db:test-get-state test-info) '("REMOVING" "REMOTEHOSTSTART" "RUNNING" "KILLREQ")) Index: megatest-version.scm ================================================================== --- megatest-version.scm +++ megatest-version.scm @@ -18,6 +18,6 @@ ;; Always use two or four digit decimal ;; 1.01, 1.02...1.10,1.11,1.1101 ... 1.99,2.00.. (declare (unit megatest-version)) -(define megatest-version 1.6521) +(define megatest-version 1.6523) Index: megatest.scm ================================================================== --- megatest.scm +++ megatest.scm @@ -22,11 +22,11 @@ ;; fake out readline usage of toplevel-command (define (toplevel-command . a) #f) (use (prefix sqlite3 sqlite3:) srfi-1 posix regex regex-case srfi-69 (prefix base64 base64:) readline apropos json http-client directory-utils typed-records - http-client srfi-18 extras format) + http-client srfi-18 extras format (prefix pkts pkts:)) ;; Added for csv stuff - will be removed ;; (use sparse-vectors) @@ -44,19 +44,27 @@ (declare (uses tests)) (declare (uses genexample)) ;; (declare (uses daemon)) (declare (uses db)) ;; (declare (uses dcommon)) +(import db) (declare (uses tdb)) (declare (uses mt)) (declare (uses api)) (declare (uses tasks)) ;; only used for debugging. (declare (uses env)) (declare (uses diff-report)) -(declare (uses ftail)) -(import ftail) + +;; (declare (uses ftail)) +;; (import ftail) +;; +;; (declare (uses portlogger)) +;; (import portlogger) +;; +;; (declare (uses nmsg-transport)) +;; (import (prefix nmsg-transport nmsg:)) (define *db* #f) ;; this is only for the repl, do not use in general!!!! (include "common_records.scm") (include "key_records.scm") @@ -110,10 +118,12 @@ Launching and managing runs -run : run all tests or as specified by -testpatt -remove-runs : remove the data for a run, requires -runname and -testpatt Optionally use :state and :status, use -keep-records to remove only the run data. + -kill-runs : kill existing run(s) (all incomplete tests killed) + -kill-rerun : kill an existing run (all incomplete tests killed and run is rerun) -set-state-status X,Y : set state to X and status to Y, requires controls per -remove-runs -rerun FAIL,WARN... : force re-run for tests with specificed status(s) -rerun-clean : set all tests not COMPLETED+PASS,WARN,WAIVED to NOT_STARTED,n/a and then run the specified testpatt with -preclean -rerun-all : set all tests to NOT_STARTED,n/a and run with -preclean @@ -291,10 +301,11 @@ "-set-toplog" "-runstep" "-logpro" "-m" "-rerun" + "-days" "-rename-run" "-to" ;; values and messages ":category" @@ -307,10 +318,11 @@ "-start-dir" "-run-patt" "-target-patt" "-contour" "-area-tag" + "-area" "-server" "-transport" "-port" "-extract-ods" "-pathmod" @@ -403,10 +415,12 @@ "-test-paths" ;; get path(s) to a test, ordered by youngest first "-runall" ;; run all tests, respects -testpatt, defaults to % "-run" ;; alias for -runall "-remove-runs" + "-kill-runs" + "-kill-rerun" "-keep-records" ;; use with -remove-runs to remove only the run data "-rebuild-db" "-cleanup-db" "-rollup" "-update-meta" @@ -571,16 +585,16 @@ (process:children #f)) (original-exit exit-code))))) ;; for some switches always print the command to stderr ;; -(if (args:any? "-run" "-runall" "-remove-runs" "-set-state-status") +(if (args:any? "-run" "-runall" "-remove-runs" "-set-state-status" "-kill-runs" "-kill-rerun") (debug:print 0 *default-log-port* (string-intersperse (argv) " "))) ;; some switches imply homehost. Exit here if not on homehost ;; -(let ((homehost-required (list "-cleanup-db" "-server"))) +#;(let ((homehost-required (list "-cleanup-db" "-server"))) (if (apply args:any? homehost-required) (if (not (common:on-homehost?)) (for-each (lambda (switch) (if (args:get-arg switch) @@ -1038,11 +1052,11 @@ (exit 1)) ((not (or (args:get-arg ":runname") (args:get-arg "-runname"))) (debug:print-error 0 *default-log-port* "Missing required parameter for " action ", you must specify the run name pattern with -runname patt") (exit 2)) - ((not (args:get-arg "-testpatt")) + ((not (or (args:get-arg "-testpatt") (eq? action 'kill-runs))) (debug:print-error 0 *default-log-port* "Missing required parameter for " action ", you must specify the test pattern with -testpatt") (exit 3)) (else (if (not (car *configinfo*)) (begin @@ -1059,10 +1073,46 @@ state: (common:args-get-state) status: (common:args-get-status) new-state-status: (args:get-arg "-set-state-status") mode: mode))) (set! *didsomething* #t))))) + +(if (args:get-arg "-kill-runs") + (general-run-call + "-kill-runs" + "kill runs" + (lambda (target runname keys keyvals) + (operate-on 'kill-runs mode: #f) + ))) + +(if (args:get-arg "-kill-rerun") + (let* ((target-patt (args:get-arg "-target")) + (runname-patt (args:get-arg "-runname"))) + (cond ((not target-patt) + (debug:print-error 0 *default-log-port* "Missing target, must specify target for -kill-rerun with -target ") + (exit 1)) + ((not runname-patt) + (debug:print-error 0 *default-log-port* "Missing runname, must specify runname for -kill-rerun with -runname ") + (exit 1)) + ((string-search "[ ,%]" target-patt) + (debug:print-error 0 *default-log-port* "Invalid target ["target-patt"], must specify exact target (no wildcards) for -kill-rerun with -target ") + (exit 1)) + ((string-search "[ ,%]" runname-patt) + (debug:print-error 0 *default-log-port* "Invalid runname ["runname-patt"], must specify exact runname (no wildcards) for -kill-rerun with -runname ") + (exit 1)) + (else + (general-run-call + "-kill-runs" + "kill runs" + (lambda (target runname keys keyvals) + (operate-on 'kill-runs mode: #f) + )) + + (thread-sleep! 15)) + ;; fall thru and let "-run" loop fire + ))) + (if (args:get-arg "-remove-runs") (general-run-call "-remove-runs" "remove runs" @@ -1622,18 +1672,19 @@ ;; run all tests are are Not COMPLETED and PASS or CHECK (if (or (args:get-arg "-runall") (args:get-arg "-run") (args:get-arg "-rerun-clean") (args:get-arg "-rerun-all") - (args:get-arg "-runtests")) + (args:get-arg "-runtests") + (args:get-arg "-kill-rerun")) (let ((need-clean (or (args:get-arg "-rerun-clean") (args:get-arg "-rerun-all")))) (general-run-call "-runall" "run all tests" (lambda (target runname keys keyvals) - (if (args:get-arg "-rerun-clean") ;; first set states/statuses correct + (if (or (args:get-arg "-kill-rerun") (args:get-arg "-rerun-clean")) ;; first set states/statuses correct ;; For rerun-clean do we or do we not support the testpatt? (let ((states (or (configf:lookup *configdat* "validvalues" "cleanrerun-states") "KILLREQ,KILLED,UNKNOWN,INCOMPLETE,STUCK,NOT_STARTED")) (statuses (or (configf:lookup *configdat* "validvalues" "cleanrerun-statuses") "FAIL,INCOMPLETE,ABORT,CHECK,DEAD,PREQ_FAIL,PREQ_DISCARDED"))) @@ -2150,11 +2201,11 @@ (if (or (getenv "MT_RUNSCRIPT") (args:get-arg "-repl") (args:get-arg "-load")) (let* ((toppath (launch:setup)) (dbstruct (if (and toppath - (common:on-homehost?)) + #;(common:on-homehost?)) (db:setup #t) #f))) ;; make-dbr:dbstruct path: toppath local: (args:get-arg "-local")) #f))) (if *toppath* (cond ((getenv "MT_RUNSCRIPT") @@ -2174,10 +2225,11 @@ (set! *db* dbstruct) (import extras) ;; might not be needed ;; (import csi) (import readline) (import apropos) + (import portlogger) ;; (import (prefix sqlite3 sqlite3:)) ;; doesn't work ... (if *use-new-readline* (begin (install-history-file (get-environment-variable "HOME") ".megatest_history") ;; [homedir] [filename] [nlines]) ADDED mtserve.scm Index: mtserve.scm ================================================================== --- /dev/null +++ mtserve.scm @@ -0,0 +1,294 @@ +;; Copyright 2006-2017, Matthew Welland. +;; +;; This file is part of Megatest. +;; +;; Megatest is free software: you can redistribute it and/or modify +;; it under the terms of the GNU General Public License as published by +;; the Free Software Foundation, either version 3 of the License, or +;; (at your option) any later version. +;; +;; Megatest is distributed in the hope that it will be useful, +;; but WITHOUT ANY WARRANTY; without even the implied warranty of +;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +;; GNU General Public License for more details. +;; +;; You should have received a copy of the GNU General Public License +;; along with Megatest. If not, see . +;; + +;; (include "common.scm") +;; (include "megatest-version.scm") + +;; fake out readline usage of toplevel-command +(define (toplevel-command . a) #f) + +(use (prefix sqlite3 sqlite3:) srfi-1 posix regex regex-case srfi-69 (prefix base64 base64:) + readline apropos json directory-utils typed-records + srfi-18 extras format (prefix pkts pkts:)) + +(declare (uses common)) +(declare (uses megatest-version)) +(declare (uses margs)) +(declare (uses server)) +(declare (uses rmt)) + +;; (declare (uses daemon)) + +(declare (uses db)) +(import db) + +(declare (uses portlogger)) +(import portlogger) + +(declare (uses nmsg-transport)) +(import (prefix nmsg-transport nmsg:)) + +(include "common_records.scm") +(include "key_records.scm") +(include "db_records.scm") +(include "run_records.scm") +(include "megatest-fossil-hash.scm") + +(define *usage-log-file* #f) ;; put path to file for logging usage in this var in the ~/.megatestrc file +(define *usage-use-seconds* #t) ;; for Epoc seconds in usage logging change this to #t in ~/.megatestrc file + +;; load the ~/.megatestrc file, put (use trace)(trace-call-sites #t)(trace function-you-want-to-trace) in this file +;; +(let ((debugcontrolf (conc (get-environment-variable "HOME") "/.mtserverrc"))) + (if (file-exists? debugcontrolf) + (load debugcontrolf))) + +;; usage logging, careful with this, it is not designed to deal with all real world challenges! +;; +(if (and *usage-log-file* + (file-write-access? *usage-log-file*)) + (with-output-to-file + *usage-log-file* + (lambda () + (print + (if *usage-use-seconds* + (current-seconds) + (time->string + (seconds->local-time (current-seconds)) + "%Yww%V.%w %H:%M:%S")) + " " + (current-user-name) " " + (current-directory) " " + "\"" (string-intersperse (argv) " ") "\"")) + #:append)) + +;; Disabled help items +;; -rollup : (currently disabled) fill run (set by :runname) with latest test(s) +;; from prior runs with same keys +;; -daemonize : fork into background and disconnect from stdin/out + +(define help (conc " +Megatest, documentation at http://www.kiatoa.com/fossils/megatest + version " megatest-version " + license GPL, Copyright Matt Welland 2006-2017 + +Usage: mtserver [options] + -h : this help + -manual : show the Megatest user manual + -version : print megatest version (currently " megatest-version ") + +Launching and managing runs + -run : run all tests or as specified by -testpatt + -server main|passive : start the server in \"main\" mode or \"passive\" mode + -log logfile : send stdout and stderr to logfile + -list-servers : list the servers + -kill-servers : kill all servers + -repl : start a repl (useful for extending megatest) + -ping run-id|host:port : ping server, exit with 0 if found + -debug N|N,M,O... : enable debug 0-N or N and M and O ... + +Examples + +# Get test path, use '.' to get a single path or a specific path/file pattern +megatest -test-files 'logs/*.log' -target ubuntu/n%/no% -runname w49% -testpatt test_mt% + +Called as " (string-intersperse (argv) " ") " +Version " megatest-version ", built from " megatest-fossil-hash )) + +;; -gui : start a gui interface +;; -config fname : override the runconfigs file with fname + +;; process args +(define remargs (args:get-args + (argv) + (list "-start-dir" + "-server" + "-port" + "-log" + ) + (list "-h" "-help" "--help" + "-manual" + "-version" + "-list-servers" + "-kill-servers" + "-repl" + "-v" ;; verbose 2, more than normal (normal is 1) + "-q" ;; quiet 0, errors/warnings only + + "-diff-rep" + ) + args:arg-hash + 0)) + +;; Add args that use remargs here +;; +(if (and (not (null? remargs)) + (not (or + (args:get-arg "-runstep") + (args:get-arg "-envcap") + (args:get-arg "-envdelta") + ) + )) + (debug:print-error 0 *default-log-port* "Unrecognised arguments: " (string-intersperse (if (list? remargs) remargs (argv)) " "))) + +;; before doing anything else change to the start-dir if provided +;; +(if (args:get-arg "-start-dir") + (if (file-exists? (args:get-arg "-start-dir")) + (let ((fullpath (common:real-path (args:get-arg "-start-dir")))) + (setenv "PWD" fullpath) + (change-directory fullpath)) + (begin + (debug:print-error 0 *default-log-port* "non-existant start dir " (args:get-arg "-start-dir") " specified, exiting.") + (exit 1)))) + +;; The watchdog is to keep an eye on things like db sync etc. +;; +(define *watchdog* (make-thread + (lambda () + (handle-exceptions + exn + (begin + (print-call-chain) + (print " message: " ((condition-property-accessor 'exn 'message) exn))) + (common:watchdog))) + "Watchdog thread")) + +;;====================================================================== +;; Strive for clean exit handling +;;====================================================================== + +(define (server-exit-procedure) + (on-exit (lambda () + ;; close the databases, ensure the pkt is removed! + + (server:shutdown) + 0))) + +;; Copied from the SDL2 examples. +;; +;; Schedule quit! to be automatically called when your program exits normally. +(on-exit server-exit-procedure) + +;; Install a custom exception handler that will call quit! and then +;; call the original exception handler. This ensures that quit! will +;; be called even if an unhandled exception reaches the top level. +(current-exception-handler + (let ((original-handler (current-exception-handler))) + (lambda (exception) + (server-exit-procedure) + (original-handler exception)))) + +;;(if (not (args:get-arg "-server")) +;; (thread-start! *watchdog*)) ;; if starting a server; wait till we get to running state before kicking off watchdog +#;(let* ((no-watchdog-args + '("-list-runs" + "-testdata-csv" + "-list-servers" + "-server" + "-list-disks" + "-list-targets" + "-show-runconfig" + ;;"-list-db-targets" + "-show-runconfig" + "-show-config" + "-show-cmdinfo" + "-cleanup-db")) + (no-watchdog-args-vals (filter (lambda (x) x) + (map args:get-arg no-watchdog-args))) + (start-watchdog (null? no-watchdog-args-vals))) + ;;(BB> "no-watchdog-args="no-watchdog-args "no-watchdog-args-vals="no-watchdog-args-vals) + (if start-watchdog + (thread-start! *watchdog*))) + + +;; bracket open-output-file with code to make leading directory if it does not exist and handle exceptions +(define (open-logfile logpath) + (condition-case + (let* ((log-dir (or (pathname-directory logpath) "."))) + (if (not (directory-exists? log-dir)) + (system (conc "mkdir -p " log-dir))) + (open-output-file logpath)) + (exn () + (debug:print-error 0 *default-log-port* "Could not open log file for write: "logpath) + (define *didsomething* #t) + (exit 1)))) + +;; this segment will run launch:setup only if -log is not set. This is fairly safe as servers are not +;; manually started and thus should never be started in a non-megatest area. Thus no need to handle situation +;; where (launch:setup) returns #f? +;; +#;(if (or (args:get-arg "-log")(args:get-arg "-server")) ;; redirect the log always when a server + (handle-exceptions + exn + (begin + (print "ERROR: Failed to switch to log output. " ((condition-property-accessor 'exn 'message) exn)) + ) + (let* ((tl (or (args:get-arg "-log")(launch:setup))) ;; run launch:setup if -server, ensure we do NOT run launch:setup if -log specified + (logf (or (args:get-arg "-log") ;; use -log unless we are a server, then craft a logfile name + (conc tl "/logs/server-" (current-process-id) "-" (get-host-name) ".log"))) + (oup (open-logfile logf))) + (if (not (args:get-arg "-log")) + (hash-table-set! args:arg-hash "-log" logf)) ;; fake out future queries of -log + (debug:print-info 0 *default-log-port* "Sending log output to " logf) + (set! *default-log-port* oup)))) + +(if (or (args:get-arg "-h") + (args:get-arg "-help") + (args:get-arg "--help")) + (begin + (print help) + (exit))) + +(if (args:get-arg "-version") + (begin + (print (common:version-signature)) ;; (print megatest-version) + (exit))) + +(define *didsomething* #f) + +;; ready? start the server +;; +(if (args:get-arg "-server") + (let ((mode (string->symbol (args:get-arg "-server")))) + (print "Mode: " mode) + (case mode + ((main)(print "Starting server in main mode.")) + (else (print "Starting server in hidden mode."))) + ;; opens the port, drops the pkt, contacts other servers and then waits for messages + (if (not (server:launch mode)) ;; (lambda (pktrecvd)(print "Received: " pktrecvd)))) + (exit 1)) + (set! *didsomething* #t))) + +(if (args:get-arg "-repl") + (begin + ;; user will have to start the server manually + (print "Run: (server:start-nmsg 'main) to start the server") + (import extras) ;; might not be needed + ;; (import csi) + (import readline) + (import apropos) + (import portlogger) + ;; (import (prefix sqlite3 sqlite3:)) ;; doesn't work ... + + (install-history-file (get-environment-variable "HOME") ".megatest_history") ;; [homedir] [filename] [nlines]) + (current-input-port (make-readline-port "megatest> ")) + (repl) + (set! *didsomething* #t))) + + Index: mtut.scm ================================================================== --- mtut.scm +++ mtut.scm @@ -29,11 +29,11 @@ (declare (uses common)) (declare (uses megatest-version)) (declare (uses margs)) (declare (uses configf)) -;; (declare (uses rmt)) +(declare (uses rmt)) (use ducttape-lib) (include "megatest-fossil-hash.scm") @@ -140,10 +140,12 @@ Run management: run : initiate or resume a run, already completed and in-progress tests are not affected. rerun-clean : clean and rerun all not completed pass/fail tests rerun-all : clean and rerun entire run + kill-run : kill all tests in run + kill-rerun : kill all tests in run and restart non-completed tests remove : remove runs set-ss : set state/status archive : compress and move test data to archive disk kill : stop tests or entire runs db : database utilities @@ -247,10 +249,12 @@ ;; alist to map actions to old megatest commands (define *action-keys* '((run . "-run") (rerun-clean . "-rerun-clean") (rerun-all . "-rerun-all") + (kill-run . "-kill-runs") + (kill-rerun . "-kill-rerun") (sync . "") (archive . "-archive") (set-ss . "-set-state-status") (remove . "-remove-runs"))) @@ -492,10 +496,12 @@ (with-input-from-string data (lambda () (read)))) +;; moved to portlogger - TODO: remove from here and get from portlogger +;; (define (is-port-in-use port-num) (let* ((ret #f)) (let-values (((inp oup pid) (process "netstat" (list "-tulpn" )))) (let loop ((inl (read-line inp))) @@ -1443,11 +1449,11 @@ (set! *default-log-port* oup) ))) (if *action* (case (string->symbol *action*) - ((run remove rerun rerun-clean rerun-all set-ss archive kill list) + ((run remove rerun rerun-clean rerun-all set-ss archive kill list kill-run kill-rerun) (let* ((mtconfdat (simple-setup (args:get-arg "-start-dir"))) (mtconf (car mtconfdat)) (area (args:get-arg "-area")) ;; look up the area to dispatch to from [areas] section (areasec (if area (configf:lookup mtconf "areas" area) #f)) (areadat (if areasec (common:val->alist areasec) #f)) @@ -1622,68 +1628,65 @@ (mtconf (car mtconfdat)) (contact (configf:lookup mtconf "listener" "owner")) (script (configf:lookup mtconf "listener" "script"))) (print "Listening on port " portnum " for messages.") (set-signal-handler! signal/int (lambda (signum) - (set! *time-to-exit* #t) - (debug:print-error 0 *default-log-port* "Received signal " signum " sending email befor exiting !!") - (let ((email-body (mtut:stml->string (s:body - (s:p (conc "Received signal " signum ". Lister has been terminated on host " (get-environment-variable "HOST") ". ")))))) - (sendmail contact "Listner has been terminated." email-body use_html: #t)) - (exit))) - (set-signal-handler! signal/term (lambda (signum) - (set! *time-to-exit* #t) - (debug:print-error 0 *default-log-port* "Received signal " signum " sending email befor exiting !!") - (let ((email-body (mtut:stml->string (s:body - (s:p (conc "Received signal " signum ". Lister has been terminated on host " (get-environment-variable "HOST") ". ")))))) - (sendmail contact "Listner has been terminated." email-body use_html: #t)) - (exit))) - - ;(set-signal-handler! signal/term special-signal-handler) + (set! *time-to-exit* #t) + (debug:print-error 0 *default-log-port* "Received signal " signum " sending email befor exiting !!") + (let ((email-body (mtut:stml->string (s:body + (s:p (conc "Received signal " signum ". Lister has been terminated on host " (get-environment-variable "HOST") ". ")))))) + (sendmail contact "Listner has been terminated." email-body use_html: #t)) + (exit))) + (set-signal-handler! signal/term (lambda (signum) + (set! *time-to-exit* #t) + (debug:print-error 0 *default-log-port* "Received signal " signum " sending email befor exiting !!") + (let ((email-body (mtut:stml->string (s:body + (s:p (conc "Received signal " signum ". Lister has been terminated on host " (get-environment-variable "HOST") ". ")))))) + (sendmail contact "Listner has been terminated." email-body use_html: #t)) + (exit))) + + ;;(set-signal-handler! signal/term special-signal-handler) (let loop ((instr (nn-recv rep))) - ;;(nn-send rep "3.9") - (with-input-from-pipe (conc "/usr/bin/uptime | cut -d':' -f4 | awk '{print $1}' | cut -d',' -f1") - (lambda() - (let loop ((inl (read-line))) - (if (not (eof-object? inl)) - (begin - ;;(print "fdk73: " inl ":") - ;;(set! current-list-ciaf (append! current-list-ciaf (list (string-substitute "\\s+$" "" inl)))) - (nn-send rep inl) - (loop(read-line))) - )) - - ) - ) - ;;(print (isys "/usr/bin/uptime" foreach-stdout-thunk: foreach-stdout)) - (let ((ctime (date->string (current-date)))) + ;;(nn-send rep "3.9") + (with-input-from-pipe (conc "/usr/bin/uptime | cut -d':' -f4 | awk '{print $1}' | cut -d',' -f1") + (lambda() + (let loop ((inl (read-line))) + (if (not (eof-object? inl)) + (begin + ;;(print "fdk73: " inl ":") + ;;(set! current-list-ciaf (append! current-list-ciaf (list (string-substitute "\\s+$" "" inl)))) + (nn-send rep inl) + (loop(read-line))) + )))) + ;;(print (isys "/usr/bin/uptime" foreach-stdout-thunk: foreach-stdout)) + (let ((ctime (date->string (current-date)))) (if (equal? instr "time-to-die") - (begin - (debug:print 0 *default-log-port* ctime " received '" instr "'. Time to sucide." ) - (let ((pid (current-process-id))) - (debug:print 0 *default-log-port* "Killing current process (pid=" pid ")") - (system (conc "kill " pid)))) - (begin - (debug:print 0 *default-log-port* ctime " received " instr ) - ;(nn-send rep "ok") - (if (not (equal? instr "ping")) - (begin - (debug:print 0 *default-log-port* ctime " running \"" script " " instr "\"") - ;(system (conc script " '" instr "'")) - (process-run script (list instr )) - (debug:print 0 *default-log-port* ctime " done" )) - (begin - (if (not (equal? instr "load")) - (print "Checking load") - - ) - ) - - ) - - ))) + (begin + (debug:print 0 *default-log-port* ctime " received '" instr "'. Time to sucide." ) + (let ((pid (current-process-id))) + (debug:print 0 *default-log-port* "Killing current process (pid=" pid ")") + (system (conc "kill " pid)))) + (begin + (debug:print 0 *default-log-port* ctime " received " instr ) + ;(nn-send rep "ok") + (if (not (equal? instr "ping")) + (begin + (debug:print 0 *default-log-port* ctime " running \"" script " " instr "\"") + ;(system (conc script " '" instr "'")) + (process-run script (list instr )) + (debug:print 0 *default-log-port* ctime " done" )) + (begin + (if (not (equal? instr "load")) + (print "Checking load") + + ) + ) + + ) + + ))) (loop (nn-recv rep)))) (print "ERROR: Port " portnum " already in use. Try another port"))))))) ADDED nmsg-transport.scm Index: nmsg-transport.scm ================================================================== --- /dev/null +++ nmsg-transport.scm @@ -0,0 +1,121 @@ + +;; Copyright 2006-2012, Matthew Welland. +;; +;; This file is part of Megatest. +;; +;; Megatest is free software: you can redistribute it and/or modify +;; it under the terms of the GNU General Public License as published by +;; the Free Software Foundation, either version 3 of the License, or +;; (at your option) any later version. +;; +;; Megatest is distributed in the hope that it will be useful, +;; but WITHOUT ANY WARRANTY; without even the implied warranty of +;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +;; GNU General Public License for more details. +;; +;; You should have received a copy of the GNU General Public License +;; along with Megatest. If not, see . + +;;====================================================================== +;; Support routines for nmsg usage. +;; This should be reusable, non-megatest specific stuff +;;====================================================================== + +(declare (unit nmsg-transport)) + +(module + nmsg-transport + ( + nmsg:start-server + nmsg:open-send-close + nmsg:open-send-receive + nmsg:recv + nmsg:send + nmsg:close + ) + +(import scheme posix chicken data-structures ports) + +(use nanomsg srfi-18) + +;;start a server, returns the connection +;; +(define (nmsg:start-server portnum) + (let ((rep (nn-socket 'rep))) + (handle-exceptions + exn + (let ((emsg ((condition-property-accessor 'exn 'message) exn))) + (print "ERROR: Failed to start server \"" emsg "\"") + #f) + (nn-bind rep (conc "tcp://*:" portnum))) + rep)) + +;; open connection to server, send message, close connection +;; +;; to take an action on failure use proc which is called with the error info +;; (proc exn errormsg) +;; +;; returns the response or #f if no response within timeout +;; +(define (nmsg:open-send-close host-port msg #!key (timeout 3)(proc #f)) ;; default timeout is 3 seconds + (let ((req (nn-socket 'req)) + (uri (conc "tcp://" host-port)) + (res #f)) + (handle-exceptions + exn + (let ((emsg ((condition-property-accessor 'exn 'message) exn))) + ;; call proc on fail + (if proc (proc exn emsg)) + #f) + (nn-connect req uri) + (print "Connected to the server " ) + (nn-send req msg) + (print "Request Sent") + (let* ((th1 (make-thread (lambda () + (let ((resp (nn-recv req))) + (nn-close req) + (set! res resp))) + "recv thread")) + (th2 (make-thread (lambda () + (thread-sleep! timeout) + (thread-terminate! th1)) + "timer thread"))) + (thread-start! th1) + (thread-start! th2) + (thread-join! th1) + res)))) + +;; default timeout is 3 seconds +;; +(define (nmsg:open-send-receive host-port msg #!key (timeout 3)(proc #f)) + (let ((req (nn-socket 'req)) + (uri (conc "tcp://" host-port)) + (res #f)) + (handle-exceptions + exn + (let ((emsg ((condition-property-accessor 'exn 'message) exn))) + ;; take action on fail + (if proc (proc exn emsg)) + #f) + (nn-connect req uri) + (nn-send req msg) + (let* ((th1 (make-thread (lambda () + (let ((resp (nn-recv req))) + (nn-close req) + (print resp) + (set! res resp))) + "recv thread")) + (th2 (make-thread (lambda () + (thread-sleep! timeout) + (thread-terminate! th1)) + "timer thread"))) + (thread-start! th1) + (thread-start! th2) + (thread-join! th1) + res)))) + +(define nmsg:close nn-close) +(define nmsg:recv nn-recv) +(define nmsg:send nn-send) + +) Index: portlogger-example.scm ================================================================== --- portlogger-example.scm +++ portlogger-example.scm @@ -15,7 +15,15 @@ ;; You should have received a copy of the GNU General Public License ;; along with Megatest. If not, see . (declare (uses portlogger)) +(import portlogger) +(use trace (prefix sqlite3 sqlite3:)) +(trace + portlogger:open-db + portlogger:take-port + portlogger:open-run-close + sqlite3:execute + ) (print (apply portlogger:main (cdr (argv)))) Index: portlogger.scm ================================================================== --- portlogger.scm +++ portlogger.scm @@ -15,42 +15,67 @@ ;; ;; You should have received a copy of the GNU General Public License ;; along with Megatest. If not, see . ;; -(require-extension (srfi 18) extras tcp s11n) - -(use sqlite3 srfi-1 posix srfi-69 hostinfo dot-locking z3) -(import (prefix sqlite3 sqlite3:)) - (declare (unit portlogger)) -(declare (uses db)) + +(module + portlogger + (portlogger:set-configdat! + portlogger:set-printers! + portlogger:set-default-log-port! + portlogger:open-db + portlogger:open-run-close + portlogger:take-port + portlogger:get-prev-used-port + portlogger:find-port + portlogger:set-port + portlogger:release-port + portlogger:set-failed + portlogger:is-port-in-use + portlogger:main +) + +(import scheme posix chicken data-structures ports) + +(require-extension (srfi 18) extras tcp s11n) +(use srfi-1 posix srfi-69 hostinfo dot-locking z3 regex) +(use (prefix sqlite3 sqlite3:)) +(use (prefix mtconfigf configf:)) ;; lsof -i +(define *configdat* #f) +(define (portlogger:set-configdat! cfgdat) + (set! *configdat* cfgdat)) + +(define (debug:print level port . params) + (with-output-to-port + port + (lambda ()(apply print params)))) +(define debug:print-error debug:print) +(define *default-log-port* (current-error-port)) + +(define (portlogger:set-printers! pdebug pdebugerr) + (set! debug:print pdebug) + (set! debug:print-error pdebugerr)) +(define (portlogger:set-default-log-port! port) + (set! *default-log-port* port)) (define (portlogger:open-db fname) - (let* ((avail (tasks:wait-on-journal fname 5 remove: #t)) ;; wait up to about 10 seconds for the journal to go away - (exists (common:file-exists? fname)) + (let* ((avail #t) ;; for now - assume wait on journal not needed (tasks:wait-on-journal fname 5 remove: #t)) ;; wait up to about 10 seconds for the journal to go away + (exists (file-exists? fname)) (db (if avail (sqlite3:open-database fname) (begin (system (conc "rm -f " fname)) (sqlite3:open-database fname)))) - (handler (make-busy-timeout 136000)) + (handler (sqlite3:make-busy-timeout 136000)) (canwrite (file-write-access? fname))) - ;; (db-init (lambda () - ;; (sqlite3:execute - ;; db - ;; "CREATE TABLE IF NOT EXISTS ports ( - ;; port INTEGER PRIMARY KEY, - ;; state TEXT DEFAULT 'not-used', - ;; fail_count INTEGER DEFAULT 0, - ;; update_time TIMESTAMP DEFAULT (strftime('%s','now')) );")))) (sqlite3:set-busy-handler! db handler) - (db:set-sync db) ;; (sqlite3:execute db "PRAGMA synchronous = 0;") - ;; (if (not exists) ;; needed with IF NOT EXISTS? + (sqlite3:execute db "PRAGMA synchronous = 0;") (sqlite3:execute db "CREATE TABLE IF NOT EXISTS ports ( port INTEGER PRIMARY KEY, state TEXT DEFAULT 'not-used', @@ -58,19 +83,19 @@ update_time TIMESTAMP DEFAULT (strftime('%s','now')) );") db)) (define (portlogger:open-run-close proc . params) (let* ((fname (conc "/tmp/." (current-user-name) "-portlogger.db")) - (avail (tasks:wait-on-journal fname 10))) ;; wait up to about 10 seconds for the journal to go away + (avail #t)) ;; (tasks:wait-on-journal fname 10))) ;; wait up to about 10 seconds for the journal to go away (handle-exceptions exn (begin ;; (release-dot-lock fname) (debug:print-error 0 *default-log-port* "portlogger:open-run-close failed. " proc " " params) (debug:print 0 *default-log-port* " message: " ((condition-property-accessor 'exn 'message) exn)) (debug:print 5 *default-log-port* "exn=" (condition->list exn)) - (if (common:file-exists? fname)(delete-file fname)) ;; brutally get rid of it + (if (file-exists? fname)(delete-file fname)) ;; brutally get rid of it (print-call-chain (current-error-port))) (let* (;; (lock (obtain-dot-lock fname 2 9 10)) (db (portlogger:open-db fname)) (res (apply proc db params))) (sqlite3:finalize! db) @@ -80,13 +105,13 @@ ;; (fold-row PROC INIT DATABASE SQL . PARAMETERS) (define (portlogger:take-port db portnum) (let* ((qry1 (sqlite3:prepare db "INSERT INTO ports (port,state) VALUES (?,?);")) (qry2 (sqlite3:prepare db "UPDATE ports SET state=?,update_time=strftime('%s','now') WHERE port=?;")) (qry3 (sqlite3:prepare db "SELECT state FROM ports WHERE port=?;")) - (res (sqlite3:with-transaction - db - (lambda () + (res ;; (sqlite3:with-transaction ;; move the transaction up to the find-port call + ;; db + ;; (lambda () ;; (fold-row (lambda (var curr) (or var curr)) #f db "SELECT var FROM foo WHERE id=100;") (let* ((curr #f) (res #f)) (set! curr (sqlite3:fold-row (lambda (var curr) @@ -100,11 +125,11 @@ ((not-tried) (sqlite3:execute qry1 portnum "taken") 'taken) ((taken) 'already-taken) ((failed) 'failed) (else 'error))) ;; (print "res=" res) - res))))) + res))) ;; )) (sqlite3:finalize! qry1) (sqlite3:finalize! qry2) (sqlite3:finalize! qry3) res)) @@ -124,38 +149,60 @@ #f db "SELECT (port) FROM ports WHERE state='released' LIMIT 1;"))) (define (portlogger:find-port db) - (let* ((lowport (let ((val (configf:lookup *configdat* "server" "lowport"))) - (if (and val - (string->number val)) - (string->number val) - 32768))) - (portnum (or (portlogger:get-prev-used-port db) - (+ lowport ;; top of registered ports is 49152 but lets use ports in the registered range - (random (- 64000 lowport)))))) - (handle-exceptions - exn - (begin - (debug:print 0 *default-log-port* "EXCEPTION: portlogger database probably overloaded or unreadable. If you see this message again remove /tmp/.$USER-portlogger.db") - (debug:print 0 *default-log-port* " message: " ((condition-property-accessor 'exn 'message) exn)) - (debug:print 5 *default-log-port* "exn=" (condition->list exn)) - (print-call-chain (current-error-port)) - (debug:print 0 *default-log-port* "Continuing anyway.")) - (portlogger:take-port db portnum)) - portnum)) + (let ((lowport (let ((val (configf:lookup *configdat* "server" "lowport"))) + (if (and val + (string->number val)) + (string->number val) + 32768)))) + (sqlite3:with-transaction + db + (lambda () + (let loop ((numtries 0)) + (let* ((portnum (or (portlogger:get-prev-used-port db) + (+ lowport ;; top of registered ports is 49152 but let's use ports in the registered range + (random (- 64000 lowport)))))) + (handle-exceptions + exn + (begin + (debug:print 0 *default-log-port* "EXCEPTION: portlogger database probably overloaded or unreadable. If you see this message again remove /tmp/.$USER-portlogger.db") + (debug:print 0 *default-log-port* " message: " ((condition-property-accessor 'exn 'message) exn)) + (debug:print 5 *default-log-port* "exn=" (condition->list exn)) + (print-call-chain (current-error-port)) + (debug:print 0 *default-log-port* "Continuing anyway.")) + (portlogger:take-port db portnum) ;; always "take the port" + (if (portlogger:is-port-in-use portnum) + portnum + (loop (add1 numtries)))))))))) ;; set port to "released", "failed" etc. ;; (define (portlogger:set-port db portnum value) (sqlite3:execute db "UPDATE ports SET state=?,update_time=strftime('%s','now') WHERE port=?;" value portnum)) +;; release port +(define (portlogger:release-port db portnum) + (sqlite3:execute db "UPDATE ports SET state=?,update_time=strftime('%s','now') WHERE port=?;" "released" portnum)) + ;; set port to failed (attempted to take but got error) ;; (define (portlogger:set-failed db portnum) (sqlite3:execute db "UPDATE ports SET state='failed',fail_count=fail_count+1,update_time=strftime('%s','now') WHERE port=?;" portnum)) + +;; pulled from mtut - TODO: remove from mtut +;; +(define (portlogger:is-port-in-use port-num) + (let-values (((inp oup pid) + (process "netstat" (list "-tulpn" )))) + (let loop ((inl (read-line inp))) + (if (not (eof-object? inl)) + (begin + (if (string-search (regexp (conc ":" port-num "\\s+")) inl) + #t + (loop (read-line inp)))))))) ;;====================================================================== ;; MAIN ;;====================================================================== @@ -180,10 +227,12 @@ (state (caddr args))) (portlogger:set-port db (if (number? port) port (string->number port)) state) state)) - ((failed)(portlogger:set-failed db (string->number (cadr args))) 'failed))))) + ((failed)(portlogger:set-failed db (string->number (cadr args))) 'failed) + (else "nosuchcommand"))))) (sqlite3:finalize! db) result)) ;; (print (apply portlogger:main (cdr (argv)))) +) Index: rmt.scm ================================================================== --- rmt.scm +++ rmt.scm @@ -20,911 +20,346 @@ (use format typed-records) ;; RADT => purpose of json format?? (declare (unit rmt)) (declare (uses api)) -(declare (uses http-transport)) +(import api) + (include "common_records.scm") -;; -;; THESE ARE ALL CALLED ON THE CLIENT SIDE!!! -;; - -;; generate entries for ~/.megatestrc with the following -;; -;; grep define ../rmt.scm | grep rmt: |perl -pi -e 's/\(define\s+\((\S+)\W.*$/\1/'|sort -u - -;;====================================================================== -;; S U P P O R T F U N C T I O N S -;;====================================================================== - -;; if a server is either running or in the process of starting call client:setup -;; else return #f to let the calling proc know that there is no server available -;; -(define (rmt:get-connection-info areapath #!key (area-dat #f)) ;; TODO: push areapath down. - (let* ((runremote (or area-dat *runremote*)) - (cinfo (if (remote? runremote) - (remote-conndat runremote) - #f))) - (if cinfo - cinfo - (if (server:check-if-running areapath) - (client:setup areapath) - #f)))) - -(define *send-receive-mutex* (make-mutex)) ;; should have separate mutex per run-id - -;; RA => e.g. usage (rmt:send-receive 'get-var #f (list varname)) -;; -(define (rmt:send-receive cmd rid params #!key (attemptnum 1)(area-dat #f)) ;; start attemptnum at 1 so the modulo below works as expected - - ;;DOT digraph megatest_state_status { - ;;DOT ranksep=0; - ;;DOT // rankdir=LR; - ;;DOT node [shape="box"]; - ;;DOT "rmt:send-receive" -> MUTEXLOCK; - ;;DOT { edge [style=invis];"case 1" -> "case 2" -> "case 3" -> "case 4" -> "case 5" -> "case 6" -> "case 7" -> "case 8" -> "case 9" -> "case 10" -> "case 11"; } - ;; do all the prep locked under the rmt-mutex - (mutex-lock! *rmt-mutex*) - - ;; 1. check if server is started IFF cmd is a write OR if we are not on the homehost, store in runremote - ;; 2. check the age of the connections. refresh the connection if it is older than timeout-20 seconds. - ;; 3. do the query, if on homehost use local access - ;; - (let* ((start-time (current-seconds)) ;; snapshot time so all use cases get same value - (areapath *toppath*);; TODO - resolve from dbstruct to be compatible with multiple areas - (runremote (or area-dat - *runremote*)) - (readonly-mode (if (and runremote - (remote-ro-mode-checked runremote)) - (remote-ro-mode runremote) - (let* ((dbfile (conc *toppath* "/megatest.db")) - (ro-mode (not (file-write-access? dbfile)))) ;; TODO: use dbstruct or runremote to figure this out in future - (if runremote - (begin - (remote-ro-mode-set! runremote ro-mode) - (remote-ro-mode-checked-set! runremote #t) - ro-mode) - ro-mode))))) - - ;; DOT INIT_RUNREMOTE; // leaving off - doesn't really add to the clarity - ;; DOT MUTEXLOCK -> INIT_RUNREMOTE [label="no remote?"]; - ;; DOT INIT_RUNREMOTE -> MUTEXLOCK; - ;; ensure we have a record for our connection for given area - (if (not runremote) ;; can remove this one. should never get here. - (begin - (set! *runremote* (make-remote)) - (set! runremote *runremote*))) ;; new runremote will come from this on next iteration - - ;; DOT SET_HOMEHOST; // leaving off - doesn't really add to the clarity - ;; DOT MUTEXLOCK -> SET_HOMEHOST [label="no homehost?"]; - ;; DOT SET_HOMEHOST -> MUTEXLOCK; - ;; ensure we have a homehost record - (if (not (pair? (remote-hh-dat runremote))) ;; not on homehost - (thread-sleep! 0.1) ;; since we shouldn't get here, delay a little - (remote-hh-dat-set! runremote (common:get-homehost))) - - ;;(print "BB> readonly-mode is "readonly-mode" dbfile is "dbfile) - (cond - ;;DOT EXIT; - ;;DOT MUTEXLOCK -> EXIT [label="> 15 attempts"]; {rank=same "case 1" "EXIT" } - ;; give up if more than 15 attempts - ((> attemptnum 15) - (debug:print 0 *default-log-port* "ERROR: 15 tries to start/connect to server. Giving up.") - (exit 1)) - - ;;DOT CASE2 [label="local\nreadonly\nquery"]; - ;;DOT MUTEXLOCK -> CASE2; {rank=same "case 2" CASE2} - ;;DOT CASE2 -> "rmt:open-qry-close-locally"; - ;; readonly mode, read request- handle it - case 2 - ((and readonly-mode - (member cmd api:read-only-queries)) - (mutex-unlock! *rmt-mutex*) - (debug:print-info 12 *default-log-port* "rmt:send-receive, case 2") - (rmt:open-qry-close-locally cmd 0 params) - ) - - ;;DOT CASE3 [label="write in\nread-only mode"]; - ;;DOT MUTEXLOCK -> CASE3 [label="readonly\nmode?"]; {rank=same "case 3" CASE3} - ;;DOT CASE3 -> "#f"; - ;; readonly mode, write request. Do nothing, return #f - (readonly-mode - (mutex-unlock! *rmt-mutex*) - (debug:print-info 12 *default-log-port* "rmt:send-receive, case 3") - (debug:print 0 *default-log-port* "WARNING: write transaction requested on a readonly area. cmd="cmd" params="params) - #f) - - ;; This block was for pre-emptively resetting the connection if there had been no communication for some time. - ;; I don't think it adds any value. If the server is not there, just fail and start a new connection. - ;; also, the expire-time calculation might not be correct. We want, time-since-last-server-access > (server:get-timeout) - ;; - ;;DOT CASE4 [label="reset\nconnection"]; - ;;DOT MUTEXLOCK -> CASE4 [label="have connection,\nlast_access > expire_time"]; {rank=same "case 4" CASE4} - ;;DOT CASE4 -> "rmt:send-receive"; - ;; reset the connection if it has been unused too long - ((and runremote - (remote-conndat runremote) - (> (current-seconds) ;; if it has been more than server-timeout seconds since last contact, close this connection and start a new on - (+ (http-transport:server-dat-get-last-access (remote-conndat runremote)) - (remote-server-timeout runremote)))) - (debug:print-info 0 *default-log-port* "Connection to " (remote-server-url runremote) " expired due to no accesses, forcing new connection.") - (http-transport:close-connections area-dat: runremote) - (remote-conndat-set! runremote #f) ;; invalidate the connection, thus forcing a new connection. - (mutex-unlock! *rmt-mutex*) - (rmt:send-receive cmd rid params attemptnum: attemptnum)) - - ;;DOT CASE5 [label="local\nread"]; - ;;DOT MUTEXLOCK -> CASE5 [label="server not required,\non homehost,\nread-only query"]; {rank=same "case 5" CASE5}; - ;;DOT CASE5 -> "rmt:open-qry-close-locally"; - - ;; on homehost and this is a read - ((and (not (remote-force-server runremote)) ;; honor forced use of server, i.e. server NOT required - (cdr (remote-hh-dat runremote)) ;; on homehost - (member cmd api:read-only-queries)) ;; this is a read - (mutex-unlock! *rmt-mutex*) - (debug:print-info 12 *default-log-port* "rmt:send-receive, case 5") - (rmt:open-qry-close-locally cmd 0 params)) - - ;;DOT CASE6 [label="init\nremote"]; - ;;DOT MUTEXLOCK -> CASE6 [label="on homehost,\nwrite query,\nhave server,\ncan't reach it"]; {rank=same "case 6" CASE6}; - ;;DOT CASE6 -> "rmt:send-receive"; - ;; on homehost and this is a write, we already have a server, but server has died - ((and (cdr (remote-hh-dat runremote)) ;; on homehost - (not (member cmd api:read-only-queries)) ;; this is a write - (remote-server-url runremote) ;; have a server - (not (server:ping (remote-server-url runremote)))) ;; server has died. NOTE: this is not a cheap call! Need better approach. - (set! *runremote* (make-remote)) - (remote-force-server-set! runremote (common:force-server?)) - (mutex-unlock! *rmt-mutex*) - (debug:print-info 12 *default-log-port* "rmt:send-receive, case 6") - (rmt:send-receive cmd rid params attemptnum: attemptnum)) - - ;;DOT CASE7 [label="homehost\nwrite"]; - ;;DOT MUTEXLOCK -> CASE7 [label="server not required,\non homehost,\na write,\nhave a server"]; {rank=same "case 7" CASE7}; - ;;DOT CASE7 -> "rmt:open-qry-close-locally"; - ;; on homehost and this is a write, we already have a server - ((and (not (remote-force-server runremote)) ;; honor forced use of server, i.e. server NOT required - (cdr (remote-hh-dat runremote)) ;; on homehost - (not (member cmd api:read-only-queries)) ;; this is a write - (remote-server-url runremote)) ;; have a server - (mutex-unlock! *rmt-mutex*) - (debug:print-info 12 *default-log-port* "rmt:send-receive, case 4.1") - (rmt:open-qry-close-locally cmd 0 params)) - - ;;DOT CASE8 [label="force\nserver"]; - ;;DOT MUTEXLOCK -> CASE8 [label="server not required,\nhave homehost info,\nno connection yet,\nnot a read-only query"]; {rank=same "case 8" CASE8}; - ;;DOT CASE8 -> "rmt:open-qry-close-locally"; - ;; on homehost, no server contact made and this is a write, passively start a server - ((and (not (remote-force-server runremote)) ;; honor forced use of server, i.e. server NOT required - (cdr (remote-hh-dat runremote)) ;; have homehost - (not (remote-server-url runremote)) ;; no connection yet - (not (member cmd api:read-only-queries))) ;; not a read-only query - (debug:print-info 12 *default-log-port* "rmt:send-receive, case 8") - (let ((server-url (server:check-if-running *toppath*))) ;; (server:read-dotserver->url *toppath*))) ;; (server:check-if-running *toppath*))) ;; Do NOT want to run server:check-if-running - very expensive to do for every write call - (if server-url - (remote-server-url-set! runremote server-url) ;; the string can be consumed by the client setup if needed - (if (common:force-server?) - (server:start-and-wait *toppath*) - (server:kind-run *toppath*)))) - (remote-force-server-set! runremote (common:force-server?)) - (mutex-unlock! *rmt-mutex*) - (debug:print-info 12 *default-log-port* "rmt:send-receive, case 8.1") - (rmt:open-qry-close-locally cmd 0 params)) - - ;;DOT CASE9 [label="force server\nnot on homehost"]; - ;;DOT MUTEXLOCK -> CASE9 [label="no connection\nand either require server\nor not on homehost"]; {rank=same "case 9" CASE9}; - ;;DOT CASE9 -> "start\nserver" -> "rmt:send-receive"; - ((or (and (remote-force-server runremote) ;; we are forcing a server and don't yet have a connection to one - (not (remote-conndat runremote))) - (and (not (cdr (remote-hh-dat runremote))) ;; not on a homehost - (not (remote-conndat runremote)))) ;; and no connection - (debug:print-info 12 *default-log-port* "rmt:send-receive, case 9, hh-dat: " (remote-hh-dat runremote) " conndat: " (remote-conndat runremote)) - (mutex-unlock! *rmt-mutex*) - (if (not (server:check-if-running *toppath*)) ;; who knows, maybe one has started up? - (server:start-and-wait *toppath*)) - (remote-conndat-set! runremote (rmt:get-connection-info *toppath*)) ;; calls client:setup which calls client:setup-http - (rmt:send-receive cmd rid params attemptnum: attemptnum)) ;; TODO: add back-off timeout as - - ;;DOT CASE10 [label="on homehost"]; - ;;DOT MUTEXLOCK -> CASE10 [label="server not required,\non homehost"]; {rank=same "case 10" CASE10}; - ;;DOT CASE10 -> "rmt:open-qry-close-locally"; - ;; all set up if get this far, dispatch the query - ((and (not (remote-force-server runremote)) - (cdr (remote-hh-dat runremote))) ;; we are on homehost - (mutex-unlock! *rmt-mutex*) - (debug:print-info 12 *default-log-port* "rmt:send-receive, case 10") - (rmt:open-qry-close-locally cmd (if rid rid 0) params)) - - ;;DOT CASE11 [label="send_receive"]; - ;;DOT MUTEXLOCK -> CASE11 [label="else"]; {rank=same "case 11" CASE11}; - ;;DOT CASE11 -> "rmt:send-receive" [label="call failed"]; - ;;DOT CASE11 -> "RESULT" [label="call succeeded"]; - ;; not on homehost, do server query - (else - ;; (mutex-unlock! *rmt-mutex*) - (debug:print-info 12 *default-log-port* "rmt:send-receive, case 9") - ;; (mutex-lock! *rmt-mutex*) - (let* ((conninfo (remote-conndat runremote)) - (dat (case (remote-transport runremote) - ((http) (condition-case ;; handling here has caused a lot of problems. However it is needed to deal with attemtped communication to servers that have gone away - (http-transport:client-api-send-receive 0 conninfo cmd params) - ((commfail)(vector #f "communications fail")) - ((exn)(vector #f "other fail" (print-call-chain))))) - (else - (debug:print 0 *default-log-port* "ERROR: transport " (remote-transport runremote) " not supported") - (exit)))) - (success (if (vector? dat) (vector-ref dat 0) #f)) - (res (if (vector? dat) (vector-ref dat 1) #f))) - (if (and (vector? conninfo) (< 5 (vector-length conninfo))) - (http-transport:server-dat-update-last-access conninfo) ;; refresh access time - (begin - (debug:print 0 *default-log-port* "INFO: Should not get here! conninfo=" conninfo) - (set! conninfo #f) - (remote-conndat-set! *runremote* #f) - (http-transport:close-connections area-dat: runremote))) - ;; (mutex-unlock! *rmt-mutex*) - (debug:print-info 13 *default-log-port* "rmt:send-receive, case 9. conninfo=" conninfo " dat=" dat " runremote = " runremote) - (mutex-unlock! *rmt-mutex*) - (if success ;; success only tells us that the transport was successful, have to examine the data to see if there was a detected issue at the other end - (if (and (vector? res) - (eq? (vector-length res) 2) - (eq? (vector-ref res 1) 'overloaded)) ;; since we are looking at the data to carry the error we'll use a fairly obtuse combo to minimise the chances of some sort of collision. - ;; this is the case where the returned data is bad or the server is overloaded and we want - ;; to ease off the queries - (let ((wait-delay (+ attemptnum (* attemptnum 10)))) - (debug:print 0 *default-log-port* "WARNING: server is overloaded. Delaying " wait-delay " seconds and trying call again.") - (mutex-lock! *rmt-mutex*) - (http-transport:close-connections area-dat: runremote) - (set! *runremote* #f) ;; force starting over - (mutex-unlock! *rmt-mutex*) - (thread-sleep! wait-delay) - (rmt:send-receive cmd rid params attemptnum: (+ attemptnum 1))) - res) ;; All good, return res - (begin - (debug:print 0 *default-log-port* "WARNING: communication failed. Trying again, try num: " attemptnum) - (mutex-lock! *rmt-mutex*) - (remote-conndat-set! runremote #f) - (http-transport:close-connections area-dat: runremote) - (remote-server-url-set! runremote #f) - (mutex-unlock! *rmt-mutex*) - (debug:print-info 12 *default-log-port* "rmt:send-receive, case 9.1") - ;; (if (not (server:check-if-running *toppath*)) - ;; (server:start-and-wait *toppath*)) - (rmt:send-receive cmd rid params attemptnum: (+ attemptnum 1))))))))) - - ;;DOT } - -;; (define (rmt:update-db-stats run-id rawcmd params duration) -;; (mutex-lock! *db-stats-mutex*) -;; (handle-exceptions -;; exn -;; (begin -;; (debug:print 0 *default-log-port* "WARNING: stats collection failed in update-db-stats") -;; (debug:print 0 *default-log-port* " message: " ((condition-property-accessor 'exn 'message) exn)) -;; (print "exn=" (condition->list exn)) -;; #f) ;; if this fails we don't care, it is just stats -;; (let* ((cmd (conc "run-id=" run-id " " (if (eq? rawcmd 'general-call) (car params) rawcmd))) -;; (stat-vec (hash-table-ref/default *db-stats* cmd #f))) -;; (if (not (vector? stat-vec)) -;; (let ((newvec (vector 0 0))) -;; (hash-table-set! *db-stats* cmd newvec) -;; (set! stat-vec newvec))) -;; (vector-set! stat-vec 0 (+ (vector-ref stat-vec 0) 1)) -;; (vector-set! stat-vec 1 (+ (vector-ref stat-vec 1) duration)))) -;; (mutex-unlock! *db-stats-mutex*)) - -(define (rmt:print-db-stats) - (let ((fmtstr "~40a~7-d~9-d~20,2-f")) ;; "~20,2-f" - (debug:print 18 *default-log-port* "DB Stats\n========") - (debug:print 18 *default-log-port* (format #f "~40a~8a~10a~10a" "Cmd" "Count" "TotTime" "Avg")) - (for-each (lambda (cmd) - (let ((cmd-dat (hash-table-ref *db-stats* cmd))) - (debug:print 18 *default-log-port* (format #f fmtstr cmd (vector-ref cmd-dat 0) (vector-ref cmd-dat 1) (/ (vector-ref cmd-dat 1)(vector-ref cmd-dat 0)))))) - (sort (hash-table-keys *db-stats*) - (lambda (a b) - (> (vector-ref (hash-table-ref *db-stats* a) 0) - (vector-ref (hash-table-ref *db-stats* b) 0))))))) - -(define (rmt:get-max-query-average run-id) - (mutex-lock! *db-stats-mutex*) - (let* ((runkey (conc "run-id=" run-id " ")) - (cmds (filter (lambda (x) - (substring-index runkey x)) - (hash-table-keys *db-stats*))) - (res (if (null? cmds) - (cons 'none 0) - (let loop ((cmd (car cmds)) - (tal (cdr cmds)) - (max-cmd (car cmds)) - (res 0)) - (let* ((cmd-dat (hash-table-ref *db-stats* cmd)) - (tot (vector-ref cmd-dat 0)) - (curravg (/ (vector-ref cmd-dat 1) (vector-ref cmd-dat 0))) ;; count is never zero by construction - (currmax (max res curravg)) - (newmax-cmd (if (> curravg res) cmd max-cmd))) - (if (null? tal) - (if (> tot 10) - (cons newmax-cmd currmax) - (cons 'none 0)) - (loop (car tal)(cdr tal) newmax-cmd currmax))))))) - (mutex-unlock! *db-stats-mutex*) - res)) - -(define (rmt:open-qry-close-locally cmd run-id params #!key (remretries 5)) - (let* ((qry-is-write (not (member cmd api:read-only-queries))) - (db-file-path (db:dbfile-path)) ;; 0)) - (dbstruct-local (db:setup #t)) ;; make-dbr:dbstruct path: dbdir local: #t))) - (read-only (not (file-write-access? db-file-path))) - (start (current-milliseconds)) - (resdat (if (not (and read-only qry-is-write)) - (let ((v (api:execute-requests dbstruct-local (vector (symbol->string cmd) params)))) - (handle-exceptions ;; there has been a long history of receiving strange errors from values returned by the client when things go wrong.. - exn ;; This is an attempt to detect that situation and recover gracefully - (begin - (debug:print0 *default-log-port* "ERROR: bad data from server " v " message: " ((condition-property-accessor 'exn 'message) exn)) - (vector #t '())) ;; should always get a vector but if something goes wrong return a dummy - (if (and (vector? v) - (> (vector-length v) 1)) - (let ((newvec (vector (vector-ref v 0)(vector-ref v 1)))) - newvec) ;; by copying the vector while inside the error handler we should force the detection of a corrupted record - (vector #t '())))) ;; we could also check that the returned types are valid - (vector #t '()))) - (success (vector-ref resdat 0)) - (res (vector-ref resdat 1)) - (duration (- (current-milliseconds) start))) - (if (and read-only qry-is-write) - (debug:print 0 *default-log-port* "ERROR: attempt to write to read-only database ignored. cmd=" cmd)) - (if (not success) - (if (> remretries 0) - (begin - (debug:print-error 0 *default-log-port* "local query failed. Trying again.") - (thread-sleep! (/ (random 5000) 1000)) ;; some random delay - (rmt:open-qry-close-locally cmd run-id params remretries: (- remretries 1))) - (begin - (debug:print-error 0 *default-log-port* "too many retries in rmt:open-qry-close-locally, giving up") - #f)) - (begin - ;; (rmt:update-db-stats run-id cmd params duration) - ;; mark this run as dirty if this was a write, the watchdog is responsible for syncing it - (if qry-is-write - (let ((start-time (current-seconds))) - (mutex-lock! *db-multi-sync-mutex*) -/ (set! *db-last-access* start-time) ;; THIS IS PROBABLY USELESS? (we are on a client) - (mutex-unlock! *db-multi-sync-mutex*))))) - res)) - -(define (rmt:send-receive-no-auto-client-setup connection-info cmd run-id params) - (let* ((run-id (if run-id run-id 0)) - (res (handle-exceptions - exn - #f - (http-transport:client-api-send-receive run-id connection-info cmd params)))) - (if (and res (vector-ref res 0)) - (vector-ref res 1) ;;; YES!! THIS IS CORRECT!! CHANGE IT HERE, THEN CHANGE rmt:send-receive ALSO!!! - #f))) - -;; ;; Wrap json library for strings (why the ports crap in the first place?) -;; (define (rmt:dat->json-str dat) -;; (with-output-to-string -;; (lambda () -;; (json-write dat)))) -;; -;; (define (rmt:json-str->dat json-str) -;; (with-input-from-string json-str -;; (lambda () -;; (json-read)))) - -;;====================================================================== -;; -;; A C T U A L A P I C A L L S -;; -;;====================================================================== - -;;====================================================================== -;; S E R V E R -;;====================================================================== - -(define (rmt:kill-server run-id) - (rmt:send-receive 'kill-server run-id (list run-id))) - -(define (rmt:start-server run-id) - (rmt:send-receive 'start-server 0 (list run-id))) - -;;====================================================================== -;; M I S C -;;====================================================================== - -(define (rmt:login run-id) - (rmt:send-receive 'login run-id (list *toppath* megatest-version *my-client-signature*))) - -;; This login does no retries under the hood - it acts a bit like a ping. -;; Deprecated for nmsg-transport. -;; -(define (rmt:login-no-auto-client-setup connection-info) - (case *transport-type* ;; run-id of 0 is just a placeholder - ((http)(rmt:send-receive-no-auto-client-setup connection-info 'login 0 (list *toppath* megatest-version *my-client-signature*))) - ;;((nmsg)(nmsg-transport:client-api-send-receive run-id connection-info 'login (list *toppath* megatest-version run-id *my-client-signature*))) - )) - -;; hand off a call to one of the db:queries statements -;; added run-id to make looking up the correct db possible -;; -(define (rmt:general-call stmtname run-id . params) - (rmt:send-receive 'general-call run-id (append (list stmtname run-id) params))) - - -;; given a hostname, return a pair of cpu load and update time representing latest intelligence from tests running on that host -(define (rmt:get-latest-host-load hostname) - (rmt:send-receive 'get-latest-host-load 0 (list hostname))) - -;; (define (rmt:sync-inmem->db run-id) -;; (rmt:send-receive 'sync-inmem->db run-id '())) - -(define (rmt:sdb-qry qry val run-id) - ;; add caching if qry is 'getid or 'getstr - (rmt:send-receive 'sdb-qry run-id (list qry val))) - -;; NOT COMPLETED -(define (rmt:runtests user run-id testpatt params) - (rmt:send-receive 'runtests run-id testpatt)) - -(define (rmt:get-run-record-ids target run keynames test-patt) - (rmt:send-receive 'get-run-record-ids #f (list target run keynames test-patt))) - -(define (rmt:get-changed-record-ids since-time) - (rmt:send-receive 'get-changed-record-ids #f (list since-time)) ) - -;;====================================================================== -;; T E S T M E T A -;;====================================================================== - -(define (rmt:get-tests-tags) - (rmt:send-receive 'get-tests-tags #f '())) - -;;====================================================================== -;; K E Y S -;;====================================================================== - -;; These require run-id because the values come from the run! -;; -(define (rmt:get-key-val-pairs run-id) - (rmt:send-receive 'get-key-val-pairs run-id (list run-id))) - -(define (rmt:get-keys) - (if *db-keys* *db-keys* - (let ((res (rmt:send-receive 'get-keys #f '()))) - (set! *db-keys* res) - res))) - -(define (rmt:get-keys-write) ;; dummy query to force server start - (let ((res (rmt:send-receive 'get-keys-write #f '()))) - (set! *db-keys* res) - res)) - -;; we don't reuse run-id's (except possibly *after* a db cleanup) so it is safe -;; to cache the resuls in a hash -;; -(define (rmt:get-key-vals run-id) - (or (hash-table-ref/default *keyvals* run-id #f) - (let ((res (rmt:send-receive 'get-key-vals #f (list run-id)))) - (hash-table-set! *keyvals* run-id res) - res))) - -(define (rmt:get-targets) - (rmt:send-receive 'get-targets #f '())) - -(define (rmt:get-target run-id) - (rmt:send-receive 'get-target run-id (list run-id))) - -(define (rmt:get-run-times runpatt targetpatt) - (rmt:send-receive 'get-run-times #f (list runpatt targetpatt ))) - - -;;====================================================================== -;; T E S T S -;;====================================================================== - -;; Just some syntatic sugar -(define (rmt:register-test run-id test-name item-path) - (rmt:general-call 'register-test run-id run-id test-name item-path)) - -(define (rmt:get-test-id run-id testname item-path) - (rmt:send-receive 'get-test-id run-id (list run-id testname item-path))) - -;; run-id is NOT used -;; -(define (rmt:get-test-info-by-id run-id test-id) - (if (number? test-id) - (rmt:send-receive 'get-test-info-by-id run-id (list run-id test-id)) - (begin - (debug:print 0 *default-log-port* "WARNING: Bad data handed to rmt:get-test-info-by-id run-id=" run-id ", test-id=" test-id) - (print-call-chain (current-error-port)) - #f))) - -(define (rmt:test-get-rundir-from-test-id run-id test-id) - (rmt:send-receive 'test-get-rundir-from-test-id run-id (list run-id test-id))) - -(define (rmt:open-test-db-by-test-id run-id test-id #!key (work-area #f)) - (let* ((test-path (if (string? work-area) - work-area - (rmt:test-get-rundir-from-test-id run-id test-id)))) - (debug:print 3 *default-log-port* "TEST PATH: " test-path) - (open-test-db test-path))) - -;; WARNING: This currently bypasses the transaction wrapped writes system -(define (rmt:test-set-state-status-by-id run-id test-id newstate newstatus newcomment) - (rmt:send-receive 'test-set-state-status-by-id run-id (list run-id test-id newstate newstatus newcomment))) - -(define (rmt:set-tests-state-status run-id testnames currstate currstatus newstate newstatus) - (rmt:send-receive 'set-tests-state-status run-id (list run-id testnames currstate currstatus newstate newstatus))) - -(define (rmt:get-tests-for-run run-id testpatt states statuses offset limit not-in sort-by sort-order qryvals last-update mode) - ;; (if (number? run-id) - (rmt:send-receive 'get-tests-for-run run-id (list run-id testpatt states statuses offset limit not-in sort-by sort-order qryvals last-update mode))) - ;; (begin - ;; (debug:print-error 0 *default-log-port* "rmt:get-tests-for-run called with bad run-id=" run-id) - ;; (print-call-chain (current-error-port)) - ;; '()))) - -;; get stuff via synchash -(define (rmt:synchash-get run-id proc synckey keynum params) - (rmt:send-receive 'synchash-get run-id (list run-id proc synckey keynum params))) - -(define (rmt:get-tests-for-run-mindata run-id testpatt states status not-in) - (rmt:send-receive 'get-tests-for-run-mindata run-id (list run-id testpatt states status not-in))) - -;; IDEA: Threadify these - they spend a lot of time waiting ... -;; -(define (rmt:get-tests-for-runs-mindata run-ids testpatt states status not-in) - (let ((multi-run-mutex (make-mutex)) - (run-id-list (if run-ids - run-ids - (rmt:get-all-run-ids))) - (result '())) - (if (null? run-id-list) - '() - (let loop ((hed (car run-id-list)) - (tal (cdr run-id-list)) - (threads '())) - (if (> (length threads) 5) - (loop hed tal (filter (lambda (th)(not (member (thread-state th) '(terminated dead)))) threads)) - (let* ((newthread (make-thread - (lambda () - (let ((res (rmt:send-receive 'get-tests-for-run-mindata hed (list hed testpatt states status not-in)))) - (if (list? res) - (begin - (mutex-lock! multi-run-mutex) - (set! result (append result res)) - (mutex-unlock! multi-run-mutex)) - (debug:print-error 0 *default-log-port* "get-tests-for-run-mindata failed for run-id " hed ", testpatt " testpatt ", states " states ", status " status ", not-in " not-in)))) - (conc "multi-run-thread for run-id " hed))) - (newthreads (cons newthread threads))) - (thread-start! newthread) - (thread-sleep! 0.05) ;; give that thread some time to start - (if (null? tal) - newthreads - (loop (car tal)(cdr tal) newthreads)))))) - result)) - -;; ;; IDEA: Threadify these - they spend a lot of time waiting ... -;; ;; -;; (define (rmt:get-tests-for-runs-mindata run-ids testpatt states status not-in) -;; (let ((run-id-list (if run-ids -;; run-ids -;; (rmt:get-all-run-ids)))) -;; (apply append (map (lambda (run-id) -;; (rmt:send-receive 'get-tests-for-run-mindata run-id (list run-ids testpatt states status not-in))) -;; run-id-list)))) - -(define (rmt:delete-test-records run-id test-id) - (rmt:send-receive 'delete-test-records run-id (list run-id test-id))) - -;; This is not needed as test steps are deleted on test delete call -;; -;; (define (rmt:delete-test-step-records run-id test-id) -;; (rmt:send-receive 'delete-test-step-records run-id (list run-id test-id))) - -(define (rmt:test-set-state-status run-id test-id state status msg) - (rmt:send-receive 'test-set-state-status run-id (list run-id test-id state status msg))) - -(define (rmt:test-toplevel-num-items run-id test-name) - (rmt:send-receive 'test-toplevel-num-items run-id (list run-id test-name))) - -;; (define (rmt:get-previous-test-run-record run-id test-name item-path) -;; (rmt:send-receive 'get-previous-test-run-record run-id (list run-id test-name item-path))) - -(define (rmt:get-matching-previous-test-run-records run-id test-name item-path) - (rmt:send-receive 'get-matching-previous-test-run-records run-id (list run-id test-name item-path))) - -(define (rmt:test-get-logfile-info run-id test-name) - (rmt:send-receive 'test-get-logfile-info run-id (list run-id test-name))) - -(define (rmt:test-get-records-for-index-file run-id test-name) - (rmt:send-receive 'test-get-records-for-index-file run-id (list run-id test-name))) - -(define (rmt:get-testinfo-state-status run-id test-id) - (rmt:send-receive 'get-testinfo-state-status run-id (list run-id test-id))) - -(define (rmt:test-set-log! run-id test-id logf) - (if (string? logf)(rmt:general-call 'test-set-log run-id logf test-id))) - -(define (rmt:test-set-top-process-pid run-id test-id pid) - (rmt:send-receive 'test-set-top-process-pid run-id (list run-id test-id pid))) - -(define (rmt:test-get-top-process-pid run-id test-id) - (rmt:send-receive 'test-get-top-process-pid run-id (list run-id test-id))) - -(define (rmt:get-run-ids-matching-target keynames target res runname testpatt statepatt statuspatt) - (rmt:send-receive 'get-run-ids-matching-target #f (list keynames target res runname testpatt statepatt statuspatt))) - -;; NOTE: This will open and access ALL run databases. -;; -(define (rmt:test-get-paths-matching-keynames-target-new keynames target res testpatt statepatt statuspatt runname) - (let ((run-ids (rmt:get-run-ids-matching-target keynames target res runname testpatt statepatt statuspatt))) - (apply append - (map (lambda (run-id) - (rmt:send-receive 'test-get-paths-matching-keynames-target-new run-id (list run-id keynames target res testpatt statepatt statuspatt runname))) - run-ids)))) - -;; (define (rmt:get-run-ids-matching keynames target res) -;; (rmt:send-receive #f 'get-run-ids-matching (list keynames target res))) - -(define (rmt:get-prereqs-not-met run-id waitons ref-test-name ref-item-path #!key (mode '(normal))(itemmaps #f)) - (rmt:send-receive 'get-prereqs-not-met run-id (list run-id waitons ref-test-name ref-item-path mode itemmaps))) - -(define (rmt:get-count-tests-running-for-run-id run-id) - (rmt:send-receive 'get-count-tests-running-for-run-id run-id (list run-id))) - -;; Statistical queries - -(define (rmt:get-count-tests-running run-id) - (rmt:send-receive 'get-count-tests-running run-id (list run-id))) - -(define (rmt:get-count-tests-running-for-testname run-id testname) - (rmt:send-receive 'get-count-tests-running-for-testname run-id (list run-id testname))) - -(define (rmt:get-count-tests-running-in-jobgroup run-id jobgroup) - (rmt:send-receive 'get-count-tests-running-in-jobgroup run-id (list run-id jobgroup))) - -;; state and status are extra hints not usually used in the calculation -;; -(define (rmt:set-state-status-and-roll-up-items run-id test-name item-path state status comment) - (rmt:send-receive 'set-state-status-and-roll-up-items run-id (list run-id test-name item-path state status comment))) - -(define (rmt:update-pass-fail-counts run-id test-name) - (rmt:general-call 'update-pass-fail-counts run-id test-name test-name test-name)) - -(define (rmt:top-test-set-per-pf-counts run-id test-name) - (rmt:send-receive 'top-test-set-per-pf-counts run-id (list run-id test-name))) - -(define (rmt:get-raw-run-stats run-id) - (rmt:send-receive 'get-raw-run-stats run-id (list run-id))) - -(define (rmt:get-test-times runname target) - (rmt:send-receive 'get-test-times #f (list runname target ))) - -;;====================================================================== -;; R U N S -;;====================================================================== - -(define (rmt:get-run-info run-id) - (rmt:send-receive 'get-run-info run-id (list run-id))) - -(define (rmt:get-num-runs runpatt) - (rmt:send-receive 'get-num-runs #f (list runpatt))) - -(define (rmt:get-runs-cnt-by-patt runpatt targetpatt keys) - (rmt:send-receive 'get-runs-cnt-by-patt #f (list runpatt targetpatt keys))) - -;; Use the special run-id == #f scenario here since there is no run yet -(define (rmt:register-run keyvals runname state status user contour) - (rmt:send-receive 'register-run #f (list keyvals runname state status user contour))) - -(define (rmt:get-run-name-from-id run-id) - (rmt:send-receive 'get-run-name-from-id run-id (list run-id))) - -(define (rmt:delete-run run-id) - (rmt:send-receive 'delete-run run-id (list run-id))) - -(define (rmt:update-run-stats run-id stats) - (rmt:send-receive 'update-run-stats #f (list run-id stats))) - -(define (rmt:delete-old-deleted-test-records) - (rmt:send-receive 'delete-old-deleted-test-records #f '())) - -(define (rmt:get-runs runpatt count offset keypatts) - (rmt:send-receive 'get-runs #f (list runpatt count offset keypatts))) - -(define (rmt:simple-get-runs runpatt count offset target) - (rmt:send-receive 'simple-get-runs #f (list runpatt count offset target))) - -(define (rmt:get-all-run-ids) - (rmt:send-receive 'get-all-run-ids #f '())) - -(define (rmt:get-prev-run-ids run-id) - (rmt:send-receive 'get-prev-run-ids #f (list run-id))) - -(define (rmt:lock/unlock-run run-id lock unlock user) - (rmt:send-receive 'lock/unlock-run #f (list run-id lock unlock user))) - -;; set/get status -(define (rmt:get-run-status run-id) - (rmt:send-receive 'get-run-status #f (list run-id))) - -(define (rmt:set-run-status run-id run-status #!key (msg #f)) - (rmt:send-receive 'set-run-status #f (list run-id run-status msg))) - -(define (rmt:update-run-event_time run-id) - (rmt:send-receive 'update-run-event_time #f (list run-id))) - -(define (rmt:get-runs-by-patt keys runnamepatt targpatt offset limit fields last-runs-update #!key (sort-order "asc")) ;; fields of #f uses default - (rmt:send-receive 'get-runs-by-patt #f (list keys runnamepatt targpatt offset limit fields last-runs-update sort-order))) - -(define (rmt:find-and-mark-incomplete run-id ovr-deadtime) - ;; (if (rmt:send-receive 'have-incompletes? run-id (list run-id ovr-deadtime)) - (rmt:send-receive 'mark-incomplete run-id (list run-id ovr-deadtime))) ;; ) - -(define (rmt:get-main-run-stats run-id) - (rmt:send-receive 'get-main-run-stats #f (list run-id))) - -(define (rmt:get-var varname) - (rmt:send-receive 'get-var #f (list varname))) - -(define (rmt:del-var varname) - (rmt:send-receive 'del-var #f (list varname))) - -(define (rmt:set-var varname value) - (rmt:send-receive 'set-var #f (list varname value))) - -;;====================================================================== -;; M U L T I R U N Q U E R I E S -;;====================================================================== - -;; Need to move this to multi-run section and make associated changes -(define (rmt:find-and-mark-incomplete-all-runs #!key (ovr-deadtime #f)) - (let ((run-ids (rmt:get-all-run-ids))) - (for-each (lambda (run-id) - (rmt:find-and-mark-incomplete run-id ovr-deadtime)) - run-ids))) - -;; get the previous record for when this test was run where all keys match but runname -;; returns #f if no such test found, returns a single test record if found -;; -;; Run this at the client end since we have to connect to multiple run-id dbs -;; -(define (rmt:get-previous-test-run-record run-id test-name item-path) - (let* ((keyvals (rmt:get-key-val-pairs run-id)) - (keys (rmt:get-keys)) - (selstr (string-intersperse keys ",")) - (qrystr (string-intersperse (map (lambda (x)(conc x "=?")) keys) " AND "))) - (if (not keyvals) - #f - (let ((prev-run-ids (rmt:get-prev-run-ids run-id))) - ;; for each run starting with the most recent look to see if there is a matching test - ;; if found then return that matching test record - (debug:print 4 *default-log-port* "selstr: " selstr ", qrystr: " qrystr ", keyvals: " keyvals ", previous run ids found: " prev-run-ids) - (if (null? prev-run-ids) #f - (let loop ((hed (car prev-run-ids)) - (tal (cdr prev-run-ids))) - (let ((results (rmt:get-tests-for-run hed (conc test-name "/" item-path) '() '() ;; run-id testpatt states statuses - #f #f #f ;; offset limit not-in hide/not-hide - #f #f #f #f 'normal))) ;; sort-by sort-order qryvals last-update mode - (debug:print 4 *default-log-port* "Got tests for run-id " run-id ", test-name " test-name ", item-path " item-path ": " results) - (if (and (null? results) - (not (null? tal))) - (loop (car tal)(cdr tal)) - (if (null? results) #f - (car results)))))))))) - -(define (rmt:get-run-stats) - (rmt:send-receive 'get-run-stats #f '())) - -;;====================================================================== -;; S T E P S -;;====================================================================== - -;; Getting steps is more complicated. -;; -;; If given work area -;; 1. Find the testdat.db file -;; 2. Open the testdat.db file and do the query -;; If not given the work area -;; 1. Do a remote call to get the test path -;; 2. Continue as above -;; -;;(define (rmt:get-steps-for-test run-id test-id) -;; (rmt:send-receive 'get-steps-data run-id (list test-id))) - -(define (rmt:teststep-set-status! run-id test-id teststep-name state-in status-in comment logfile) - (let* ((state (items:check-valid-items "state" state-in)) - (status (items:check-valid-items "status" status-in))) - (if (or (not state)(not status)) - (debug:print 3 *default-log-port* "WARNING: Invalid " (if status "status" "state") - " value \"" (if status state-in status-in) "\", update your validvalues section in megatest.config")) - (rmt:send-receive 'teststep-set-status! run-id (list run-id test-id teststep-name state-in status-in comment logfile)))) - -(define (rmt:get-steps-for-test run-id test-id) - (rmt:send-receive 'get-steps-for-test run-id (list run-id test-id))) - -(define (rmt:get-steps-info-by-id test-step-id) - (rmt:send-receive 'get-steps-info-by-id #f (list test-step-id))) - -;;====================================================================== -;; T E S T D A T A -;;====================================================================== - -(define (rmt:read-test-data run-id test-id categorypatt #!key (work-area #f)) - (rmt:send-receive 'read-test-data run-id (list run-id test-id categorypatt))) -(define (rmt:read-test-data* run-id test-id categorypatt varpatt #!key (work-area #f)) - (rmt:send-receive 'read-test-data* run-id (list run-id test-id categorypatt varpatt))) - -(define (rmt:get-data-info-by-id test-data-id) - (rmt:send-receive 'get-data-info-by-id #f (list test-data-id))) - -(define (rmt:testmeta-add-record testname) - (rmt:send-receive 'testmeta-add-record #f (list testname))) - -(define (rmt:testmeta-get-record testname) - (rmt:send-receive 'testmeta-get-record #f (list testname))) - -(define (rmt:testmeta-update-field test-name fld val) - (rmt:send-receive 'testmeta-update-field #f (list test-name fld val))) - -(define (rmt:test-data-rollup run-id test-id status) - (rmt:send-receive 'test-data-rollup run-id (list run-id test-id status))) - -(define (rmt:csv->test-data run-id test-id csvdata) - (rmt:send-receive 'csv->test-data run-id (list run-id test-id csvdata))) - -;;====================================================================== -;; T A S K S -;;====================================================================== - -(define (rmt:tasks-find-task-queue-records target run-name test-patt state-patt action-patt) - (rmt:send-receive 'find-task-queue-records #f (list target run-name test-patt state-patt action-patt))) - -(define (rmt:tasks-add action owner target runname testpatt params) - (rmt:send-receive 'tasks-add #f (list action owner target runname testpatt params))) - -(define (rmt:tasks-set-state-given-param-key param-key new-state) - (rmt:send-receive 'tasks-set-state-given-param-key #f (list param-key new-state))) - -(define (rmt:tasks-get-last target runname) - (rmt:send-receive 'tasks-get-last #f (list target runname))) - -;;====================================================================== -;; N O S Y N C D B -;;====================================================================== - -(define (rmt:no-sync-set var val) - (rmt:send-receive 'no-sync-set #f `(,var ,val))) - -(define (rmt:no-sync-get/default var default) - (rmt:send-receive 'no-sync-get/default #f `(,var ,default))) - -(define (rmt:no-sync-del! var) - (rmt:send-receive 'no-sync-del! #f `(,var))) - -(define (rmt:no-sync-get-lock keyname) - (rmt:send-receive 'no-sync-get-lock #f `(,keyname))) - -;;====================================================================== -;; A R C H I V E S -;;====================================================================== - -(define (rmt:archive-get-allocations testname itempath dneeded) - (rmt:send-receive 'archive-get-allocations #f (list testname itempath dneeded))) - -(define (rmt:archive-register-block-name bdisk-id archive-path) - (rmt:send-receive 'archive-register-block-name #f (list bdisk-id archive-path))) - -(define (rmt:archive-allocate-testsuite/area-to-block block-id testsuite-name areakey) - (rmt:send-receive 'archive-allocate-test-to-block #f (list block-id testsuite-name areakey))) - -(define (rmt:archive-register-disk bdisk-name bdisk-path df) - (rmt:send-receive 'archive-register-disk #f (list bdisk-name bdisk-path df))) - -(define (rmt:test-set-archive-block-id run-id test-id archive-block-id) - (rmt:send-receive 'test-set-archive-block-id run-id (list run-id test-id archive-block-id))) - -(define (rmt:test-get-archive-block-info archive-block-id) - (rmt:send-receive 'test-get-archive-block-info #f (list archive-block-id))) +(use (prefix pkts pkts:) srfi-18) + +(defstruct cmdrec + cmd + (host #f) + (run-ids #f) + params) + +;; call cmd on remote host (#f for any host) +;; +;; example: (rmt:run 'get-runs target run-name test-patt state status) +;; +(define (rmt:run cmd . params) + (let ((server (rmt:get-server cmdrec))) ;; look up server + #f)) + +(define (rmt:get-connection-info . args) + #t + (print "Got here: rmt:get-connection-info")) +(define (rmt:send-receive . args) + #t + (print "Got here: rmt:send-receive")) +(define (rmt:print-db-stats . args) + #t + (print "Got here: rmt:print-db-stats")) +(define (rmt:get-max-query-average . args) + #t + (print "Got here: rmt:get-max-query-average")) +(define (rmt:open-qry-close-locally . args) + #t + (print "Got here: rmt:open-qry-close-locally")) +(define (rmt:send-receive-no-auto-client-setup . args) + #t + (print "Got here: rmt:send-receive-no-auto-client-setup")) +(define (rmt:kill-server . args) + #t + (print "Got here: rmt:kill-server")) +(define (rmt:start-server . args) + #t + (print "Got here: rmt:start-server")) +(define (rmt:login . args) + #t + (print "Got here: rmt:login")) +(define (rmt:login-no-auto-client-setup . args) + #t + (print "Got here: rmt:login-no-auto-client-setup")) +(define (rmt:general-call . args) + #t + (print "Got here: rmt:general-call")) +(define (rmt:get-latest-host-load . args) + #t + (print "Got here: rmt:get-latest-host-load")) +(define (rmt:sdb-qry . args) + #t + (print "Got here: rmt:sdb-qry")) +(define (rmt:runtests . args) + #t + (print "Got here: rmt:runtests")) +(define (rmt:get-run-record-ids . args) + #t + (print "Got here: rmt:get-run-record-ids")) +(define (rmt:get-changed-record-ids . args) + #t + (print "Got here: rmt:get-changed-record-ids")) +(define (rmt:get-tests-tags . args) + #t + (print "Got here: rmt:get-tests-tags")) +(define (rmt:get-key-val-pairs . args) + #t + (print "Got here: rmt:get-key-val-pairs")) +(define (rmt:get-keys . args) + #t + (print "Got here: rmt:get-keys")) +(define (rmt:get-keys-write . args) + #t + (print "Got here: rmt:get-keys-write")) +(define (rmt:get-key-vals . args) + #t + (print "Got here: rmt:get-key-vals")) +(define (rmt:get-targets . args) + #t + (print "Got here: rmt:get-targets")) +(define (rmt:get-target . args) + #t + (print "Got here: rmt:get-target")) +(define (rmt:get-run-times . args) + #t + (print "Got here: rmt:get-run-times")) +(define (rmt:register-test . args) + #t + (print "Got here: rmt:register-test")) +(define (rmt:get-test-id . args) + #t + (print "Got here: rmt:get-test-id")) +(define (rmt:get-test-info-by-id . args) + #t + (print "Got here: rmt:get-test-info-by-id")) +(define (rmt:test-get-rundir-from-test-id . args) + #t + (print "Got here: rmt:test-get-rundir-from-test-id")) +(define (rmt:open-test-db-by-test-id . args) + #t + (print "Got here: rmt:open-test-db-by-test-id")) +(define (rmt:test-set-state-status-by-id . args) + #t + (print "Got here: rmt:test-set-state-status-by-id")) +(define (rmt:set-tests-state-status . args) + #t + (print "Got here: rmt:set-tests-state-status")) +(define (rmt:get-tests-for-run . args) + #t + (print "Got here: rmt:get-tests-for-run")) +(define (rmt:synchash-get . args) + #t + (print "Got here: rmt:synchash-get")) +(define (rmt:get-tests-for-run-mindata . args) + #t + (print "Got here: rmt:get-tests-for-run-mindata")) +(define (rmt:get-tests-for-runs-mindata . args) + #t + (print "Got here: rmt:get-tests-for-runs-mindata")) +(define (rmt:delete-test-records . args) + #t + (print "Got here: rmt:delete-test-records")) +(define (rmt:test-set-state-status . args) + #t + (print "Got here: rmt:test-set-state-status")) +(define (rmt:test-toplevel-num-items . args) + #t + (print "Got here: rmt:test-toplevel-num-items")) +(define (rmt:get-matching-previous-test-run-records . args) + #t + (print "Got here: rmt:get-matching-previous-test-run-records")) +(define (rmt:test-get-logfile-info . args) + #t + (print "Got here: rmt:test-get-logfile-info")) +(define (rmt:test-get-records-for-index-file . args) + #t + (print "Got here: rmt:test-get-records-for-index-file")) +(define (rmt:get-testinfo-state-status . args) + #t + (print "Got here: rmt:get-testinfo-state-status")) +(define (rmt:test-set-log! . args) + #t + (print "Got here: rmt:test-set-log!")) +(define (rmt:test-set-top-process-pid . args) + #t + (print "Got here: rmt:test-set-top-process-pid")) +(define (rmt:test-get-top-process-pid . args) + #t + (print "Got here: rmt:test-get-top-process-pid")) +(define (rmt:get-run-ids-matching-target . args) + #t + (print "Got here: rmt:get-run-ids-matching-target")) +(define (rmt:test-get-paths-matching-keynames-target-new . args) + #t + (print "Got here: rmt:test-get-paths-matching-keynames-target-new")) +(define (rmt:get-prereqs-not-met . args) + #t + (print "Got here: rmt:get-prereqs-not-met")) +(define (rmt:get-count-tests-running-for-run-id . args) + #t + (print "Got here: rmt:get-count-tests-running-for-run-id")) +(define (rmt:get-count-tests-running . args) + #t + (print "Got here: rmt:get-count-tests-running")) +(define (rmt:get-count-tests-running-for-testname . args) + #t + (print "Got here: rmt:get-count-tests-running-for-testname")) +(define (rmt:get-count-tests-running-in-jobgroup . args) + #t + (print "Got here: rmt:get-count-tests-running-in-jobgroup")) +(define (rmt:set-state-status-and-roll-up-items . args) + #t + (print "Got here: rmt:set-state-status-and-roll-up-items")) +(define (rmt:update-pass-fail-counts . args) + #t + (print "Got here: rmt:update-pass-fail-counts")) +(define (rmt:top-test-set-per-pf-counts . args) + #t + (print "Got here: rmt:top-test-set-per-pf-counts")) +(define (rmt:get-raw-run-stats . args) + #t + (print "Got here: rmt:get-raw-run-stats")) +(define (rmt:get-test-times . args) + #t + (print "Got here: rmt:get-test-times")) +(define (rmt:get-run-info . args) + #t + (print "Got here: rmt:get-run-info")) +(define (rmt:get-num-runs . args) + #t + (print "Got here: rmt:get-num-runs")) +(define (rmt:get-runs-cnt-by-patt . args) + #t + (print "Got here: rmt:get-runs-cnt-by-patt")) +(define (rmt:register-run . args) + #t + (print "Got here: rmt:register-run")) +(define (rmt:get-run-name-from-id . args) + #t + (print "Got here: rmt:get-run-name-from-id")) +(define (rmt:delete-run . args) + #t + (print "Got here: rmt:delete-run")) +(define (rmt:update-run-stats . args) + #t + (print "Got here: rmt:update-run-stats")) +(define (rmt:delete-old-deleted-test-records . args) + #t + (print "Got here: rmt:delete-old-deleted-test-records")) +(define (rmt:get-runs . args) + #t + (print "Got here: rmt:get-runs")) +(define (rmt:simple-get-runs . args) + #t + (print "Got here: rmt:simple-get-runs")) +(define (rmt:get-all-run-ids . args) + #t + (print "Got here: rmt:get-all-run-ids")) +(define (rmt:get-prev-run-ids . args) + #t + (print "Got here: rmt:get-prev-run-ids")) +(define (rmt:lock/unlock-run . args) + #t + (print "Got here: rmt:lock/unlock-run")) +(define (rmt:get-run-status . args) + #t + (print "Got here: rmt:get-run-status")) +(define (rmt:set-run-status . args) + #t + (print "Got here: rmt:set-run-status")) +(define (rmt:update-run-event_time . args) + #t + (print "Got here: rmt:update-run-event_time")) +(define (rmt:get-runs-by-patt . args) + #t + (print "Got here: rmt:get-runs-by-patt")) +(define (rmt:find-and-mark-incomplete . args) + #t + (print "Got here: rmt:find-and-mark-incomplete")) +(define (rmt:get-main-run-stats . args) + #t + (print "Got here: rmt:get-main-run-stats")) +(define (rmt:get-var . args) + #t + (print "Got here: rmt:get-var")) +(define (rmt:del-var . args) + #t + (print "Got here: rmt:del-var")) +(define (rmt:set-var . args) + #t + (print "Got here: rmt:set-var")) +(define (rmt:find-and-mark-incomplete-all-runs . args) + #t + (print "Got here: rmt:find-and-mark-incomplete-all-runs")) +(define (rmt:get-previous-test-run-record . args) + #t + (print "Got here: rmt:get-previous-test-run-record")) +(define (rmt:get-run-stats . args) + #t + (print "Got here: rmt:get-run-stats")) +(define (rmt:teststep-set-status! . args) + #t + (print "Got here: rmt:teststep-set-status!")) +(define (rmt:get-steps-for-test . args) + #t + (print "Got here: rmt:get-steps-for-test")) +(define (rmt:get-steps-info-by-id . args) + #t + (print "Got here: rmt:get-steps-info-by-id")) +(define (rmt:read-test-data . args) + #t + (print "Got here: rmt:read-test-data")) +(define (rmt:read-test-data* . args) + #t + (print "Got here: rmt:read-test-data*")) +(define (rmt:get-data-info-by-id . args) + #t + (print "Got here: rmt:get-data-info-by-id")) +(define (rmt:testmeta-add-record . args) + #t + (print "Got here: rmt:testmeta-add-record")) +(define (rmt:testmeta-get-record . args) + #t + (print "Got here: rmt:testmeta-get-record")) +(define (rmt:testmeta-update-field . args) + #t + (print "Got here: rmt:testmeta-update-field")) +(define (rmt:test-data-rollup . args) + #t + (print "Got here: rmt:test-data-rollup")) +(define (rmt:csv->test-data . args) + #t + (print "Got here: rmt:csv->test-data")) +(define (rmt:tasks-find-task-queue-records . args) + #t + (print "Got here: rmt:tasks-find-task-queue-records")) +(define (rmt:tasks-add . args) + #t + (print "Got here: rmt:tasks-add")) +(define (rmt:tasks-set-state-given-param-key . args) + #t + (print "Got here: rmt:tasks-set-state-given-param-key")) +(define (rmt:tasks-get-last . args) + #t + (print "Got here: rmt:tasks-get-last")) +(define (rmt:no-sync-set . args) + #t + (print "Got here: rmt:no-sync-set")) +(define (rmt:no-sync-get/default . args) + #t + (print "Got here: rmt:no-sync-get/default")) +(define (rmt:no-sync-del! . args) + #t + (print "Got here: rmt:no-sync-del!")) +(define (rmt:no-sync-get-lock . args) + #t + (print "Got here: rmt:no-sync-get-lock")) +(define (rmt:archive-get-allocations . args) + #t + (print "Got here: rmt:archive-get-allocations")) +(define (rmt:archive-register-block-name . args) + #t + (print "Got here: rmt:archive-register-block-name")) +(define (rmt:archive-allocate-testsuite/area-to-block . args) + #t + (print "Got here: rmt:archive-allocate-testsuite/area-to-block")) +(define (rmt:archive-register-disk . args) + #t + (print "Got here: rmt:archive-register-disk")) +(define (rmt:test-set-archive-block-id . args) + #t + (print "Got here: rmt:test-set-archive-block-id")) +(define (rmt:test-get-archive-block-info . args) + #t + (print "Got here: rmt:test-get-archive-block-info")) DELETED rpc-transport.scm Index: rpc-transport.scm ================================================================== --- rpc-transport.scm +++ /dev/null @@ -1,237 +0,0 @@ - -;; Copyright 2006-2012, Matthew Welland. -;; -;; This file is part of Megatest. -;; -;; Megatest is free software: you can redistribute it and/or modify -;; it under the terms of the GNU General Public License as published by -;; the Free Software Foundation, either version 3 of the License, or -;; (at your option) any later version. -;; -;; Megatest is distributed in the hope that it will be useful, -;; but WITHOUT ANY WARRANTY; without even the implied warranty of -;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the -;; GNU General Public License for more details. -;; -;; You should have received a copy of the GNU General Public License -;; along with Megatest. If not, see . -;; - -(require-extension (srfi 18) extras tcp s11n rpc) -(import (prefix rpc rpc:)) - -(use sqlite3 srfi-1 posix regex regex-case srfi-69 hostinfo md5 message-digest) -(import (prefix sqlite3 sqlite3:)) - -(declare (unit rpc-transport)) - -(declare (uses common)) -(declare (uses db)) -(declare (uses tests)) -(declare (uses tasks)) ;; tasks are where stuff is maintained about what is running. - -(include "common_records.scm") -(include "db_records.scm") - -;; procstr is the name of the procedure to be called as a string -(define (rpc-transport:autoremote procstr params) - (handle-exceptions - exn - (begin - (debug:print 1 *default-log-port* "Remote failed for " proc " " params) - (apply (eval (string->symbol procstr)) params)) - ;; (if *runremote* - ;; (apply (eval (string->symbol (conc "remote:" procstr))) params) - (apply (eval (string->symbol procstr)) params))) - -;; all routes though here end in exit ... -;; -;; start_server? -;; -(define (rpc-transport:launch run-id) - (let* ((tdbdat (tasks:open-db))) - (BB> "rpc-transport:launch fired for run-id="run-id) - (set! *run-id* run-id) - (if (args:get-arg "-daemonize") - (daemon:ize)) - (if (server:check-if-running run-id) - (begin - (debug:print 0 *default-log-port* "INFO: Server for run-id " run-id " already running") - (exit 0))) - (let loop ((server-id (tasks:server-lock-slot (db:delay-if-busy tdbdat) run-id)) - (remtries 4)) - (if (not server-id) - (if (> remtries 0) - (begin - (thread-sleep! 2) - (loop (tasks:server-lock-slot (db:delay-if-busy tdbdat) run-id) - (- remtries 1))) - (begin - ;; since we didn't get the server lock we are going to clean up and bail out - (debug:print-info 2 *default-log-port* "INFO: server pid=" (current-process-id) ", hostname=" (get-host-name) " not starting due to other candidates ahead in start queue") - (tasks:server-delete-records-for-this-pid (db:delay-if-busy tdbdat) " rpc-transport:launch"))) - (begin - (rpc-transport:run (if (args:get-arg "-server")(args:get-arg "-server") "-") run-id server-id) - (exit)))))) - -(define (rpc-transport:run hostn run-id server-id) - (debug:print 2 *default-log-port* "Attempting to start the rpc server ...") - ;; (trace rpc:publish-procedure!) - - (rpc:publish-procedure! 'server:login server:login) - (rpc:publish-procedure! 'testing (lambda () "Just testing")) - - (let* ((db #f) - (hostname (get-host-name)) - (ipaddrstr (let ((ipstr (if (string=? "-" hostn) - ;; (string-intersperse (map number->string (u8vector->list (hostname->ip hostname))) ".") - (server:get-best-guess-address hostname) - #f))) - (if ipstr ipstr hostn))) ;; hostname))) - (start-port (open-run-close tasks:server-get-next-port tasks:open-db)) - (link-tree-path (configf:lookup *configdat* "setup" "linktree")) - (rpc:listener (rpc-transport:find-free-port-and-open (rpc:default-server-port))) - (th1 (make-thread - (lambda () - ((rpc:make-server rpc:listener) #t)) - "rpc:server")) - ;; (cute (rpc:make-server rpc:listener) "rpc:server") - ;; 'rpc:server)) - (hostname (if (string=? "-" hostn) - (get-host-name) - hostn)) - (ipaddrstr (if (string=? "-" hostn) - (server:get-best-guess-address hostname) ;; (string-intersperse (map number->string (u8vector->list (hostname->ip hostname))) ".") - #f)) - (portnum (rpc:default-server-port)) - (host:port (conc (if ipaddrstr ipaddrstr hostname) ":" portnum)) - (tdb (tasks:open-db))) - (thread-start! th1) - (set! db *dbstruct-db*) - (open-run-close tasks:server-set-interface-port - tasks:open-db - server-id - ipaddrstr portnum) - (debug:print 0 *default-log-port* "Server started on " host:port) - - ;; (trace rpc:publish-procedure!) - ;; (rpc:publish-procedure! 'server:login server:login) - ;; (rpc:publish-procedure! 'testing (lambda () "Just testing")) - - ;;====================================================================== - ;; ;; end of publish-procedure section - ;;====================================================================== - ;; - (on-exit (lambda () - (open-run-close tasks:server-set-state! tasks:open-db server-id "stopped"))) - - (set! *rpc:listener* rpc:listener) - (tasks:server-set-state! tdb server-id "running") - (set! *dbstruct-db* (db:setup run-id)) - ;; if none running or if > 20 seconds since - ;; server last used then start shutdown - (let loop ((count 0)) - (thread-sleep! 5) ;; no need to do this very often - (let ((numrunning -1)) ;; (db:get-count-tests-running db))) - (if (or (> numrunning 0) - (> (+ *db-last-access* 60)(current-seconds))) - (begin - (debug:print-info 0 *default-log-port* "Server continuing, tests running: " numrunning ", seconds since last db access: " (- (current-seconds) *db-last-access*)) - (loop (+ 1 count))) - (begin - (debug:print-info 0 *default-log-port* "Starting to shutdown the server side") - (open-run-close tasks:server-delete-record tasks:open-db server-id " rpc-transport:try-start-server stop") - (thread-sleep! 10) - (debug:print-info 0 *default-log-port* "Max cached queries was " *max-cache-size*) - (debug:print-info 0 *default-log-port* "Server shutdown complete. Exiting") - )))))) - -(define (rpc-transport:find-free-port-and-open port) - (handle-exceptions - exn - (begin - (print "Failed to bind to port " (rpc:default-server-port) ", trying next port") - (rpc-transport:find-free-port-and-open (+ port 1))) - (rpc:default-server-port port) - (tcp-read-timeout 240000) - (tcp-listen (rpc:default-server-port) 10000))) - -(define (rpc-transport:ping run-id host port) - (handle-exceptions - exn - (begin - (print "SERVER_NOT_FOUND") - (exit 1)) - (let ((login-res ((rpc:procedure 'server:login host port) *toppath*))) - (if (and (list? login-res) - (car login-res)) - (begin - (print "LOGIN_OK") - (exit 0)) - (begin - (print "LOGIN_FAILED") - (exit 1)))))) - -(define (rpc-transport:client-setup run-id #!key (remtries 10)) - (if *runremote* - (begin - (debug:print-error 0 *default-log-port* "Attempt to connect to server but already connected") - #f) - (let* ((host-info (hash-table-ref/default *runremote* run-id #f))) ;; (open-run-close db:get-var #f "SERVER")) - (if host-info - (let ((iface (car host-info)) - (port (cadr host-info)) - (ping-res ((rpc:procedure 'server:login host port) *toppath*))) - (if ping-res - (let ((server-dat (list iface port #f #f #f))) - (hash-table-set! *runremote* run-id server-dat) - server-dat) - (begin - (server:try-running *toppath*) - (thread-sleep! 2) - (rpc-transport:client-setup run-id (- remtries 1))))) - (let* ((server-db-info (open-run-close tasks:get-server tasks:open-db run-id))) - (debug:print-info 0 *default-log-port* "client:setup server-dat=" server-dat ", remaining-tries=" remaining-tries) - (if server-db-info - (let* ((iface (tasks:hostinfo-get-interface server-db-info)) - (port (tasks:hostinfo-get-port server-db-info)) - (server-dat (list iface port #f #f #f)) - (ping-res ((rpc:procedure 'server:login host port) *toppath*))) - (if start-res - (begin - (hash-table-set! *runremote* run-id server-dat) - server-dat) - (begin - (server:try-running *toppath*) - (thread-sleep! 2) - (rpc-transport:client-setup run-id (- remtries 1))))) - (begin - (server:try-running *toppath*) - (thread-sleep! 2) - (rpc-transport:client-setup run-id (- remtries 1))))))))) -;; -;; (port (if (and hostinfo (> (length hostdat) 1))(cadr hostdat) #f))) -;; (if (and port -;; (string->number port)) -;; (let ((portn (string->number port))) -;; (debug:print-info 2 *default-log-port* "Setting up to connect to host " host ":" port) -;; (handle-exceptions -;; exn -;; (begin -;; (debug:print-error 0 *default-log-port* "Failed to open a connection to the server at host: " host " port: " port) -;; (debug:print 0 *default-log-port* " EXCEPTION: " ((condition-property-accessor 'exn 'message) exn)) -;; ;; (open-run-close -;; ;; (lambda (db . param) -;; ;; (sqlite3:execute db "DELETE FROM metadat WHERE var='SERVER'")) -;; ;; #f) -;; (set! *runremote* #f)) -;; (if (and (not (args:get-arg "-server")) ;; no point in the server using the server using the server -;; ((rpc:procedure 'server:login host portn) *toppath*)) -;; (begin -;; (debug:print-info 2 *default-log-port* "Logged in and connected to " host ":" port) -;; (set! *runremote* (vector host portn))) -;; (begin -;; (debug:print-info 2 *default-log-port* "Failed to login or connect to " host ":" port) -;; (set! *runremote* #f))))) -;; (debug:print-info 2 *default-log-port* "no server available"))))) - Index: runs.scm ================================================================== --- runs.scm +++ runs.scm @@ -2044,11 +2044,11 @@ (state-status (if (string? new-state-status) (string-split new-state-status ",") '(#f #f))) (rp-mutex (make-mutex)) (bup-mutex (make-mutex)) (keep-records (args:get-arg "-keep-records"))) ;; used in conjunction with -remove-runs to keep the records, TODO: consolidate this with "mode". - (let* ((write-access-actions '(remove-runs set-state-status archive run-wait)) + (let* ((write-access-actions '(remove-runs set-state-status archive run-wait kill-runs)) (dbfile (conc *toppath* "/megatest.db")) (readonly-mode (not (file-write-access? dbfile)))) (when (and readonly-mode (member action write-access-actions)) (debug:print-error 0 *default-log-port* "megatest.db is readonly. Cannot proceed with action ["action"] in which write-access isrequired .") @@ -2081,16 +2081,19 @@ (worker-thread #f)) (debug:print-info 4 *default-log-port* "runs:operate-on run=" run ", header=" header) (if (not (null? tests)) (begin (case action + ((kill-runs) + (tasks:kill-runner target run-name "%") + (debug:print 1 *default-log-port* "Killing tests for run: " runkey " " (db:get-value-by-header run header "runname")) + ) ((remove-runs) ;; (if (tasks:need-server run-id)(tasks:start-and-wait-for-server tdbdat run-id 10)) ;; seek and kill in flight -runtests with % as testpatt here ;; (if (equal? testpatt "%") (tasks:kill-runner target run-name testpatt) - ;; (debug:print 0 *default-log-port* "not attempting to kill any run launcher processes as testpatt is " testpatt)) (debug:print 1 *default-log-port* "Removing tests for run: " runkey " " (db:get-value-by-header run header "runname"))) ((set-state-status) ;; (if (tasks:need-server run-id)(tasks:start-and-wait-for-server tdbdat run-id 10)) (debug:print 1 *default-log-port* "Modifying state and staus for tests for run: " runkey " " (db:get-value-by-header run header "runname"))) @@ -2194,11 +2197,11 @@ (if (< (- now last-visit) 1.0) (thread-sleep! 1.0)) (hash-table-set! backgrounded-remove-last-visit test-fulln (current-seconds)) ;; send to back of line, loop (let ((newtal (append tal (list test)))) - (loop (car newtal)(cdr newtal))) + (loop (car newtal)(cdr newtal))) ) ((done) ;; drop this one; if remaining, loop, else finish (hash-table-set! backgrounded-remove-last-visit test-fulln (current-seconds)) (let ((subrun-remove-succeeded (hash-table-ref/default backgrounded-remove-result test-fulln 'exception))) @@ -2251,10 +2254,32 @@ (begin (runs:remove-test-directory new-test-dat mode) ;; 'remove-all) (if (not (null? tal)) (loop (car tal)(cdr tal))))))) (rmt:update-run-stats run-id (rmt:get-raw-run-stats run-id))) + ((kill-runs) + ;; RUNNING -> KILLREQ + ;; LAUNCHED,RUNNING,REMOTEHOSTSTART -> NOT STARTED + (cond + ((and has-subrun (member test-state (list "RUNNING" "LAUNCHED" "REMOTEHOSTSTART" "KILLREQ"))) + (common:send-thunk-to-background-thread + (lambda () + (let* ((subrun-remove-succeeded + (subrun:kill-subrun run-dir keep-records))) + #t))) + (if (not (null? tal)) + (loop (car tal)(cdr tal))) + ) + ((member test-state (list "RUNNING" "LAUNCHED" "REMOTEHOSTSTART" "KILLREQ")) + (debug:print 1 *default-log-port* "INFO: issuing killreq to test "test-fulln) + (mt:test-set-state-status-by-id run-id (db:test-get-id test) "KILLREQ" "n/a" #f) + (if (not (null? tal)) + (loop (car tal)(cdr tal)))) + (else + (if (not (null? tal)) + (loop (car tal)(cdr tal))) + ))) ((set-state-status) (let* ((new-state (car state-status)) (new-status (cadr state-status)) (test-id (db:test-get-id test)) (test-run-dir (db:test-get-rundir new-test-dat)) DELETED sdb.scm Index: sdb.scm ================================================================== --- sdb.scm +++ /dev/null @@ -1,116 +0,0 @@ -;;====================================================================== -;; Copyright 2006-2013, Matthew Welland. -;; -;; This file is part of Megatest. -;; -;; Megatest is free software: you can redistribute it and/or modify -;; it under the terms of the GNU General Public License as published by -;; the Free Software Foundation, either version 3 of the License, or -;; (at your option) any later version. -;; -;; Megatest is distributed in the hope that it will be useful, -;; but WITHOUT ANY WARRANTY; without even the implied warranty of -;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the -;; GNU General Public License for more details. -;; -;; You should have received a copy of the GNU General Public License -;; along with Megatest. If not, see . - -;;====================================================================== - -;;====================================================================== -;; Simple persistant strings lookup table. Keep out of the main db -;; so writes/reads don't slow down central access. -;;====================================================================== - -(require-extension (srfi 18) extras) -(use sqlite3 srfi-1 posix regex regex-case srfi-69 csv-xml s11n md5 message-digest base64) -(import (prefix sqlite3 sqlite3:)) -(import (prefix base64 base64:)) - -(declare (unit sdb)) - -;; -(define (sdb:open fname) - (let* ((dbpath (pathname-directory fname)) - (dbexists (let ((fe (common:file-exists? fname))) - (if fe - fe - (begin - (create-directory dbpath #t) - #f)))) - (sdb (sqlite3:open-database fname)) - (handler (make-busy-timeout 136000))) - (sqlite3:set-busy-handler! sdb handler) - (if (not dbexists) - (sdb:initialize sdb)) - (sqlite3:execute sdb "PRAGMA synchronous = 1;") - sdb)) - -(define (sdb:initialize sdb) - (sqlite3:execute sdb "CREATE TABLE IF NOT EXISTS strs - (id INTEGER PRIMARY KEY, - str TEXT, - CONSTRAINT str UNIQUE (str));") - (sqlite3:execute sdb "CREATE INDEX IF NOT EXISTS strindx ON strs (str);")) - -;; (define sumup (let ((a 0))(lambda (x)(set! a (+ x a)) a))) - -(define (sdb:register-string sdb str) - (sqlite3:execute sdb "INSERT OR IGNORE INTO strs (str) VALUES (?);" str)) - -(define (sdb:string->id sdb str-cache str) - (let ((id (hash-table-ref/default str-cache str #f))) - (if (not id) - (sqlite3:for-each-row - (lambda (sid) - (set! id sid) - (hash-table-set! str-cache str id)) - sdb - "SELECT id FROM strs WHERE str=?;" str)) - id)) - -(define (sdb:id->string sdb id-cache id) - (let ((str (hash-table-ref/default id-cache id #f))) - (if (not str) - (sqlite3:for-each-row - (lambda (istr) - (set! str istr) - (hash-table-set! id-cache id str)) - sdb - "SELECT str FROM strs WHERE id=?;" id)) - str)) - -;; Numbers get passed though in both directions -;; -(define (make-sdb:qry fname) - (let ((sdb #f) - (scache (make-hash-table)) - (icache (make-hash-table))) - (lambda (cmd var) - (case cmd - ((setup) (set! sdb (if (not sdb) - (sdb:open (if var var fname))))) - ((setdb) (set! sdb var)) - ((getdb) sdb) - ((finalize) (if sdb - (begin - (sqlite3:finalize! sdb) - (set! sdb #f)))) - ((getid) (let ((id (if (or (number? var) - (string->number var)) - var - (sdb:string->id sdb scache var)))) - (if id - id - (begin - (sdb:register-string sdb var) - (sdb:string->id sdb scache var))))) - ((getstr) (if (or (number? var) - (string->number var)) - (sdb:id->string sdb icache var) - var)) - ((passid) var) - ((passstr) var) - (else #f))))) - Index: server.scm ================================================================== --- server.scm +++ server.scm @@ -15,606 +15,360 @@ ;; ;; You should have received a copy of the GNU General Public License ;; along with Megatest. If not, see . ;; +;;====================================================================== +;; +;; This is the Megatest specific stuff for starting and maintaining a +;; server. Anything that talks to the server should go in client.scm (maybe - might get rid of client.scm) +;; General nanomsg stuff (not Megatest specific) should go in the +;; nmsg-transport.scm file. +;; +;;====================================================================== + (require-extension (srfi 18) extras tcp s11n) (use srfi-1 posix regex regex-case srfi-69 hostinfo md5 message-digest - directory-utils posix-extras matchable) + directory-utils posix-extras matchable typed-records + pkts) (use spiffy uri-common intarweb http-client spiffy-request-vars) (declare (unit server)) (declare (uses common)) -(declare (uses db)) -(declare (uses tasks)) ;; tasks are where stuff is maintained about what is running. -;; (declare (uses synchash)) -(declare (uses http-transport)) -;;(declare (uses rpc-transport)) -(declare (uses launch)) -;; (declare (uses daemon)) - -(include "common_records.scm") -(include "db_records.scm") - -(define (server:make-server-url hostport) - (if (not hostport) - #f - (conc "http://" (car hostport) ":" (cadr hostport)))) - -(define *server-loop-heart-beat* (current-seconds)) - -;;====================================================================== -;; P K T S S T U F F -;;====================================================================== - -;; ??? - -;;====================================================================== -;; P K T S S T U F F -;;====================================================================== - -;; ??? - -;;====================================================================== -;; S E R V E R -;;====================================================================== - -;; Call this to start the actual server -;; - -;; all routes though here end in exit ... -;; -;; start_server -;; -(define (server:launch run-id transport-type) - (case transport-type - ((http)(http-transport:launch)) - ;;((nmsg)(nmsg-transport:launch run-id)) - ;;((rpc) (rpc-transport:launch run-id)) - (else (debug:print-error 0 *default-log-port* "unknown server type " transport-type)))) - -;;====================================================================== -;; S E R V E R U T I L I T I E S -;;====================================================================== - -;; Get the transport -(define (server:get-transport) - (if *transport-type* - *transport-type* - (let ((ttype (string->symbol - (or (args:get-arg "-transport") - (configf:lookup *configdat* "server" "transport") - "rpc")))) - (set! *transport-type* ttype) - ttype))) - -;; Generate a unique signature for this server -(define (server:mk-signature) - (message-digest-string (md5-primitive) - (with-output-to-string - (lambda () - (write (list (current-directory) - (argv))))))) - -;; When using zmq this would send the message back (two step process) -;; with spiffy or rpc this simply returns the return data to be returned -;; -(define (server:reply return-addr query-sig success/fail result) - (debug:print-info 11 *default-log-port* "server:reply return-addr=" return-addr ", result=" result) - ;; (send-message pubsock target send-more: #t) - ;; (send-message pubsock - (case (server:get-transport) - ((rpc) (db:obj->string (vector success/fail query-sig result))) - ((http) (db:obj->string (vector success/fail query-sig result))) - ((fs) result) - (else - (debug:print-error 0 *default-log-port* "unrecognised transport type: " *transport-type*) - result))) - -;; Given a run id start a server process ### NOTE ### > file 2>&1 -;; if the run-id is zero and the target-host is set -;; try running on that host -;; incidental: rotate logs in logs/ dir. -;; -(define (server:run areapath) ;; areapath is *toppath* for a given testsuite area - (let* ((curr-host (get-host-name)) - ;; (attempt-in-progress (server:start-attempted? areapath)) - ;; (dot-server-url (server:check-if-running areapath)) - (curr-ip (server:get-best-guess-address curr-host)) - (curr-pid (current-process-id)) - (homehost (common:get-homehost)) ;; configf:lookup *configdat* "server" "homehost" )) - (target-host (car homehost)) - (testsuite (common:get-testsuite-name)) - (logfile (conc areapath "/logs/server.log")) ;; -" curr-pid "-" target-host ".log")) - (cmdln (conc (common:get-megatest-exe) - " -server " (or target-host "-") (if (equal? (configf:lookup *configdat* "server" "daemonize") "yes") - " -daemonize " - "") - ;; " -log " logfile - " -m testsuite:" testsuite)) ;; (conc " >> " logfile " 2>&1 &"))))) - (log-rotate (make-thread common:rotate-logs "server run, rotate logs thread")) - (load-limit (configf:lookup-number *configdat* "jobtools" "max-server-start-load" default: 3.0))) - ;; we want the remote server to start in *toppath* so push there - (push-directory areapath) - (debug:print 0 *default-log-port* "INFO: Trying to start server (" cmdln ") ...") - (thread-start! log-rotate) - - ;; host.domain.tld match host? - (if (and target-host - ;; look at target host, is it host.domain.tld or ip address and does it - ;; match current ip or hostname - (not (string-match (conc "("curr-host "|" curr-host"\\..*)") target-host)) - (not (equal? curr-ip target-host))) - (begin - (debug:print-info 0 *default-log-port* "Starting server on " target-host ", logfile is " logfile) - (setenv "TARGETHOST" target-host))) - - (setenv "TARGETHOST_LOGF" logfile) - (thread-sleep! (/ (random 5000) 1000)) ;; add about a random (up to 5 seconds) initial delay. It seems pretty common that many running tests request a server at the same time - (common:wait-for-normalized-load load-limit " delaying server start due to load" target-host) ;; do not try starting servers on an already overloaded machine, just wait forever - (system (conc "nbfake " cmdln)) - (unsetenv "TARGETHOST_LOGF") - (if (get-environment-variable "TARGETHOST")(unsetenv "TARGETHOST")) - (thread-join! log-rotate) - (pop-directory))) - -;; given a path to a server log return: host port startseconds -;; -(define (server:logf-get-start-info logf) - (let ((rx (regexp "^SERVER STARTED: (\\S+):(\\d+) AT ([\\d\\.]+)"))) ;; SERVER STARTED: host:port AT timesecs - (handle-exceptions - exn - (list #f #f #f) ;; no idea what went wrong, call it a bad server - (with-input-from-file - logf - (lambda () - (let loop ((inl (read-line)) - (lnum 0)) - (if (not (eof-object? inl)) - (let ((mlst (string-match rx inl))) - (if (not mlst) - (if (< lnum 500) ;; give up if more than 500 lines of server log read - (loop (read-line)(+ lnum 1)) - (list #f #f #f)) - (let ((dat (cdr mlst))) - (list (car dat) ;; host - (string->number (cadr dat)) ;; port - (string->number (caddr dat)))))) - (list #f #f #f)))))))) - -;; get a list of servers with all relevant data -;; ( mod-time host port start-time pid ) -;; -(define (server:get-list areapath #!key (limit #f)) - (let ((fname-rx (regexp "^(|.*/)server-(\\d+)-(\\S+).log$")) - (day-seconds (* 24 60 60))) - ;; if the directory exists continue to get the list - ;; otherwise attempt to create the logs dir and then - ;; continue - (if (if (directory-exists? (conc areapath "/logs")) - '() - (if (file-write-access? areapath) - (begin - (condition-case - (create-directory (conc areapath "/logs") #t) - (exn (i/o file)(debug:print 0 *default-log-port* "ERROR: Cannot create directory at " (conc areapath "/logs"))) - (exn ()(debug:print 0 *default-log-port* "ERROR: Unknown error attemtping to get server list."))) - (directory-exists? (conc areapath "/logs"))) - '())) - (let* ((server-logs (glob (conc areapath "/logs/server-*.log"))) - (num-serv-logs (length server-logs))) - (if (null? server-logs) - '() - (let loop ((hed (car server-logs)) - (tal (cdr server-logs)) - (res '())) - (let* ((mod-time (handle-exceptions - exn - (current-seconds) ;; 0 - (file-modification-time hed))) ;; default to *very* old so log gets ignored if deleted - (down-time (- (current-seconds) mod-time)) - (serv-dat (if (or (< num-serv-logs 10) - (< down-time 900)) ;; day-seconds)) - (server:logf-get-start-info hed) - '())) ;; don't waste time processing server files not touched in the 15 minutes if there are more than ten servers to look at - (serv-rec (cons mod-time serv-dat)) - (fmatch (string-match fname-rx hed)) - (pid (if fmatch (string->number (list-ref fmatch 2)) #f)) - (new-res (if (null? serv-dat) - res - (cons (append serv-rec (list pid)) res)))) - (if (null? tal) - (if (and limit - (> (length new-res) limit)) - new-res ;; (take new-res limit) <= need intelligent sorting before this will work - new-res) - (loop (car tal)(cdr tal) new-res))))))))) - -(define (server:get-num-alive srvlst) - (let ((num-alive 0)) - (for-each - (lambda (server) - (match-let (((mod-time host port start-time pid) - server)) - (let* ((uptime (- (current-seconds) mod-time)) - (runtime (if start-time - (- mod-time start-time) - 0))) - (if (< uptime 5)(set! num-alive (+ num-alive 1)))))) - srvlst) - num-alive)) - -;; given a list of servers get a list of valid servers, i.e. at least -;; 10 seconds old, has started and is less than 1 hour old and is -;; active (i.e. mod-time < 10 seconds -;; -;; mod-time host port start-time pid -;; -;; sort by start-time descending. I.e. get the oldest first. Young servers will thus drop off -;; and servers should stick around for about two hours or so. -;; -(define (server:get-best srvlst) - (let* ((nums (server:get-num-servers)) - (now (current-seconds)) - (slst (sort - (filter (lambda (rec) - (if (and (list? rec) - (> (length rec) 2)) - (let ((start-time (list-ref rec 3)) - (mod-time (list-ref rec 0))) - ;; (print "start-time: " start-time " mod-time: " mod-time) - (and start-time mod-time - (> (- now start-time) 0) ;; been running at least 0 seconds - (< (- now mod-time) 16) ;; still alive - file touched in last 16 seconds - (< (- now start-time) - (+ (- (string->number (or (configf:lookup *configdat* "server" "runtime") "3600")) - 180) - (random 360))) ;; under one hour running time +/- 180 - )) - #f)) - srvlst) - (lambda (a b) - (< (list-ref a 3) - (list-ref b 3)))))) - (if (> (length slst) nums) - (take slst nums) - slst))) - -(define (server:get-first-best areapath) - (let ((srvrs (server:get-best (server:get-list areapath)))) - (if (and srvrs - (not (null? srvrs))) - (car srvrs) - #f))) - -(define (server:get-rand-best areapath) - (let ((srvrs (server:get-best (server:get-list areapath)))) - (if (and (list? srvrs) - (not (null? srvrs))) - (let* ((len (length srvrs)) - (idx (random len))) - (list-ref srvrs idx)) - #f))) - - -(define (server:record->url servr) - (match-let (((mod-time host port start-time pid) - servr)) - (if (and host port) - (conc host ":" port) - #f))) - -(define (server:get-client-signature) ;; BB> why is this proc named "get-"? it returns nothing -- set! has not return value. - (if *my-client-signature* *my-client-signature* - (let ((sig (server:mk-signature))) - (set! *my-client-signature* sig) - *my-client-signature*))) - -;; kind start up of servers, wait 40 seconds before allowing another server for a given -;; run-id to be launched -(define (server:kind-run areapath) - (if (not (server:check-if-running areapath)) ;; why try if there is already a server running? - (let* ((last-run-dat (hash-table-ref/default *server-kind-run* areapath '(0 0))) ;; callnum, whenrun - (call-num (car last-run-dat)) - (when-run (cadr last-run-dat)) - (run-delay (+ (case call-num - ((0) 0) - ((1) 20) - ((2) 300) - (else 600)) - (random 5))) ;; add a small random number just in case a lot of jobs hit the work hosts simultaneously - (lock-file (conc areapath "/logs/server-start.lock"))) - (if (> (- (current-seconds) when-run) run-delay) - (begin - (common:simple-file-lock-and-wait lock-file expire-time: 15) - (server:run areapath) - (thread-sleep! 5) ;; don't release the lock for at least a few seconds - (common:simple-file-release-lock lock-file))) - (hash-table-set! *server-kind-run* areapath (list (+ call-num 1)(current-seconds)))))) - -(define (server:start-and-wait areapath #!key (timeout 60)) - (let ((give-up-time (+ (current-seconds) timeout))) - (let loop ((server-url (server:check-if-running areapath)) - (try-num 0)) - (if (or server-url - (> (current-seconds) give-up-time)) ;; server-url will be #f if no server available. - server-url - (let ((num-ok (length (server:get-best (server:get-list areapath))))) - (if (and (> try-num 0) ;; first time through simply wait a little while then try again - (< num-ok 1)) ;; if there are no decent candidates for servers then try starting a new one - (server:kind-run areapath)) - (thread-sleep! 5) - (loop (server:check-if-running areapath) - (+ try-num 1))))))) - -(define server:try-running server:run) ;; there is no more per-run servers ;; REMOVE ME. BUG. - -(define (server:get-num-servers #!key (numservers 2)) - (let ((ns (string->number - (or (configf:lookup *configdat* "server" "numservers") "notanumber")))) - (or ns numservers))) - -;; no longer care if multiple servers are started by accident. older servers will drop off in time. -;; -(define (server:check-if-running areapath) ;; #!key (numservers "2")) - (let* ((ns (server:get-num-servers)) - (servers (server:get-best (server:get-list areapath)))) - ;; (print "servers: " servers " ns: " ns) - (if (or (and servers - (null? servers)) - (not servers) - (and (list? servers) - (< (length servers) (random ns)))) ;; somewhere between 0 and numservers - #f - (let loop ((hed (car servers)) - (tal (cdr servers))) - (let ((res (server:check-server hed))) - (if res - res - (if (null? tal) - #f - (loop (car tal)(cdr tal))))))))) - -;; ping the given server -;; -(define (server:check-server server-record) - (let* ((server-url (server:record->url server-record)) - (res (case *transport-type* - ((http)(server:ping server-url)) - ;; ((nmsg)(nmsg-transport:ping (tasks:hostinfo-get-interface server) - ))) - (if res - server-url - #f))) - -(define (server:kill servr) - (match-let (((mod-time hostname port start-time pid) - servr)) - (tasks:kill-server hostname pid))) - -;; called in megatest.scm, host-port is string hostname:port -;; -;; NOTE: This is NOT called directly from clients as not all transports support a client running -;; in the same process as the server. -;; -(define (server:ping host-port-in #!key (do-exit #f)) - (let ((host:port (if (not host-port-in) ;; use read-dotserver to find - #f ;; (server:check-if-running *toppath*) - ;; (if (number? host-port-in) ;; we were handed a server-id - ;; (let ((srec (tasks:get-server-by-id (db:delay-if-busy (tasks:open-db)) host-port-in))) - ;; ;; (print "srec: " srec " host-port-in: " host-port-in) - ;; (if srec - ;; (conc (vector-ref srec 3) ":" (vector-ref srec 4)) - ;; (conc "no such server-id " host-port-in))) - host-port-in))) ;; ) - (let* ((host-port (if host:port - (let ((slst (string-split host:port ":"))) - (if (eq? (length slst) 2) - (list (car slst)(string->number (cadr slst))) - #f)) - #f))) -;; (toppath (launch:setup))) - ;; (print "host-port=" host-port) - (if (not host-port) - (begin - (if host-port-in - (debug:print 0 *default-log-port* "ERROR: bad host:port")) - (if do-exit (exit 1)) - #f) - (let* ((iface (car host-port)) - (port (cadr host-port)) - (server-dat (http-transport:client-connect iface port)) - (login-res (rmt:login-no-auto-client-setup server-dat))) - (if (and (list? login-res) - (car login-res)) - (begin - ;; (print "LOGIN_OK") - (if do-exit (exit 0)) - #t) - (begin - ;; (print "LOGIN_FAILED") - (if do-exit (exit 1)) - #f))))))) - -;; run ping in separate process, safest way in some cases -;; -(define (server:ping-server ifaceport) - (with-input-from-pipe - (conc (common:get-megatest-exe) " -ping " ifaceport) - (lambda () - (let loop ((inl (read-line)) - (res "NOREPLY")) - (if (eof-object? inl) - (case (string->symbol res) - ((NOREPLY) #f) - ((LOGIN_OK) #t) - (else #f)) - (loop (read-line) inl)))))) - -;; NOT USED (well, ok, reference in rpc-transport but otherwise not used). -;; -(define (server:login toppath) - (lambda (toppath) - (set! *db-last-access* (current-seconds)) ;; might not be needed. - (if (equal? *toppath* toppath) - #t - #f))) - -;; timeout is hms string: 1h 5m 3s, default is 1 minute -;; -(define (server:expiration-timeout) - (let ((tmo (configf:lookup *configdat* "server" "timeout"))) - (if (and (string? tmo) - (common:hms-string->seconds tmo)) ;; BUG: hms-string->seconds is broken, if given "10" returns 0. Also, it doesn't belong in this logic unless the string->number is changed below - (* 3600 (string->number tmo)) - 60))) - -(define (server:get-best-guess-address hostname) - (let ((res #f)) - (for-each - (lambda (adr) - (if (not (eq? (u8vector-ref adr 0) 127)) - (set! res adr))) - ;; NOTE: This can fail when there is no mention of the host in /etc/hosts. FIXME - (vector->list (hostinfo-addresses (hostname->hostinfo hostname)))) - (string-intersperse - (map number->string - (u8vector->list - (if res res (hostname->ip hostname)))) "."))) - -;; moving this here as it needs access to db and cannot be in common. -;; -(define (server:writable-watchdog dbstruct) - (thread-sleep! 0.05) ;; delay for startup - (let ((legacy-sync (common:run-sync?)) - (sync-stale-seconds (configf:lookup-number *configdat* "server" "sync-stale-seconds" default: 300)) - (debug-mode (debug:debug-mode 1)) - (last-time (current-seconds)) - (no-sync-db (db:open-no-sync-db)) - (sync-duration 0) ;; run time of the sync in milliseconds - ;;(this-wd-num (begin (mutex-lock! *wdnum*mutex) (let ((x *wdnum*)) (set! *wdnum* (add1 *wdnum*)) (mutex-unlock! *wdnum*mutex) x))) - ) - (set! *no-sync-db* no-sync-db) ;; make the no sync db available to api calls - (debug:print-info 2 *default-log-port* "Periodic sync thread started.") - (debug:print-info 3 *default-log-port* "watchdog starting. legacy-sync is " legacy-sync" pid="(current-process-id) );; " this-wd-num="this-wd-num) - (if (and legacy-sync (not *time-to-exit*)) - (let* (;;(dbstruct (db:setup)) - (mtdb (dbr:dbstruct-mtdb dbstruct)) - (mtpath (db:dbdat-get-path mtdb)) - (tmp-area (common:get-db-tmp-area)) - (start-file (conc tmp-area "/.start-sync")) - (end-file (conc tmp-area "/.end-sync"))) - (debug:print-info 0 *default-log-port* "Server running, periodic sync started.") - (let loop () - ;; sync for filesystem local db writes - ;; - (mutex-lock! *db-multi-sync-mutex*) - (let* ((need-sync (>= *db-last-access* *db-last-sync*)) ;; no sync since last write - (sync-in-progress *db-sync-in-progress*) - (min-intersync-delay (configf:lookup-number *configdat* "server" "minimum-intersync-delay" default: 5)) - (should-sync (and (not *time-to-exit*) - (> (- (current-seconds) *db-last-sync*) min-intersync-delay))) ;; sync every five seconds minimum, deprecated logic, can probably be removed - (start-time (current-seconds)) - (cpu-load-adj (alist-ref 'adj-proc-load (common:get-normalized-cpu-load #f))) - (mt-mod-time (file-modification-time mtpath)) - (last-sync-start (if (common:file-exists? start-file) - (file-modification-time start-file) - 0)) - (last-sync-end (if (common:file-exists? end-file) - (file-modification-time end-file) - 10)) - (sync-period (+ 3 (* cpu-load-adj 30))) ;; as adjusted load increases increase the sync period - (recently-synced (and (< (- start-time mt-mod-time) sync-period) ;; not useful if sync didn't modify megatest.db! - (< mt-mod-time last-sync-start))) - (sync-done (<= last-sync-start last-sync-end)) - (sync-stale (> start-time (+ last-sync-start sync-stale-seconds))) - (will-sync (and (not *time-to-exit*) ;; do not start a sync if we are in the process of exiting - (or need-sync should-sync) - (or sync-done sync-stale) - (not sync-in-progress) - (not recently-synced)))) - (debug:print-info 13 *default-log-port* "WD writable-watchdog top of loop. need-sync="need-sync" sync-in-progress=" sync-in-progress - " should-sync="should-sync" start-time="start-time" mt-mod-time="mt-mod-time" recently-synced="recently-synced" will-sync="will-sync - " sync-done=" sync-done " sync-period=" sync-period) - (if (and (> sync-period 5) - (common:low-noise-print 30 "sync-period")) - (debug:print-info 0 *default-log-port* "Increased sync period due to long sync times, sync took: " sync-period " seconds.")) - ;; (if recently-synced (debug:print-info 0 *default-log-port* "Skipping sync due to recently-synced flag=" recently-synced)) - ;; (debug:print-info 0 *default-log-port* "need-sync: " need-sync " sync-in-progress: " sync-in-progress " should-sync: " should-sync " will-sync: " will-sync) - (if will-sync (set! *db-sync-in-progress* #t)) - (mutex-unlock! *db-multi-sync-mutex*) - (if will-sync - (let (;; (max-sync-duration (configf:lookup-number *configdat* "server" "max-sync-duration")) ;; KEEPING THIS AVAILABLE BUT SHOULD NOT USE, I'M PRETTY SURE IT DOES NOT WORK! - (sync-start (current-milliseconds))) - (with-output-to-file start-file (lambda ()(print (current-process-id)))) - - ;; put lock here - - ;; (if (or (not max-sync-duration) - ;; (< sync-duration max-sync-duration)) ;; NOTE: db:sync-to-megatest.db keeps track of time of last sync and syncs incrementally - (let ((res (db:sync-to-megatest.db dbstruct no-sync-db: no-sync-db))) ;; did we sync any data? If so need to set the db touched flag to keep the server alive - (set! sync-duration (- (current-milliseconds) sync-start)) - (if (> res 0) ;; some records were transferred, keep the db alive - (begin - (mutex-lock! *heartbeat-mutex*) - (set! *db-last-access* (current-seconds)) - (mutex-unlock! *heartbeat-mutex*) - (debug:print-info 0 *default-log-port* "sync called, " res " records transferred.")) - (debug:print-info 2 *default-log-port* "sync called but zero records transferred"))))) -;; ;; TODO: factor this next routine out into a function -;; (with-input-from-pipe ;; this should not block other threads but need to verify this -;; (conc "megatest -sync-to-megatest.db -m testsuite:" (common:get-area-name) ":" *toppath*) -;; (lambda () -;; (let loop ((inl (read-line)) -;; (res #f)) -;; (if (eof-object? inl) -;; (begin -;; (set! sync-duration (- (current-milliseconds) sync-start)) -;; (cond -;; ((not res) -;; (debug:print 0 *default-log-port* "ERROR: sync from /tmp db to megatest.db appears to have failed. Recommended that you stop your runs and run \"megatest -cleanup-db\"")) -;; ((> res 0) -;; (mutex-lock! *heartbeat-mutex*) -;; (set! *db-last-access* (current-seconds)) -;; (mutex-unlock! *heartbeat-mutex*)))) -;; (let ((num-synced (let ((matches (string-match "^Synced (\\d+).*$" inl))) -;; (if matches -;; (string->number (cadr matches)) -;; #f)))) -;; (loop (read-line) -;; (or num-synced res)))))))))) - (if will-sync - (begin - (mutex-lock! *db-multi-sync-mutex*) - (set! *db-sync-in-progress* #f) - (set! *db-last-sync* start-time) - (with-output-to-file end-file (lambda ()(print (current-process-id)))) - - ;; release lock here - - (mutex-unlock! *db-multi-sync-mutex*))) - (if (and debug-mode - (> (- start-time last-time) 60)) - (begin - (set! last-time start-time) - (debug:print-info 4 *default-log-port* "timestamp -> " (seconds->time-string (current-seconds)) ", time since start -> " (seconds->hr-min-sec (- (current-seconds) *time-zero*)))))) - - ;; keep going unless time to exit - ;; - (if (not *time-to-exit*) - (let delay-loop ((count 0)) - ;;(debug:print-info 13 *default-log-port* "delay-loop top; count="count" pid="(current-process-id)" this-wd-num="this-wd-num" *time-to-exit*="*time-to-exit*) - - (if (and (not *time-to-exit*) - (< count 6)) ;; was 11, changing to 4. - (begin - (thread-sleep! 1) - (delay-loop (+ count 1)))) - (if (not *time-to-exit*) (loop)))) - ;; time to exit, close the no-sync db here - (db:no-sync-close-db no-sync-db) - (if (common:low-noise-print 30) - (debug:print-info 0 *default-log-port* "Exiting watchdog timer, *time-to-exit* = " *time-to-exit*" pid="(current-process-id) ))))))) ;;" this-wd-num="this-wd-num))))))) + +(declare (uses db)) +(import db) + +;; Basic stuff for safely kicking off a server +(declare (uses portlogger)) +(import portlogger) + +(declare (uses nmsg-transport)) +(import nmsg-transport) + + +;; Might want to bring the daemonizing back +;; (declare (uses daemon)) + +(include "common_records.scm") +(include "db_records.scm") + +;;====================================================================== +;; P K T S S T U F F +;;====================================================================== + +;;====================================================================== +;; N A N O M S G B A S E D S E R V E R +;;====================================================================== + +;; information about me as a server +;; +(defstruct area + (conn #f) + (port #f) + (myaddr #f) + (hosts (make-hash-table)) + pktid ;; get pkt from hosts table if needed + pktfile + pktsdir + mtrah + (mutex (make-mutex)) + ) + +;; make it a global? Well, it is local to area module + +(define *area-info* (make-area)) +(define *pktspec* + `((server (hostname . h) + (port . p) + (pid . i) + (ipaddr . a) + ) + (data (hostname . h) ;; sender hostname + (port . p) ;; sender port + (ipaddr . a) ;; sender ip + (hostkey . k) ;; sending host key - store info at server under this key + (servkey . s) ;; server key - this needs to match at server end or reject the msg + (format . f) ;; sb=serialized-base64, t=text, sx=sexpr, j=json + (data . d) ;; base64 encoded slln data + ))) + +(define (server:get-mtrah) + (or (get-environment-variable "MT_RUN_AREA_HOME") + (if (file-exists? "megatest.config") + (current-directory) + #f))) + +;; get a port +;; start the nmsg server +;; look for other servers +;; contact other servers and compile list of servers +;; there are two types of server +;; main servers - dashboards, runners and dedicated servers - need pkt +;; passive servers - test executers, step calls, list-runs - no pkt +;; +(define (server:start-nmsg #!optional (force-server-type #f)) + (mutex-lock! (area-mutex *area-info*)) + (let* ((server-type (or force-server-type + (if (args:any? "-run" "-server") + 'main + 'passive))) + (port-num (portlogger:open-run-close portlogger:find-port)) + (best-ip (server:get-my-best-address)) + (area-conn (nmsg:start-server port-num)) + ;; (pktspec (area-pktspec *area-info*)) + (mtdir (or (server:get-mtrah) + (begin + (print "ERROR: megatest.config not found and MT_RUN_AREA_HOME is not set.") + #f))) + (pktdir (conc mtdir + "/.server-pkts"))) + (if (not mtdir) + #f + (begin + (if (not (directory? pktdir))(create-directory pktdir)) + ;; server is started, now create pkt if needed + (print "Starting server in " server-type " mode") + (if (eq? server-type 'main) + (begin + (area-pktid-set! *area-info* + (write-alist->pkt + pktdir + `((hostname . ,(get-host-name)) + (ipaddr . ,best-ip) + (port . ,port-num) + (pid . ,(current-process-id))) + pktspec: *pktspec* + ptype: 'server)) + (area-pktfile-set! *area-info* (conc pktdir "/" (area-pktid *area-info*) ".pkt")))) + ;; set all the area info in the + (area-pktsdir-set! *area-info* pktdir) + (area-mtrah-set! *area-info* mtdir) + (area-conn-set! *area-info* area-conn) + (area-port-set! *area-info* port-num) + (mutex-unlock! (area-mutex *area-info*)) + area-conn)))) + +;; action: +;; immediate - quick actions, no need to put in queues +;; dbwrite - put in dbwrite queue +;; dbread - put in dbread queue +;; oslong - os actions, e.g. du, that could take a long time +;; osshort - os actions that should be quick, e.g. df +;; +(define (server:std-handler dat) + (let* ((from-host (alist-ref 'hostname dat)) + (from-port (alist-ref 'port dat)) + (servkey (alist-ref 'servkey dat)) + (hostkey (alist-ref 'hostkey dat)) + (data (alist-ref 'data dat)) + (action (alist-ref 'action dat))) + ;; first, if you don't know who I am then I'm ignoring you + (if (not (equal? servkey (area-pktid *area-info*))) + `(#f . "I don't know you") ;; immediately return this + (case action ;; else carry on + ((immediate) + (case data + ((ping) `(#t "success")) + (else `(#t "I didn't recognise " data)))) + ((dbwrite) `(#t "db write submitted")) + ((dbread) `(#t "db read submitted")) + ((oslong) `(#t "os long submitted")) + ((dbwrite) `(#t "os short submitted")) + (else `(#f "unrecognised action" action)))))) + +;; Call this to start the actual server +;; +;; start_server +;; +;; mode: ' +;; handler: proc which takes pktrecieved as argument +;; +(define (server:launch mode #!optional (proc server:std-handler)) + (let* ((start-time (current-seconds)) + (rep (server:start-nmsg mode)) + (last-msg-time (current-seconds)) + (th1 (make-thread + (lambda () + (let loop () + (let ((dat (server:receive rep))) + (set! last-msg-time (current-seconds)) + ;; (print "received: " pktdat) + (if (not (eof-object? dat)) + (let ((resdat (proc dat))) + (print "Got " dat) + (print "Responding with " resdat) + (nmsg:send rep (sexpr->string resdat)) ;; (with-output-to-string (lambda ()(write resdat)))) + (loop)))))) + "message handler")) + (th2 (make-thread + (lambda () + (let loop () + (thread-sleep! 10) + (if (> (- (current-seconds) last-msg-time) 60) ;; timeout after 60 seconds + (begin + (print "Waited for 60 seconds and no messages, exiting now.") + (exit)) + (loop))))))) + (thread-start! th1) + (thread-start! th2) + (thread-join! th1))) + +;; get the response +;; +(define (server:receive rep) + (let ((instr (nmsg:recv rep))) + (if (string? instr) + (string->sexpr instr) ;; (with-input-from-string instr read) + instr))) + +(define (server:shutdown) + (let ((conn (area-conn *area-info*)) + (pktf (area-pktfile *area-info*)) + (port (area-port *area-info*))) + (if conn + (begin + (if pktf (delete-file* pktf)) + (server:send-all "imshuttingdown") + (nmsg:close conn) + (portlogger:open-run-close portlogger:release-port port))))) + +(define (server:send-all msg) + #f) + +;; given a area record look up all the packets +;; +(define (server:get-all-server-pkts rec) + (let ((all-pkt-files (glob (conc (area-pktsdir rec) "/*.pkt")))) +;; (pktspec (area-pktspec rec))) + (map (lambda (pkt-file) + (read-pkt->alist pkt-file pktspec: *pktspec*)) + all-pkt-files))) + +#;((Z . "9a0212302295a19610d5796fce0370fa130758e9") + (port . "34827") + (pid . "28748") + (hostname . "zeus") + (T . "server") + (D . "1549427032.0")) + +;; srvpkt is the info for the server we wish to send the message to +;; +(define (server:send servpkt data action) + (let* ((port (alist-ref 'port servpkt)) + (host (alist-ref 'hostname servpkt)) + (ip (alist-ref 'ipaddr servpkt)) + (hkey (alist-ref 'Z servpkt)) + (addr (conc (or ip host) ":" port)) ;; fall back to host if ip not provided + (myport (area-port *area-info*)) + (myhost (area-myaddr *area-info*)) + (mykey (area-pktid *area-info*)) + (msg (with-output-to-string + (lambda () + (write `((hostname . ,myhost) + (port . ,myport) + (servkey . ,hkey) ;; server looks at this to ensure message is for them + (hostkey . ,mykey) + (action . ,action) ;; formating of the message + (data . ,data)) + ;; *pktspec* + ;; ptype: 'data)) + ))))) + ;; (print "msg: " msg) + (if (and port host) + (string->sexpr ;; begin + ;; (print "sending ")(pp msg)(print " to " addr) + (nmsg:open-send-receive addr msg)) + #f))) + +(define (server:get-my-best-address) + (ip->string (car (filter (lambda (x) + (not (eq? (u8vector-ref x 0) 127))) + (vector->list (hostinfo-addresses (hostname->hostinfo "zeus"))))))) + +;; whoami? I am my pkt +;; +(define (server:whoami? area) + (hash-table-ref/default (area-hosts area)(area-pktid area) #f)) + +;;====================================================================== +;; "Client side" operations +;;====================================================================== + +;; convert to/from string / sexpr + +(define (string->sexpr str) + (if (string? str) + (with-input-from-string str read) + str)) + +(define (sexpr->string s) + (with-output-to-string (lambda ()(write s)))) + +;; is the server alive? +;; +(define (server:ping servpkt) + (let* ((start-time (current-milliseconds)) + (res (server:send servpkt 'ping 'immediate))) + (cons (- (current-milliseconds) start-time) + res))) ;; (equal? res "got ping")))) + +;; look up all pkts and get the server id (the hash), port, host/ip +;; store this info in the global struct *area-info* +;; +;; pass in *area-info* as rec +;; +(define (server:update-known-servers rec) + ;; readll all pkts + ;; foreach pkt; if it isn't me ping the server; if alive, add to hosts hash, else rm the pkt + (let ((all-pkts (delete-duplicates + (append (server:get-all-server-pkts rec) + (hash-table-values (area-hosts rec))))) + (hostshash (area-hosts rec)) + (my-id (area-pktid rec)) + (pktsdir (area-pktsdir rec)) ;; needed to remove pkts from non-responsive servers + ) + (for-each + (lambda (servpkt) + (let* ((res (server:ping servpkt)) + (sid (alist-ref 'Z servpkt)) ;; Z code is our name for the server + ) + (match res + ((qduration . payload) + (print "Server pkt:")(pp servpkt) + (print "res: ")(pp res) + (match payload + ((code message) + (print "code: " code " message: " message) + (if code + (hash-table-set! hostshash sid servpkt) + (print "got #f from the server, not sure what that means!"))) + (else + (print "Got ")(pp res)(print " from server ")(pp servpkt) " but response did not match (#f/#t . msg)"))) + (else + ;; here we delete the pkt - can't reach the server, remove it + ;; however this logic is inadequate. we should mark the server as checked + ;; and not good, if it happens a second time - then remove the pkt + ;; or something similar. I.e. don't be too quick to assume the server is wedged or dead + ;; could be it is simply too busy to reply + (print "clearing out server " sid) + (delete-file* (conc pktsdir "/" sid ".pkt")) + (hash-table-delete! hostshash side))))) + all-pkts))) + +;; send out an "I'm about to exit notice to all known servers" +;; +(define (server:imminent-death) + '()) + + +;;====================================================================== +;; S E R V E R U T I L I T I E S +;;====================================================================== + +;; get a signature for identifing this process +(define (server:get-process-signature) + (cons (get-host-name)(current-process-id))) Index: subrun.scm ================================================================== --- subrun.scm +++ subrun.scm @@ -118,10 +118,19 @@ (begin (subrun:set-subrun-removed test-run-dir) #t) #f)) #t)) + +(define (subrun:kill-subrun test-run-dir ) + (if (and (not (subrun:subrun-removed? test-run-dir)) (subrun:subrun-test-initialized? test-run-dir)) + (let* ((action-switches-str + (conc "-kill-runs" )) + (kill-result + (subrun:exec-sub-megatest test-run-dir action-switches-str "kill"))) + kill-result) + #t)) (define (subrun:launch-cmd test-run-dir) (if (subrun:subrun-removed? test-run-dir) (subrun:unset-subrun-removed test-run-dir)) ADDED util.scm Index: util.scm ================================================================== --- /dev/null +++ util.scm @@ -0,0 +1,423 @@ +;;====================================================================== +;; Copyright 2018, Matthew Welland. +;; +;; This file is part of Megatest. +;; +;; Megatest is free software: you can redistribute it and/or modify +;; it under the terms of the GNU General Public License as published by +;; the Free Software Foundation, either version 3 of the License, or +;; (at your option) any later version. +;; +;; Megatest is distributed in the hope that it will be useful, +;; but WITHOUT ANY WARRANTY; without even the implied warranty of +;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +;; GNU General Public License for more details. +;; +;; You should have received a copy of the GNU General Public License +;; along with Megatest. If not, see . +;; +;;====================================================================== + +;;====================================================================== +;; Tests +;;====================================================================== + +(declare (unit util)) + +(declare (uses common)) + +(module util + * + +(import chicken scheme data-structures extras srfi-13 ports ) + + +;;====================================================================== +;; L O C K I N G M E C H A N I S M S +;;====================================================================== + +;; faux-lock is deprecated. Please use simple-lock below +;; +(define (common:faux-lock keyname #!key (wait-time 8)(allow-lock-steal #t)) + (if (rmt:no-sync-get/default keyname #f) ;; do not be tempted to compare to pid. locking is a one-shot action, if already locked for this pid it doesn't actually count + (if (> wait-time 0) + (begin + (thread-sleep! 1) + (if (eq? wait-time 1) ;; only one second left, steal the lock + (begin + (debug:print-info 0 *default-log-port* "stealing lock for " keyname) + (common:faux-unlock keyname force: #t))) + (common:faux-lock keyname wait-time: (- wait-time 1))) + #f) + (begin + (rmt:no-sync-set keyname (conc (current-process-id))) + (equal? (conc (current-process-id)) (conc (rmt:no-sync-get/default keyname #f)))))) + +(define (common:faux-unlock keyname #!key (force #f)) + (if (or force (equal? (conc (current-process-id)) (conc (rmt:no-sync-get/default keyname #f)))) + (begin + (if (rmt:no-sync-get/default keyname #f) (rmt:no-sync-del! keyname)) + #t) + #f)) + +;; simple lock. improve and converge on this one. +;; +(define (common:simple-lock keyname) + (rmt:no-sync-get-lock keyname)) + +(define (common:run-a-command cmd #!key (with-vars #f)) + (let* ((pre-cmd (dtests:get-pre-command)) + (post-cmd (dtests:get-post-command)) + (fullcmd (if (or pre-cmd post-cmd) + (conc pre-cmd cmd post-cmd) + (conc "viewscreen " cmd)))) + (debug:print-info 02 *default-log-port* "Running command: " fullcmd) + (if with-vars + (common:without-vars cmd) + (common:without-vars fullcmd "MT_.*")))) + +;; ideally put all this info into the db, no need to preserve it across moving homehost +;; +;; return list of +;; ( reachable? cpuload update-time ) +(define (common:get-host-info hostname) + (let* ((loadinfo (rmt:get-latest-host-load hostname)) ;; if this host happens to have been recently used by a test reuse the load data + (load (car loadinfo)) + (load-sample-time (cdr loadinfo)) + (load-sample-age (- (current-seconds) load-sample-time)) + (loadinfo-timeout-seconds 6) ;; this was 20 seconds, seems way too lax. Switch to 6 seconds + (host-last-update-timeout-seconds 4) + (host-rec (hash-table-ref/default *host-loads* hostname #f)) + ) + (cond + ((< load-sample-age loadinfo-timeout-seconds) + (list #t + load-sample-time + load)) + ((and host-rec + (< (current-seconds) (+ (host-last-update host-rec) host-last-update-timeout-seconds))) + (list #t + (host-last-update host-rec) + (host-last-cpuload host-rec ))) + ((common:unix-ping hostname) + (list #t + (current-seconds) + (alist-ref 'adj-core-load (common:get-normalized-cpu-load hostname)))) ;; this is cheaper than you might think. get-normalized-cpu-load is cached for up to 5 seconds + (else + (list #f 0 -1) ;; bad host, don't use! + )))) + +(define (get-uname . params) + (let* ((uname-res (process:cmd-run->list (conc "uname " (if (null? params) "-a" (car params))))) + (uname #f)) + (if (null? (car uname-res)) + "unknown" + (caar uname-res)))) + +(define (get-unix-df path) + (let* ((df-results (process:cmd-run->list (conc "df " path))) + (space-rx (regexp "([0-9]+)\\s+([0-9]+)%")) + (freespc #f)) + ;; (write df-results) + (for-each (lambda (l) + (let ((match (string-search space-rx l))) + (if match + (let ((newval (string->number (cadr match)))) + (if (number? newval) + (set! freespc newval)))))) + (car df-results)) + freespc)) + +;; given path get free space, allows override in [setup] +;; with free-space-script /path/to/some/script.sh +;; +(define (get-df path) + (if (configf:lookup *configdat* "setup" "free-space-script") + (with-input-from-pipe + (conc (configf:lookup *configdat* "setup" "free-space-script") " " path) + (lambda () + (let ((res (read-line))) + (if (string? res) + (string->number res))))) + (get-unix-df path))) + +(define (std-exit-procedure) + (on-exit (lambda () 0)) + ;;(debug:print-info 13 *default-log-port* "std-exit-procedure called; *time-to-exit*="*time-to-exit*) + (let ((no-hurry (if *time-to-exit* ;; hurry up + #f + (begin + (set! *time-to-exit* #t) + #t)))) + (debug:print-info 4 *default-log-port* "starting exit process, finalizing databases.") + (if (and no-hurry (debug:debug-mode 18)) + (rmt:print-db-stats)) + (let ((th1 (make-thread (lambda () ;; thread for cleaning up, give it five seconds + (if *dbstruct-db* (db:close-all *dbstruct-db*)) ;; one second allocated + (if *task-db* + (let ((db (cdr *task-db*))) + (if (sqlite3:database? db) + (begin + (sqlite3:interrupt! db) + (sqlite3:finalize! db #t) + ;; (vector-set! *task-db* 0 #f) + (set! *task-db* #f))))) + (http-client#close-all-connections!) + ;; (if (and *runremote* + ;; (remote-conndat *runremote*)) + ;; (begin + ;; (http-client#close-all-connections!))) ;; for http-client + (if (not (eq? *default-log-port* (current-error-port))) + (close-output-port *default-log-port*)) + (set! *default-log-port* (current-error-port))) "Cleanup db exit thread")) + (th2 (make-thread (lambda () + (debug:print 4 *default-log-port* "Attempting clean exit. Please be patient and wait a few seconds...") + (if no-hurry + (begin + (thread-sleep! 5)) ;; give the clean up few seconds to do it's stuff + (begin + (thread-sleep! 2))) + (debug:print 4 *default-log-port* " ... done") + ) + "clean exit"))) + (thread-start! th1) + (thread-start! th2) + (thread-join! th1) + ) + ) + + 0) + +;; from metadat lookup MEGATEST_VERSION +;; +(define (common:get-last-run-version) ;; RADT => How does this work in send-receive function??; assume it is the value saved in some DB + (rmt:get-var "MEGATEST_VERSION")) + +(define (common:set-last-run-version) + (rmt:set-var "MEGATEST_VERSION" (common:version-signature))) + +;;====================================================================== +;; D I S K S P A C E +;;====================================================================== + +(define (common:get-disk-space-used fpath) + (with-input-from-pipe (conc "/usr/bin/du -s " fpath) read)) + +(define (common:check-space-in-dir dirpath required) + (let* ((dbspace (if (directory? dirpath) + (get-df dirpath) + 0))) + (list (> dbspace required) + dbspace + required + dirpath))) + +;; check space in dbdir and in megatest dir +;; returns: ok/not dbspace required-space +;; +(define (common:check-db-dir-space) + (let* ((required (string->number + (or (configf:lookup *configdat* "setup" "dbdir-space-required") + "100000"))) + (dbdir (common:get-db-tmp-area)) ;; (db:get-dbdir)) + (tdbspace (common:check-space-in-dir dbdir required)) + (mdbspace (common:check-space-in-dir *toppath* required))) + (sort (list tdbspace mdbspace) (lambda (a b) + (< (cadr a)(cadr b)))))) + +;; check available space in dbdir, exit if insufficient +;; +(define (common:check-db-dir-and-exit-if-insufficient) + (let* ((spacedat (car (common:check-db-dir-space))) ;; look only at worst for now + (is-ok (car spacedat)) + (dbspace (cadr spacedat)) + (required (caddr spacedat)) + (dbdir (cadddr spacedat))) + (if (not is-ok) + (begin + (debug:print-error 0 *default-log-port* "Insufficient space in " dbdir ", require " required ", have " dbspace ", exiting now.") + (exit 1))))) + +;; paths is list of lists ((name path) ... ) +;; +(define (common:get-disk-with-most-free-space disks minsize) + (let ((best #f) + (bestsize 0)) + (for-each + (lambda (disk-num) + (let* ((dirpath (cadr (assoc disk-num disks))) + (freespc (cond + ((not (directory? dirpath)) + (if (common:low-noise-print 300 "disks not a dir " disk-num) + (debug:print 0 *default-log-port* "WARNING: disk " disk-num " at path \"" dirpath "\" is not a directory - ignoring it.")) + -1) + ((not (file-write-access? dirpath)) + (if (common:low-noise-print 300 "disks not writeable " disk-num) + (debug:print 0 *default-log-port* "WARNING: disk " disk-num " at path \"" dirpath "\" is not writeable - ignoring it.")) + -1) + ((not (eq? (string-ref dirpath 0) #\/)) + (if (common:low-noise-print 300 "disks not a proper path " disk-num) + (debug:print 0 *default-log-port* "WARNING: disk " disk-num " at path \"" dirpath "\" is not a fully qualified path - ignoring it.")) + -1) + (else + (get-df dirpath))))) + (if (> freespc bestsize) + (begin + (set! best (cons disk-num dirpath)) + (set! bestsize freespc))))) + (map car disks)) + (if (and best (> bestsize minsize)) + best + #f))) ;; #f means no disk candidate found + +;; see defstruct host at top of file. +;; host: reachable last-update last-used last-cpuload +;; +(define (common:update-host-loads-table hosts-raw) + (let* ((hosts (filter (lambda (x) + (string-match (regexp "^\\S+$") x)) + hosts-raw))) + (for-each + (lambda (hostname) + (let* ((rec (let ((h (hash-table-ref/default *host-loads* hostname #f))) + (if h + h + (let ((h (make-host))) + (hash-table-set! *host-loads* hostname h) + h)))) + (host-info (common:get-host-info hostname)) + (is-reachable (car host-info)) + (last-reached-time (cadr host-info)) + (load (caddr host-info))) + (host-reachable-set! rec is-reachable) + (host-last-update-set! rec last-reached-time) + (host-last-cpuload-set! rec load))) + hosts))) + +;; go through the hosts from least recently used to most recently used, pick the first that meets the load criteral from the +;; [host-rules] section. +;; +(define (common:get-least-loaded-host hosts-raw host-type configdat) + (let* ((rdat (configf:lookup configdat "host-rules" host-type)) + (rules (common:val->alist (or rdat "") convert: #t)) ;; maxnload, maxnjobs, maxjobrate + (maxnload (common:alist-ref/default 'maxnload rules 1.5)) ;; max normalized load + (maxnjobs (common:alist-ref/default 'maxnjobs rules 1.5)) ;; max normalized number of jobs + (maxjobrate (common:alist-ref/default 'maxjobrate rules (/ 1 6))) ;; max rate of submitting jobs to a given host in jobs/second + (hosts (filter (lambda (x) + (string-match (regexp "^\\S+$") x)) + hosts-raw)) + ;; (best-host #f) + (get-rec (lambda (hostname) + ;; (print "get-rec hostname=" hostname) + (let ((h (hash-table-ref/default *host-loads* hostname #f))) + (if h + h + (let ((h (make-host))) + (hash-table-set! *host-loads* hostname h) + h))))) + (best-load 99999) + (curr-time (current-seconds)) + (get-hosts-sorted (lambda (hosts) + (sort hosts (lambda (a b) + (let ((a-rec (get-rec a)) + (b-rec (get-rec b))) + ;; (print "a=" a " a-rec=" a-rec " host-last-used=" (host-last-used a-rec)) + ;; (print "b=" b " b-rec=" b-rec " host-last-used=" (host-last-used b-rec)) + (< (host-last-used a-rec) + (host-last-used b-rec)))))))) + (debug:print 0 *default-log-port* "INFO: hosts-sorted=" (get-hosts-sorted hosts)) + (if (null? hosts) + #f ;; no hosts to select from. All done and giving up now. + (let ((hosts-sorted (get-hosts-sorted hosts))) + (common:update-host-loads-table hosts) + (let loop ((hostname (car hosts-sorted)) + (tal (cdr hosts-sorted)) + (best-host #f)) + (let* ((rec (get-rec hostname)) + (reachable (host-reachable rec)) + (load (host-last-cpuload rec)) + (last-used (host-last-used rec)) + (delta (- curr-time last-used)) + (job-rate (if (> delta 0) + (/ 1 delta) + 999)) ;; jobs per second + (new-best + (cond + ((not reachable) + (debug:print 0 *default-log-port* "Skipping host " hostname " as it cannot be reached.") + best-host) + ((and (< load maxnload) ;; load is acceptable + (< job-rate maxjobrate)) ;; job rate is acceptable + (set! best-load load) + hostname) + (else best-host)))) + (debug:print 0 *default-log-port* "INFO: Trying host " hostname " with load " load ", last used " delta " seconds ago, with job-rate " job-rate " for running a test." ) + (if new-best + (begin ;; found a host, return it + (debug:print 0 *default-log-port* "INFO: Found host: " new-best " load: " load " last-used: " delta " seconds ago, with job-rate: " job-rate) + (host-last-used-set! rec curr-time) + new-best) + (if (null? tal) #f (loop (car tal)(cdr tal) best-host))))))))) + +(define (common:wait-for-cpuload maxload-in numcpus-in waitdelay #!key (count 1000) (msg #f)(remote-host #f)) + (let* ((loadavg (common:get-cpu-load remote-host)) + (numcpus (if (< 1 numcpus-in) ;; not possible + (common:get-num-cpus remote-host) + numcpus-in)) + (maxload (max maxload-in 0.5)) ;; so maxload must be greater than 0.5 for now BUG - FIXME? + (first (car loadavg)) + (next (cadr loadavg)) + (adjload (* maxload (max 1 numcpus))) ;; possible bug where numcpus (or could be maxload) is zero, crude fallback is to at least use 1 + (loadjmp (- first next)) + (adjwait (+ (random 10)(/ (- 1000 count) 10) waitdelay))) ;; add some randomness to the time to break any alignment where netbatch dumps many jobs to machines simultaneously + (cond + ((and (> first adjload) + (> count 0)) + (debug:print-info 0 *default-log-port* "server start delayed " adjwait " seconds due to load " first " exceeding max of " adjload " on server " (or remote-host (get-host-name)) " (normalized load-limit: " maxload ") " (if msg msg "")) + (thread-sleep! adjwait) + (common:wait-for-cpuload maxload numcpus waitdelay count: (- count 1) msg: msg remote-host: remote-host)) + ((and (> loadjmp numcpus) + (> count 0)) + (debug:print-info 0 *default-log-port* "waiting " adjwait " seconds due to load jump " loadjmp " > numcpus " numcpus (if msg msg "")) + (thread-sleep! adjwait) + (common:wait-for-cpuload maxload numcpus waitdelay count: (- count 1) msg: msg remote-host: remote-host))))) + +(define (common:wait-for-homehost-load maxload msg) + (let* ((hh-dat (if (common:on-homehost?) ;; if we are on the homehost then pass in #f so the calls are local. + #f + (common:get-homehost))) + (hh (if hh-dat (car hh-dat) #f)) + (numcpus (common:get-num-cpus hh))) + (common:wait-for-normalized-load maxload msg hh))) + +(define (common:get-num-cpus remote-host) + (let* ((actual-host (or remote-host (get-host-name)))) + (or (common:get-cached-info actual-host "num-cpus" age: 86400) ;; hosts had better not be changing the number of cpus too often! + (let* ((proc (lambda () + (let loop ((numcpu 0) + (inl (read-line))) + (if (eof-object? inl) + (begin + (common:write-cached-info remote-host "num-cpus" numcpu) + numcpu) + (loop (if (string-match "^processor\\s+:\\s+\\d+$" inl) + (+ numcpu 1) + numcpu) + (read-line)))))) + (result (if remote-host + (with-input-from-pipe + (conc "ssh " remote-host " cat /proc/cpuinfo") + proc) + (with-input-from-file "/proc/cpuinfo" proc)))) + (common:write-cached-info actual-host "num-cpus" result) + result)))) + +;; wait for normalized cpu load to drop below maxload +;; +(define (common:wait-for-normalized-load maxload msg remote-host) + (let ((num-cpus (common:get-num-cpus remote-host))) + (common:wait-for-cpuload maxload num-cpus 15 msg: msg remote-host: remote-host))) + + +) + ADDED utils/gen-list-of-functions.sh Index: utils/gen-list-of-functions.sh ================================================================== --- /dev/null +++ utils/gen-list-of-functions.sh @@ -0,0 +1,8 @@ +#!/bin/bash + +# extract a list of functions from a .scm file + +INFILE=$1 + +grep -E '^\(define\s+\(' $INFILE|cut -f3 -d\(|tr ')' ' '|cut -f1 -d' ' + ADDED utils/get-procedures.sh Index: utils/get-procedures.sh ================================================================== --- /dev/null +++ utils/get-procedures.sh @@ -0,0 +1,5 @@ +#!/bin/bash + +fname=$1 + +grep '(define (' $fname | tr '()' ' '|awk '{print $2}'