Index: Makefile ================================================================== --- Makefile +++ Makefile @@ -27,14 +27,14 @@ 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 + 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 # 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 \ @@ -71,11 +71,11 @@ PNGFILES = $(shell cd docs/manual;ls *png) #all : $(PREFIX)/bin/.$(ARCHSTR) mtest dboard mtut ndboard all : $(PREFIX)/bin/.$(ARCHSTR) mtest dboard mtut -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 showmtesthash: @echo $(MTESTHASH) @@ -83,12 +83,12 @@ 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 \ @@ -104,25 +104,25 @@ 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 \ + +# 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,21 +156,29 @@ 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 @@ -303,11 +311,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 +410,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: db.scm ================================================================== --- db.scm +++ db.scm @@ -1332,11 +1332,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; 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 @@ -53,10 +53,14 @@ (declare (uses tasks)) ;; only used for debugging. (declare (uses env)) (declare (uses diff-report)) (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 +114,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 +297,11 @@ "-set-toplog" "-runstep" "-logpro" "-m" "-rerun" + "-days" "-rename-run" "-to" ;; values and messages ":category" @@ -403,10 +410,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,11 +580,11 @@ (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"))) @@ -1038,11 +1047,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 +1068,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 +1667,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"))) @@ -2174,10 +2220,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]) Index: mtut.scm ================================================================== --- mtut.scm +++ mtut.scm @@ -140,10 +140,12 @@ Run management: run : initiate or resume a run, already completed and in-progress tests are not affected. rerun-clean : clean and rerun all not completed pass/fail tests rerun-all : clean and rerun entire run + kill-run : kill all tests in run + kill-rerun : kill all tests in run and restart non-completed tests remove : remove runs set-ss : set state/status archive : compress and move test data to archive disk kill : stop tests or entire runs db : database utilities @@ -247,10 +249,12 @@ ;; alist to map actions to old megatest commands (define *action-keys* '((run . "-run") (rerun-clean . "-rerun-clean") (rerun-all . "-rerun-all") + (kill-run . "-kill-runs") + (kill-rerun . "-kill-rerun") (sync . "") (archive . "-archive") (set-ss . "-set-state-status") (remove . "-remove-runs"))) @@ -492,10 +496,12 @@ (with-input-from-string data (lambda () (read)))) +;; moved to portlogger - TODO: remove from here and get from portlogger +;; (define (is-port-in-use port-num) (let* ((ret #f)) (let-values (((inp oup pid) (process "netstat" (list "-tulpn" )))) (let loop ((inl (read-line inp))) @@ -1443,11 +1449,11 @@ (set! *default-log-port* oup) ))) (if *action* (case (string->symbol *action*) - ((run remove rerun rerun-clean rerun-all set-ss archive kill list) + ((run remove rerun rerun-clean rerun-all set-ss archive kill list kill-run kill-rerun) (let* ((mtconfdat (simple-setup (args:get-arg "-start-dir"))) (mtconf (car mtconfdat)) (area (args:get-arg "-area")) ;; look up the area to dispatch to from [areas] section (areasec (if area (configf:lookup mtconf "areas" area) #f)) (areadat (if areasec (common:val->alist areasec) #f)) ADDED nmsg-transport.scm Index: nmsg-transport.scm ================================================================== --- /dev/null +++ nmsg-transport.scm @@ -0,0 +1,117 @@ + +;; Copyright 2006-2012, Matthew Welland. +;; +;; This file is part of Megatest. +;; +;; Megatest is free software: you can redistribute it and/or modify +;; it under the terms of the GNU General Public License as published by +;; the Free Software Foundation, either version 3 of the License, or +;; (at your option) any later version. +;; +;; Megatest is distributed in the hope that it will be useful, +;; but WITHOUT ANY WARRANTY; without even the implied warranty of +;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +;; GNU General Public License for more details. +;; +;; You should have received a copy of the GNU General Public License +;; along with Megatest. If not, see . + +(declare (unit nmsg-transport)) + +(module + nmsg-transport + ( + * + ) + +(import scheme posix chicken data-structures ports) + +(use pkts) +(use nanomsg srfi-18) + +;;start a server, returns the connection +;; +(define (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) +;; +(define (open-send-close host-port msg attrib #!key (timeout 3)(proc #f)) ;; default timeout is 3 seconds + (let ((req (nn-socket 'req)) + (uri (conc "tcp://" host-port)) + (res #f) + ;; (contacts (alist-ref 'contact attrib)) + (mode (alist-ref 'mode attrib))) + (handle-exceptions + exn + (let ((emsg ((condition-property-accessor 'exn 'message) exn))) + ;; Send notification + (if proc (proc exn emsg)) + #f) + (nn-connect req uri) + (print "Connected to the server " ) + (nn-send req msg) + (print "Request Sent") + (let* ((th1 (make-thread (lambda () + (let ((resp (nn-recv req))) + (nn-close req) + (set! res (if (equal? resp "ok") + #t + #f)))) + "recv thread")) + (th2 (make-thread (lambda () + (thread-sleep! timeout) + (thread-terminate! th1)) + "timer thread"))) + (thread-start! th1) + (thread-start! th2) + (thread-join! th1) + res)))) + +;; default timeout is 3 seconds +;; +(define (open-send-receive host-port msg attrib #!key (timeout 3)(proc #f)) + (let ((req (nn-socket 'req)) + (uri (conc "tcp://" host-port)) + (res #f) + (mode (alist-ref 'mode attrib))) + (handle-exceptions + exn + (let ((emsg ((condition-property-accessor 'exn 'message) exn))) + ;; Send notification + (if proc (proc exn emsg)) + #f) + (nn-connect req uri) + (print "Connected to the server " ) + (nn-send req msg) + (print "Request Sent") + ;; receive code here + ;;(print (nn-recv req)) + (let* ((th1 (make-thread (lambda () + (let ((resp (nn-recv req))) + (nn-close req) + (print resp) + (set! res (if (equal? resp "ok") + #t + #f)))) + "recv thread")) + (th2 (make-thread (lambda () + (thread-sleep! timeout) + (thread-terminate! th1)) + "timer thread"))) + (thread-start! th1) + (thread-start! th2) + (thread-join! th1) + res)))) + +) 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 @@ -23,18 +23,72 @@ (declare (unit rmt)) (declare (uses api)) (declare (uses http-transport)) (include "common_records.scm") +(declare (uses portlogger)) +(import portlogger) +(declare (uses nmsg-transport)) +(import (prefix nmsg-transport nmsg:)) + +(use (prefix pkts pkts:) srfi-18) ;; ;; 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 +;;====================================================================== +;; N A N O M S G S E R V E R +;;====================================================================== + +(defstruct nmsg + (conn #f) + (hosts (make-hash-table)) + pkt + (pktspec '((server (hostname . h) + (port . p) + (pid . i) + ))) + (mutex (make-mutex)) + ) + +;; make it a global +(define *nmsg-conndat* (make-nmsg)) + +;; 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 (rmt:start-nmsg #!key (force-server-type #f)) + (mutex-lock! (nmsg-mutex *nmsg-conndat*)) + (let* ((server-type (or force-server-type + (if (args:any? "-run" "-server") + 'main + 'passive))) + (port-num (portlogger:open-run-close portlogger:find-port)) + (nmsg-conn (nmsg:start-server port-num)) + (pktspec (nmsg-pktspec *nmsg-conndat*)) + (pktdir (conc (get-environment-variable "MT_RUN_AREA_HOME") + "/.server-pkts"))) + ;; server is started, now create pkt if needed + (if (eq? server-type 'main) + (nmsg-pkt-set! *nmsg-conndat* + (pkts:write-alist-pkt + pktdir + `((hostname . ,(get-host-name)) + (port . ,port-num) + (pid . ,(current-process-id))) + pktspec))) + (nmsg-conn-set! *nmsg-conndat* nmsg-conn) + )) ;;====================================================================== ;; 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 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)) 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 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}'