Index: Makefile ================================================================== --- Makefile +++ Makefile @@ -3,11 +3,11 @@ CSCOPTS= SRCFILES = common.scm items.scm launch.scm \ ods.scm runconfig.scm server.scm configf.scm \ db.scm keys.scm margs.scm megatest-version.scm \ - process.scm runs.scm tasks.scm tests.scm + process.scm runs.scm tasks.scm tests.scm GUISRCF = dashboard.scm dashboard-tests.scm dashboard-guimonitor.scm dashboard-main.scm OFILES = $(SRCFILES:%.scm=%.o) GOFILES = $(GUISRCF:%.scm=%.o) Index: common.scm ================================================================== --- common.scm +++ common.scm @@ -37,10 +37,11 @@ (define *waiting-queue* (make-hash-table)) (define *globalexitstatus* 0) ;; attempt to work around possible thread issues (define *passnum* 0) ;; when running track calls to run-tests or similar (define *verbosity* 1) (define *rpc:listener* #f) ;; if set up for server communication this will hold the tcp port +(define *runremote* #f) ;; if set up for server communication this will hold (define (get-with-default val default) (let ((val (args:get-arg val))) (if val val default))) Index: db.scm ================================================================== --- db.scm +++ db.scm @@ -10,10 +10,13 @@ ;;====================================================================== ;;====================================================================== ;; Database access ;;====================================================================== + +(require-extension (srfi 18) extras tcp rpc) +(import (prefix rpc rpc:)) (use sqlite3 srfi-1 posix regex regex-case srfi-69 csv-xml) (import (prefix sqlite3 sqlite3:)) (declare (unit db)) @@ -22,10 +25,11 @@ (declare (uses ods)) (include "common_records.scm") (include "db_records.scm") (include "key_records.scm") +(include "run_records.scm") (define (open-db) ;; (conc *toppath* "/megatest.db") (car *configinfo*))) (let* ((dbpath (conc *toppath* "/megatest.db")) ;; fname) (configdat (car *configinfo*)) (dbexists (file-exists? dbpath)) @@ -85,10 +89,11 @@ run_duration INTEGER DEFAULT 0, comment TEXT DEFAULT '', event_time TIMESTAMP, fail_count INTEGER DEFAULT 0, pass_count INTEGER DEFAULT 0, + archived INTEGER DEFAULT 0, -- 0=no, 1=in progress, 2=yes CONSTRAINT testsconstraint UNIQUE (run_id, testname, item_path) );") (sqlite3:execute db "CREATE INDEX tests_index ON tests (run_id, testname);") (sqlite3:execute db "CREATE VIEW runs_tests AS SELECT * FROM runs INNER JOIN tests ON runs.id=tests.run_id;") (sqlite3:execute db "CREATE TABLE IF NOT EXISTS test_steps @@ -130,10 +135,11 @@ type TEXT DEFAULT '', CONSTRAINT test_data_constraint UNIQUE (test_id,category,variable));") ;; Must do this *after* running patch db !! No more. (db:set-var db "MEGATEST_VERSION" megatest-version) )) + (server:client-setup db) db)) ;;====================================================================== ;; TODO: ;; put deltas into an assoc list with version numbers @@ -210,11 +216,14 @@ (db:set-var db "MEGATEST_VERSION" 1.29) (sqlite3:execute db "ALTER TABLE test_steps ADD COLUMN logfile TEXT DEFAULT '';") (sqlite3:execute db "ALTER TABLE tests ADD COLUMN shortdir TEXT DEFAULT '';")) ((< mver 1.36) (db:set-var db "MEGATEST_VERSION" 1.36) - (sqlite3:execute db "ALTER TABLER test_meta ADD COLUMN jobgroup TEXT DEFAULT 'default';")) + (sqlite3:execute db "ALTER TABLE test_meta ADD COLUMN jobgroup TEXT DEFAULT 'default';")) + ((< mver 1.37) + (db:set-var db "MEGATEST_VERSION" 1.37) + (sqlite3:execute db "ALTER TABLE tests ADD COLUMN archived INTEGER DEFAULT 0;")) ((< mver megatest-version) (db:set-var db "MEGATEST_VERSION" megatest-version)))))) ;;====================================================================== ;; meta get and set vars @@ -412,10 +421,14 @@ (define (db:test-set-state-status-by-id db test-id newstate newstatus newcomment) (if newstate (sqlite3:execute db "UPDATE tests SET state=? WHERE id=?;" newstate test-id)) (if newstatus (sqlite3:execute db "UPDATE tests SET status=? WHERE id=?;" newstatus test-id)) (if newcomment (sqlite3:execute db "UPDATE tests SET comment=? WHERE id=?;" newcomment test-id))) +(define (db:test-set-state-status-by-run-id-testname db run-id test-name item-path status state) + (sqlite3:execute db "UPDATE tests SET state=?,status=?,event_time=strftime('%s','now') WHERE run_id=? AND testname=? AND item_path=?;" + state status run-id test-name item-path)) + (define (db:get-count-tests-running db) (let ((res 0)) (sqlite3:for-each-row (lambda (count) (set! res count)) @@ -468,24 +481,31 @@ "SELECT id,run_id,testname,state,status,event_time,host,cpuload,diskfree,uname,rundir,item_path,run_duration,final_logf,comment FROM tests WHERE id=?;" test-id) res)) -(define (db:test-set-comment db run-id testname item-path comment) +(define (db:test-set-comment db run-id test-name item-path comment) (sqlite3:execute db "UPDATE tests SET comment=? WHERE run_id=? AND testname=? AND item_path=?;" - comment run-id testname item-path)) + comment run-id test-name item-path)) ;; -(define (db:test-set-rundir! db run-id testname item-path rundir) +(define (db:test-set-rundir! db run-id test-name item-path rundir) (sqlite3:execute db "UPDATE tests SET rundir=? WHERE run_id=? AND testname=? AND item_path=?;" - rundir run-id testname item-path)) + rundir run-id test-name item-path)) + +(define (db:test-set-log! db run-id test-name item-path logf) + (sqlite3:execute db "UPDATE tests SET final_logf=? WHERE run_id=? AND testname=? AND item_path=?;" + logf run-id test-name item-path)) +;;====================================================================== ;; Misc. test related queries +;;====================================================================== + (define (db:test-get-paths-matching db keynames target) (let* ((res '()) (itempatt (if (args:get-arg "-itempatt")(args:get-arg "-itempatt") "%")) (testpatt (if (args:get-arg "-testpatt")(args:get-arg "-testpatt") "%")) (statepatt (if (args:get-arg ":state") (args:get-arg ":state") "%")) @@ -506,10 +526,101 @@ (lambda (p) (set! res (cons p res))) db qrystr) res)) + +(define (db:test-get-test-records-matching db keynames target) + (let* ((res '()) + (itempatt (if (args:get-arg "-itempatt")(args:get-arg "-itempatt") "%")) + (testpatt (if (args:get-arg "-testpatt")(args:get-arg "-testpatt") "%")) + (statepatt (if (args:get-arg ":state") (args:get-arg ":state") "%")) + (statuspatt (if (args:get-arg ":status") (args:get-arg ":status") "%")) + (runname (if (args:get-arg ":runname") (args:get-arg ":runname") "%")) + (keystr (string-intersperse + (map (lambda (key val) + (conc "r." key " like '" val "'")) + keynames + (string-split target "/")) + " AND ")) + (qrystr (conc "SELECT + t.id + t.run_id + t.testname + t.host + t.cpuload + t.diskfree + t.uname + t.rundir + t.shortdir + t.item_path + t.state + t.status + t.attemptnum + t.final_logf + t.logdat + t.run_duratio + t.comment + t.event_time + t.fail_count + t.pass_count + t.archived + + + + FROM tests AS t INNER JOIN runs AS r ON t.run_id=r.id WHERE " + keystr " AND r.runname LIKE '" runname "' AND item_path LIKE '" itempatt "' AND testname LIKE '" + testpatt "' AND t.state LIKE '" statepatt "' AND t.status LIKE '" statuspatt + "'ORDER BY t.event_time ASC;"))) + (debug:print 3 "qrystr: " qrystr) + (sqlite3:for-each-row + (lambda (p) + (set! res (cons p res))) + db + qrystr) + res)) + +(define (db:test-update-meta-info db run-id test-name item-path minutes cpuload diskfree tmpfree) + (if (not item-path) + (begin (debug:print 0 "WARNING: ITEMPATH not set.") + (set! item-path ""))) + (sqlite3:execute + db + "UPDATE tests SET cpuload=?,diskfree=?,run_duration=?,state='RUNNING' WHERE run_id=? AND testname=? AND item_path=? AND state NOT IN ('COMPLETED','KILLREQ','KILLED');" + cpuload + diskfree + minutes + run-id + test-name + item-path)) + +(define (db:roll-up-pass-fail-counts db run-id test-name item-path status) + (if (and (not (equal? item-path "")) + (or (equal? status "PASS") + (equal? status "WARN") + (equal? status "FAIL") + (equal? status "WAIVED") + (equal? status "RUNNING"))) + (begin + (sqlite3:execute + db + "UPDATE tests + SET fail_count=(SELECT count(id) FROM tests WHERE run_id=? AND testname=? AND item_path != '' AND status='FAIL'), + pass_count=(SELECT count(id) FROM tests WHERE run_id=? AND testname=? AND item_path != '' AND (status='PASS' OR status='WARN' OR status='WAIVED')) + WHERE run_id=? AND testname=? AND item_path='';" + run-id test-name run-id test-name run-id test-name) + (if (equal? status "RUNNING") ;; running takes priority over all other states, force the test state to RUNNING + (sqlite3:execute db "UPDATE tests SET state=? WHERE run_id=? AND testname=? AND item_path='';" "RUNNING" run-id test-name) + (sqlite3:execute + db + "UPDATE tests + SET state=CASE WHEN (SELECT count(id) FROM tests WHERE run_id=? AND testname=? AND item_path != '' AND state in ('RUNNING','NOT_STARTED')) > 0 THEN + 'RUNNING' + ELSE 'COMPLETED' END, + status=CASE WHEN fail_count > 0 THEN 'FAIL' WHEN pass_count > 0 AND fail_count=0 THEN 'PASS' ELSE 'UNKNOWN' END + WHERE run_id=? AND testname=? AND item_path='';" + run-id test-name run-id test-name))))) ;;====================================================================== ;; Tests meta data ;;====================================================================== @@ -792,10 +903,29 @@ ;; if the test is not found then clearly the waiton is not met... (if (not ever-seen)(set! result (cons waitontest-name result))))) waitons) (delete-duplicates result)))) +(define (db:teststep-set-status! db run-id test-name teststep-name state-in status-in item-path comment logfile) + (debug:print 4 "run-id: " run-id " test-name: " test-name) + (let* ((state (check-valid-items "state" state-in)) + (status (check-valid-items "status" status-in)) + (testdat (db:get-test-info db run-id test-name item-path))) + (debug:print 5 "testdat: " testdat) + (if (and testdat ;; if the section exists then force specification BUG, I don't like how this works. + (or (not state)(not status))) + (debug:print 0 "WARNING: Invalid " (if status "status" "state") + " value \"" (if status state-in status-in) "\", update your validvalues section in megatest.config")) + (if testdat + (let ((test-id (test:get-id testdat))) + ;; FIXME - this should not update the logfile unless it is specified. + (sqlite3:execute db + "INSERT OR REPLACE into test_steps (test_id,stepname,state,status,event_time,comment,logfile) VALUES(?,?,?,?,strftime('%s','now'),?,?);" + test-id teststep-name state-in status-in (if comment comment "") (if logfile logfile "")) + #t) ;; fake out a #t - could be execute is returning something complicated + (debug:print 0 "ERROR: Can't update " test-name " for run " run-id " -> no such test in db")))) + ;;====================================================================== ;; Extract ods file from the db ;;====================================================================== ;; runspatt is a comma delimited list of run patterns @@ -916,5 +1046,76 @@ results) ;; brutal clean up (system "rm -rf tempdir"))) ;; (db:extract-ods-file db "outputfile.ods" '(("sysname" "%")("fsname" "%")("datapath" "%")) "%") + + +;;====================================================================== +;; REMOTE DB ACCESS VIA RPC +;;====================================================================== + +(define (rdb:set-tests-state-status db run-id testnames currstate currstatus newstate newstatus) + (if *runremote* + (let ((host (vector-ref *runremote* 0)) + (port (vector-ref *runremote* 1))) + ((rpc:procedure 'rdb:set-tests-state-status host port) + run-id testnames currstate currstatus newstate newstatus)) + (db:set-tests-state-status db run-id testnames currstate currstatus newstate newstatus))) + +(define (rdb:teststep-set-status! db run-id test-name teststep-name state-in status-in itemdat comment logfile) + (let ((item-path (item-list->path itemdat))) + (if *runremote* + (let ((host (vector-ref *runremote* 0)) + (port (vector-ref *runremote* 1))) + ((rpc:procedure 'rdb:teststep-set-status! host port) + run-id test-name teststep-name state-in status-in item-path comment logfile)) + (db:teststep-set-status! db run-id test-name teststep-name state-in status-in item-path comment logfile)))) + +(define (rdb:test-update-meta-info db run-id test-name itemdat minutes cpuload diskfree tmpfree) + (let ((item-path (item-list->path itemdat))) + (if *runremote* + (let ((host (vector-ref *runremote* 0)) + (port (vector-ref *runremote* 1))) + ((rpc:procedure 'rdb:test-update-meta-info host port) + run-id test-name item-path minutes cpuload diskfree tmpfree)) + (db:test-update-meta-info db run-id test-name item-path minutes cpuload diskfree tmpfree)))) + +(define (rdb:test-set-state-status-by-run-id-testname db run-id test-name item-path status state) + (if *runremote* + (let ((host (vector-ref *runremote* 0)) + (port (vector-ref *runremote* 1))) + ((rpc:procedure 'rdb:test-set-state-status-by-run-id-testname host port) + run-id test-name item-path status state)) + (db:test-set-state-status-by-run-id-testname db run-id test-name item-path status state))) + +(define (rdb:csv->test-data db test-id csvdata) + (if *runremote* + (let ((host (vector-ref *runremote* 0)) + (port (vector-ref *runremote* 1))) + ((rpc:procedure 'rdb:csv->test-data host port) + test-id csvdata)) + (db:csv->test-data db test-id csvdata))) + +(define (rdb:roll-up-pass-fail-counts db run-id test-name item-path status) + (if *runremote* + (let ((host (vector-ref *runremote* 0)) + (port (vector-ref *runremote* 1))) + ((rpc:procedure 'rdb:roll-up-pass-fail-counts host port) + run-id test-name item-path status)) + (db:roll-up-pass-fail-counts db run-id test-name item-path status))) + +(define (rdb:test-set-comment db run-id test-name item-path comment) + (if *runremote* + (let ((host (vector-ref *runremote* 0)) + (port (vector-ref *runremote* 1))) + ((rpc:procedure 'rdb:test-set-comment host port) + run-id test-name item-path comment)) + (db:test-set-comment db run-id test-name item-path comment))) + +(define (rdb:test-set-log! db run-id test-name item-path logf) + (if *runremote* + (let ((host (vector-ref *runremote* 0)) + (port (vector-ref *runremote* 1))) + ((rpc:procedure 'rpc:test-set-log! host port) + run-id test-name item-path logf)) + (db:test-set-log! db run-id test-name item-path logf))) Index: items.scm ================================================================== --- items.scm +++ items.scm @@ -16,25 +16,30 @@ (declare (unit items)) (declare (uses common)) (include "common_records.scm") -;; Mostly worked = puts out all combinations? -(define (process-itemlist-try1 curritemkey itemlist) - (let loop ((hed (car itemlist)) - (tal (cdr itemlist))) - (if (null? tal) - (for-each (lambda (item) - (debug:print 6 "curritemkey: " (append curritemkey (list item)))) - (cadr hed)) - (begin - (for-each (lambda (item) - (process-itemlist (append curritemkey (list item)) tal)) - (cadr hed)) - (loop (car tal)(cdr tal)))))) - -;; Mostly worked = puts out all combinations? +;; Puts out all combinations +(define (process-itemlist hierdepth curritemkey itemlist) + (let ((res '())) + (if (not hierdepth) + (set! hierdepth (length itemlist))) + (let loop ((hed (car itemlist)) + (tal (cdr itemlist))) + (if (null? tal) + (for-each (lambda (item) + (if (> (length curritemkey) (- hierdepth 2)) + (set! res (append res (list (append curritemkey (list (list (car hed) item)))))))) + (cadr hed)) + (begin + (for-each (lambda (item) + (set! res (append res (process-itemlist hierdepth (append curritemkey (list (list (car hed) item))) tal)))) + (cadr hed)) + (loop (car tal)(cdr tal))))) + res)) + +;; Puts out all combinations (define (process-itemlist hierdepth curritemkey itemlist) (let ((res '())) (if (not hierdepth) (set! hierdepth (length itemlist))) (let loop ((hed (car itemlist)) Index: launch.scm ================================================================== --- launch.scm +++ launch.scm @@ -179,11 +179,11 @@ ;; call the command using mt_ezstep (set! script (conc "mt_ezstep " stepname " " (if prevstep prevstep "-") " " stepcmd)) (debug:print 4 "script: " script) - (teststep-set-status! db run-id test-name stepname "start" "-" itemdat #f #f) + (rdb:teststep-set-status! db run-id test-name stepname "start" "-" itemdat #f #f) ;; now launch (let ((pid (process-run script))) (let processloop ((i 0)) (let-values (((pid-val exit-status exit-code)(process-wait pid #t))) (mutex-lock! m) @@ -194,11 +194,11 @@ (if (eq? pid-val 0) (begin (thread-sleep! 2) (processloop (+ i 1)))) )) - (teststep-set-status! db run-id test-name stepname "end" (vector-ref exit-info 2) itemdat #f (if logpro-used (conc stepname ".html") "")) + (rdb:teststep-set-status! db run-id test-name stepname "end" (vector-ref exit-info 2) itemdat #f (if logpro-used (conc stepname ".html") "")) (if logpro-used (test-set-log! db run-id test-name itemdat (conc stepname ".html"))) ;; set the test final status (let* ((this-step-status (cond ((and (eq? (vector-ref exit-info 2) 2) logpro-used) 'warn) @@ -247,11 +247,11 @@ (diskfree (get-df (current-directory))) (tmpfree (get-df "/tmp"))) (if (not cpuload) (begin (debug:print 0 "WARNING: CPULOAD not found.") (set! cpuload "n/a"))) (if (not diskfree) (begin (debug:print 0 "WARNING: DISKFREE not found.") (set! diskfree "n/a"))) (set! kill-job? (test-get-kill-request db run-id test-name itemdat)) - (test-update-meta-info db run-id test-name itemdat minutes cpuload diskfree tmpfree) + (rdb:test-update-meta-info db run-id test-name itemdat minutes cpuload diskfree tmpfree) (if kill-job? (begin (mutex-lock! m) (let* ((pid (vector-ref exit-info 0))) (if (number? pid) Index: megatest-version.scm ================================================================== --- megatest-version.scm +++ megatest-version.scm @@ -1,7 +1,7 @@ ;; Always use two digit decimal ;; 1.01, 1.02...1.10,1.11 ... 1.99,2.00.. (declare (unit megatest-version)) -(define megatest-version 1.36) +(define megatest-version 1.37) Index: megatest.scm ================================================================== --- megatest.scm +++ megatest.scm @@ -17,10 +17,11 @@ (declare (uses common)) (declare (uses megatest-version)) (declare (uses margs)) (declare (uses runs)) (declare (uses launch)) +(declare (uses server)) (include "common_records.scm") (include "key_records.scm") (include "db_records.scm") @@ -89,10 +90,14 @@ prior runs with same keys -update-meta : update the tests metadata for all tests -env2file fname : write the environment to fname.csh and fname.sh -setvars VAR1=val1,VAR2=val2 : Add environment variables to a run NB// these are overwritten by values set in config files. + -archive : archive tests, use -target, :runname, -itempatt and -testpatt + -server -|hostname : start the server (reduces contention on megatest.db), use + - to automatically figure out hostname + Spreadsheet generation -extract-ods fname.ods : extract an open document spreadsheet from the database -pathmod path : insert path, i.e. path/runame/itempath/logfile.html will clear the field if no rundir/testname/itempath/logfile if it contains forward slashes the path will be converted @@ -147,10 +152,11 @@ ":value" ":expected" ":tol" ":units" ;; misc + "-server" "-extract-ods" "-pathmod" "-env2file" "-setvars" "-debug" ;; for *verbosity* > 2 @@ -162,10 +168,12 @@ "-test-status" "-set-values" "-load-test-data" "-summarize-items" "-gui" + ;; misc + "-archive" ;; queries "-test-paths" ;; get path(s) to a test, ordered by youngest first "-runall" ;; run all tests "-remove-runs" @@ -172,10 +180,11 @@ "-keepgoing" "-usequeue" "-rebuild-db" "-rollup" "-update-meta" + "-v" ;; verbose 2, more than normal (normal is 1) "-q" ;; quiet 0, errors/warnings only ) args:arg-hash 0)) @@ -375,10 +384,20 @@ (args:get-arg "-itempatt") user (make-hash-table))))) ;;====================================================================== +;; Start the server +;;====================================================================== +(if (args:get-arg "-server") + (let* ((toppath (setup-for-run)) + (db (if toppath (open-db) #f))) + (if db + (server:start db (args:get-arg "-server")) + (debug:print 0 "ERROR: Failed to setup for megatest")))) + +;;;====================================================================== ;; Rollup into a run ;;====================================================================== (if (args:get-arg "-rollup") (general-run-call "-rollup" @@ -391,11 +410,11 @@ user)))) ;;====================================================================== ;; Get paths to tests ;;====================================================================== -;; run all tests are are Not COMPLETED and PASS or CHECK +;; Get test paths matching target, runname, testpatt, and itempatt (if (args:get-arg "-test-paths") ;; if we are in a test use the MT_CMDINFO data (if (getenv "MT_CMDINFO") (let* ((startingdir (current-directory)) (cmdinfo (read (open-input-string (base64:base64-decode (getenv "MT_CMDINFO"))))) @@ -416,10 +435,58 @@ (exit 1))) (if (not (setup-for-run)) (begin (debug:print 0 "Failed to setup, giving up on -test-paths, exiting") (exit 1))) + (set! db (open-db)) + (let* ((itempatt (args:get-arg "-itempatt")) + (keys (db-get-keys db)) + (keynames (map key:get-fieldname keys)) + (paths (db:test-get-paths-matching db keynames target))) + (set! *didsomething* #t) + (for-each (lambda (path) + (print path)) + paths))) + ;; else do a general-run-call + (general-run-call + "-test-paths" + "Get paths to tests" + (lambda (db target runname keys keynames keyvallst) + (let* ((itempatt (args:get-arg "-itempatt")) + (paths (db:test-get-paths-matching db keynames target))) + (for-each (lambda (path) + (print path)) + paths)))))) + +;;====================================================================== +;; Archive tests +;;====================================================================== +;; Archive tests matching target, runname, testpatt, and itempatt +(if (args:get-arg "-archive") + ;; if we are in a test use the MT_CMDINFO data + (if (getenv "MT_CMDINFO") + (let* ((startingdir (current-directory)) + (cmdinfo (read (open-input-string (base64:base64-decode (getenv "MT_CMDINFO"))))) + (testpath (assoc/default 'testpath cmdinfo)) + (test-name (assoc/default 'test-name cmdinfo)) + (runscript (assoc/default 'runscript cmdinfo)) + (db-host (assoc/default 'db-host cmdinfo)) + (run-id (assoc/default 'run-id cmdinfo)) + (itemdat (assoc/default 'itemdat cmdinfo)) + (db #f) + (state (args:get-arg ":state")) + (status (args:get-arg ":status")) + (target (args:get-arg "-target"))) + (change-directory testpath) + (if (not target) + (begin + (debug:print 0 "ERROR: -target is required.") + (exit 1))) + (if (not (setup-for-run)) + (begin + (debug:print 0 "Failed to setup, giving up on -archive, exiting") + (exit 1))) (set! db (open-db)) (let* ((itempatt (args:get-arg "-itempatt")) (keys (db-get-keys db)) (keynames (map key:get-fieldname keys)) (paths (db:test-get-paths-matching db keynames target))) @@ -489,11 +556,11 @@ (begin (debug:print 0 "Failed to setup, exiting") (exit 1))) (set! db (open-db)) (if (and state status) - (teststep-set-status! db run-id test-name step state status itemdat (args:get-arg "-m") logfile) + (rdb:teststep-set-status! db run-id test-name step state status itemdat (args:get-arg "-m") logfile) (begin (debug:print 0 "ERROR: You must specify :state and :status with every call to -step") (exit 6))) (sqlite3:finalize! db) (set! *didsomething* #t)))) @@ -552,11 +619,11 @@ ((zsh bash sh ash) "2>&1 >"))) (fullcmd (conc "(" (string-intersperse (cons cmd params) " ") ") " redir " " logfile))) ;; mark the start of the test - (teststep-set-status! db run-id test-name stepname "start" "n/a" itemdat (args:get-arg "-m") logfile) + (rdb:teststep-set-status! db run-id test-name stepname "start" "n/a" itemdat (args:get-arg "-m") logfile) ;; close the db (sqlite3:finalize! db) ;; run the test step (debug:print 2 "INFO: Running \"" fullcmd "\"") (change-directory startingdir) @@ -574,11 +641,11 @@ (change-directory startingdir) (set! exitstat (system cmd)) (set! *globalexitstatus* exitstat) ;; no necessary (change-directory testpath) (test-set-log! db run-id test-name itemdat htmllogfile))) - (teststep-set-status! db run-id test-name stepname "end" exitstat itemdat (args:get-arg "-m") logfile) + (rdb:teststep-set-status! db run-id test-name stepname "end" exitstat itemdat (args:get-arg "-m") logfile) (sqlite3:finalize! db) (if (not (eq? exitstat 0)) (exit 254)) ;; (exit exitstat) doesn't work?!? ;; open the db ;; mark the end of the test Index: runs.scm ================================================================== --- runs.scm +++ runs.scm @@ -17,10 +17,11 @@ (declare (uses db)) (declare (uses common)) (declare (uses items)) (declare (uses runconfig)) (declare (uses tests)) +(declare (uses server)) (include "common_records.scm") (include "key_records.scm") (include "db_records.scm") (include "run_records.scm") @@ -210,11 +211,11 @@ ;; have to delete test records where NOT_STARTED since they can cause -keepgoing to ;; get stuck due to becoming inaccessible from a failed test. I.e. if test B depends ;; on test A but test B reached the point on being registered as NOT_STARTED and test ;; A failed for some reason then on re-run using -keepgoing the run can never complete. (db:delete-tests-in-state db run-id "NOT_STARTED") - (db:set-tests-state-status db run-id test-names #f "FAIL" "NOT_STARTED" "FAIL"))) + (rdb:set-tests-state-status db run-id test-names #f "FAIL" "NOT_STARTED" "FAIL"))) ;; now add non-directly referenced dependencies (i.e. waiton) (if (not (null? test-names)) (let loop ((hed (car test-names)) (tal (cdr test-names))) ;; 'return-procs tells the config reader to prep running system but return a proc @@ -409,10 +410,12 @@ (let* ((new-test-path (string-intersperse (cons test-path (map cadr itemdat)) "/")) (new-test-name (if (equal? item-path "") test-name (conc test-name "/" item-path))) ;; just need it to be unique (testdat (db:get-test-info db run-id test-name item-path))) (if (not testdat) (begin + ;; ensure that the path exists before registering the test + (system (conc "mkdir -p " new-test-path)) (register-test db run-id test-name item-path) (set! testdat (db:get-test-info db run-id test-name item-path)))) (change-directory test-path) (case (if force ;; (args:get-arg "-force") 'NOT_STARTED Index: server.scm ================================================================== --- server.scm +++ server.scm @@ -6,12 +6,24 @@ ;; ;; This program is distributed WITHOUT ANY WARRANTY; without even the ;; implied warranty of MERCHANTABILITY or FITNESS FOR A PARTICULAR ;; PURPOSE. +(require-extension (srfi 18) extras tcp rpc) +(import (prefix rpc rpc:)) + +(use sqlite3 srfi-1 posix regex regex-case srfi-69 hostinfo) +(import (prefix sqlite3 sqlite3:)) + (declare (unit server)) +(declare (uses common)) +(declare (uses db)) + +(include "common_records.scm") +(include "db_records.scm") + ;; procstr is the name of the procedure to be called as a string (define (server:autoremote procstr params) (handle-exceptions exn (begin @@ -19,23 +31,79 @@ (apply (eval (string->symbol proc)) params)) (if *runremote* (apply (eval (string->symbol (conc "remote:" procstr))) params) (eval (string->symbol procstr) params)))) -(define (server:start db) +(define (server:start db hostn) (debug:print 0 "Attempting to start the server ...") - (let* ((rpc:listener (server:find-free-port-and-open (rpc:default-server-port))) - (th1 (make-thread - (cute (rpc:make-server rpc:listener) "rpc:server") - 'rpc:server))) - (db:set-var db "SERVER" (conc (get-host-name) ":" (rpc:default-server-port))) + (let* ((rpc:listener (server:find-free-port-and-open (rpc:default-server-port))) + (th1 (make-thread + (cute (rpc:make-server rpc:listener) "rpc:server") + 'rpc:server)) + (hostname (if (string=? "-" hostn) + (get-host-name) + hostn)) + (ipaddrstr (if (string=? "-" hostn) + (string-intersperse (map number->string (u8vector->list (hostname->ip hostname))) ".") + #f)) + (host:port (conc (if ipaddrstr ipaddrstr hostname) ":" (rpc:default-server-port)))) + (db:set-var db "SERVER" host:port) (rpc:publish-procedure! 'remote:run (lambda (procstr . params) (server:autoremote procstr params))) - (set! *rpc:listener* rpc:listener*) - (thread-start! rpc:server))) + + ;;====================================================================== + ;; db specials here + ;;====================================================================== + ;; ** set-tests-state-status + (rpc:publish-procedure! + 'rdb:set-tests-state-status + (lambda (run-id testnames currstate currstatus newstate newstatus) + (db:set-tests-state-status db run-id testnames currstate currstatus newstate newstatus))) + + (rpc:publish-procedure! + 'rdb:teststep-set-status! + (lambda (run-id test-name teststep-name state-in status-in item-path comment logfile) + (db:teststep-set-status! db run-id test-name teststep-name state-in status-in item-path comment logfile))) + + (rpc:publish-procedure! + 'rdb:test-update-meta-info + (lambda (run-id testname item-path minutes cpuload diskfree tmpfree) + (db:test-update-meta-info db run-id testname item-path minutes cpuload diskfree tmpfree))) + + (rpc:publish-procedure! + 'rdb:test-set-state-status-by-run-id-testname + (lambda (run-id test-name item-path status state) + (db:test-set-state-status-by-run-id-testname db run-id test-name item-path status state))) + + (rpc:publish-procedure! + 'rdb:csv->test-data + (lambda (test-id csvdata) + (db:csv->data db test-id csvdata))) + + (rpc:publish-procedure! + 'rdb:roll-up-pass-fail-counts + (lambda (run-id test-name item-path status) + (db:roll-up-pass-fail-counts db run-id test-name item-path status))) + + (rpc:publish-procedure! + 'rdb:test-set-comment + (lambda (run-id test-name item-path comment) + (db:test-set-comment db run-id test-name item-path comment))) + + (rpc:publish-procedure! + 'rpc:test-set-log! + (lambda (run-id test-name item-path logf) + (db:test-set-log! db run-id test-name item-path logf))) + + (set! *rpc:listener* rpc:listener) + (on-exit (lambda () + (sqlite3:execute db "DELETE FROM metadat WHERE var='SERVER' and val=?;" host:port) + (sqlite3:finalize! db))) + (thread-start! th1) + (thread-join! th1))) ;; rpc:server))) (define (server:find-free-port-and-open port) (handle-exceptions exn (begin @@ -47,6 +115,10 @@ (define (server:client-setup db) (let* ((hostinfo (db:get-var db "SERVER")) (hostdat (if hostinfo (string-split hostinfo ":"))) (host (if hostinfo (car hostdat))) (port (if (and hostinfo (> (length hostdat) 1))(cadr hostdat) #f))) - (set! *runremote* (vector host port)))) + (if (and port + (string->number port)) + (debug:print 2 "INFO: Setting up to connect to host " host ":" port)) + (set! *runremote* (if port (vector host (string->number port)) #f)))) + Index: tests.scm ================================================================== --- tests.scm +++ tests.scm @@ -11,11 +11,10 @@ (include "key_records.scm") (include "db_records.scm") (include "run_records.scm") (include "test_records.scm") - (define (register-test db run-id test-name item-path) (let ((item-paths (if (equal? item-path "") (list item-path) (list item-path "")))) (for-each @@ -109,10 +108,11 @@ results) (if (null? tal) (map cdr (hash-table->alist tests-hash)) ;; return a list of the most recent tests (loop (car tal)(cdr tal)))))))))) +;; (define (test-set-status! db run-id test-name state status itemdat-or-path comment dat) (let* ((real-status status) (item-path (if (string? itemdat-or-path) itemdat-or-path (item-list->path itemdat-or-path))) (testdat (db:get-test-info db run-id test-name item-path)) (test-id (if testdat (db:test-get-id testdat) #f)) @@ -135,14 +135,14 @@ (if waived (set! real-status "WAIVED")) (debug:print 4 "real-status " real-status ", waived " waived ", status " status) ;; update the primary record IF state AND status are defined (if (and state status) - (sqlite3:execute db "UPDATE tests SET state=?,status=?,event_time=strftime('%s','now') WHERE run_id=? AND testname=? AND item_path=?;" - state real-status run-id test-name item-path)) + (rdb:test-set-state-status-by-run-id-testname db run-id test-name item-path real-status state)) - ;; if status is "AUTO" then call rollup + ;; if status is "AUTO" then call rollup (note, this one modifies data in test + ;; run area, do not rpc it (yet) (if (and test-id state status (equal? status "AUTO")) (db:test-data-rollup db test-id status)) ;; add metadata (need to do this way to avoid SQL injection issues) @@ -166,11 +166,11 @@ (dcomment (hash-table-ref/default otherdat ":comment" ""))) (debug:print 4 "category: " category ", variable: " variable ", value: " value ", expected: " expected ", tol: " tol ", units: " units) (if (and value expected tol) ;; all three required - (db:csv->test-data db test-id + (rdb:csv->test-data db test-id (conc category "," variable "," value "," expected "," tol "," @@ -177,46 +177,21 @@ units "," dcomment ",," ;; extra comma for status type )))) ;; need to update the top test record if PASS or FAIL and this is a subtest - (if (and (not (equal? item-path "")) - (or (equal? status "PASS") - (equal? status "WARN") - (equal? status "FAIL") - (equal? status "WAIVED") - (equal? status "RUNNING"))) - (begin - (sqlite3:execute - db - "UPDATE tests - SET fail_count=(SELECT count(id) FROM tests WHERE run_id=? AND testname=? AND item_path != '' AND status='FAIL'), - pass_count=(SELECT count(id) FROM tests WHERE run_id=? AND testname=? AND item_path != '' AND (status='PASS' OR status='WARN' OR status='WAIVED')) - WHERE run_id=? AND testname=? AND item_path='';" - run-id test-name run-id test-name run-id test-name) - (if (equal? status "RUNNING") ;; running takes priority over all other states, force the test state to RUNNING - (sqlite3:execute db "UPDATE tests SET state=? WHERE run_id=? AND testname=? AND item_path='';" "RUNNING" run-id test-name) - (sqlite3:execute - db - "UPDATE tests - SET state=CASE WHEN (SELECT count(id) FROM tests WHERE run_id=? AND testname=? AND item_path != '' AND state in ('RUNNING','NOT_STARTED')) > 0 THEN - 'RUNNING' - ELSE 'COMPLETED' END, - status=CASE WHEN fail_count > 0 THEN 'FAIL' WHEN pass_count > 0 AND fail_count=0 THEN 'PASS' ELSE 'UNKNOWN' END - WHERE run_id=? AND testname=? AND item_path='';" - run-id test-name run-id test-name)))) + (rdb:roll-up-pass-fail-counts db run-id test-name item-path status) + (if (or (and (string? comment) (string-match (regexp "\\S+") comment)) waived) - (sqlite3:execute db "UPDATE tests SET comment=? WHERE run_id=? AND testname=? AND item_path=?;" - (if waived waived comment) run-id test-name item-path)) + (rdb:test-set-comment db run-id test-name item-path (if waived waived comment))) )) (define (test-set-log! db run-id test-name itemdat logf) (let ((item-path (item-list->path itemdat))) - (sqlite3:execute db "UPDATE tests SET final_logf=? WHERE run_id=? AND testname=? AND item_path=?;" - logf run-id test-name item-path))) + (rdb:test-set-log! db run-id test-name item-path logf))) (define (test-set-toplog! db run-id test-name logf) (sqlite3:execute db "UPDATE tests SET final_logf=? WHERE run_id=? AND testname=? AND item_path='';" logf run-id test-name)) @@ -369,28 +344,11 @@ ;;====================================================================== ;; test steps ;;====================================================================== -(define (teststep-set-status! db run-id test-name teststep-name state-in status-in itemdat comment logfile) - (debug:print 4 "run-id: " run-id " test-name: " test-name) - (let* ((state (check-valid-items "state" state-in)) - (status (check-valid-items "status" status-in)) - (item-path (item-list->path itemdat)) - (testdat (db:get-test-info db run-id test-name item-path))) - (debug:print 5 "testdat: " testdat) - (if (and testdat ;; if the section exists then force specification BUG, I don't like how this works. - (or (not state)(not status))) - (debug:print 0 "WARNING: Invalid " (if status "status" "state") - " value \"" (if status state-in status-in) "\", update your validvalues section in megatest.config")) - (if testdat - (let ((test-id (test:get-id testdat))) - ;; FIXME - this should not update the logfile unless it is specified. - (sqlite3:execute db - "INSERT OR REPLACE into test_steps (test_id,stepname,state,status,event_time,comment,logfile) VALUES(?,?,?,?,strftime('%s','now'),?,?);" - test-id teststep-name state-in status-in (if comment comment "") (if logfile logfile ""))) - (debug:print 0 "ERROR: Can't update " test-name " for run " run-id " -> no such test in db")))) +;; teststep-set-status! used to be here (define (test-get-kill-request db run-id test-name itemdat) (let* ((item-path (item-list->path itemdat)) (testdat (db:get-test-info db run-id test-name item-path))) (equal? (test:get-state testdat) "KILLREQ"))) @@ -410,21 +368,14 @@ runpath run-id testname item-path))) -(define (test-update-meta-info db run-id testname itemdat minutes cpuload diskfree tmpfree) - (let ((item-path (item-list->path itemdat))) - (if (not item-path)(begin (debug:print 0 "WARNING: ITEMPATH not set.") (set! item-path ""))) - ;; (let ((testinfo (db:get-test-info db run-id testname item-path))) - ;; (if (and (not (equal? (db:test-get-status testinfo) "COMPLETED")) - ;; (not (equal? (db:test-get-status testinfo) "KILLREQ")) - (sqlite3:execute - db - "UPDATE tests SET cpuload=?,diskfree=?,run_duration=?,state='RUNNING' WHERE run_id=? AND testname=? AND item_path=? AND state NOT IN ('COMPLETED','KILLREQ','KILLED');" - cpuload - diskfree - minutes - run-id - testname - item-path))) - +;;====================================================================== +;; A R C H I V I N G +;;====================================================================== + +(define (test:archive db test-id) + #f) + +(define (test:archive-tests db keynames target) + #f) ADDED tests/tests/neverrun/testconfig Index: tests/tests/neverrun/testconfig ================================================================== --- /dev/null +++ tests/tests/neverrun/testconfig @@ -0,0 +1,4 @@ +[setup] +runscript idontexist + +