Index: Makefile ================================================================== --- Makefile +++ Makefile @@ -26,11 +26,10 @@ tests.o db.o launch.o runs.o dashboard-tests.o dashboard-guimonitor.o dashboard-main.o monitor.o dashboard.o megatest.o : db_records.scm tests.o runs.o dashboard.o dashboard-tests.o dashboard-main.o : run_records.scm db.o ezsteps.o keys.o launch.o megatest.o monitor.o runs-for-ref.o runs.o tests.o : key_records.scm tests.o tasks.o dashboard-tasks.o : task_records.scm runs.o : test_records.scm - $(OFILES) $(GOFILES) : common_records.scm %.o : %.scm csc $(CSCOPTS) -c $< 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)) @@ -131,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 @@ -407,10 +412,30 @@ (if currstatus (conc "status='" currstatus "' AND ") "") " run_id=? AND testname=? AND NOT (item_path='' AND testname in (SELECT DISTINCT testname FROM tests WHERE testname=? AND item_path != ''));"))) ;;(debug:print 0 "QRY: " qry) (sqlite3:execute db qry run-id newstate newstatus testname testname))) testnames)) + +(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")))) + (define (db:delete-tests-in-state db run-id state) (sqlite3:execute db "DELETE FROM tests WHERE state=? AND run_id=?;" state run-id)) (define (db:test-set-state-status-by-id db test-id newstate newstatus newcomment) @@ -973,5 +998,70 @@ 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:get-var db var) +;; (define (rdb:set-var db var val) +;; (define (rdb-get-keys db) +;; (define (rdb:get-value-by-header row header field) +;; (define (rruns:get-std-run-fields keys remfields) +;; (define (rdb:get-runs db runpatt count offset keypatts) +;; (define (rdb:get-num-runs db runpatt) +;; (define (rdb:get-run-info db run-id) +;; (define (rdb:set-comment-for-run db run-id comment) +;; (define (rdb:delete-run db run-id) +;; (define (rdb:update-run-event_time db run-id) +;; (define (rdb-get-tests-for-run db run-id testpatt itempatt states statuses) +;; (define (rdb:delete-test-step-records db run-id test-name itemdat) +;; (define (rdb:delete-test-records db test-id) + +(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) + (print "teststep-set-status!:" 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:delete-tests-in-state db run-id state) +;; (define (rdb:test-set-state-status-by-id db test-id newstate newstatus newcomment) +;; (define (rdb:get-count-tests-running db) +;; (define (rdb:get-count-tests-running-in-jobgroup db jobgroup) +;; (define (rdb:estimated-tests-remaining db run-id) +;; (define (rdb:get-test-info db run-id testname item-path) +;; (define (rdb:get-test-data-by-id db test-id) +;; (define (rdb:test-set-comment db run-id testname item-path comment) +;; (define (rdb:test-set-rundir! db run-id testname item-path rundir) +;; (define (rdb:test-get-paths-matching db keynames target) +;; (define (rdb:test-get-test-records-matching db keynames target) +;; (define (rdb:testmeta-get-record db testname) +;; (define (rdb:testmeta-add-record db testname) +;; (define (rdb:testmeta-update-field db testname field value) +;; (define (rdb:csv->test-data db test-id csvdata) +;; (define (rdb:read-test-data db test-id categorypatt) +;; (define (rdb:load-test-data db run-id test-name itemdat) +;; (define (rdb:test-data-rollup db test-id status) +;; (define (rdb:get-prev-tol-for-test db test-id category variable) +;; (define (rdb:step-get-time-as-string vec) +;; (define (rdb:get-steps-for-test db test-id) +;; (define (rdb:get-steps-table db test-id) +;; (define (rdb-get-prereqs-not-met db run-id waiton) +;; (define (rdb:get-prereqs-not-met db run-id waitons ref-item-path) +;; (define (rdb:extract-ods-file db outputfile keypatt-alist runspatt pathmod) 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) 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") @@ -90,10 +91,11 @@ -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 : start the server (reduces contention on megatest.db) 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 @@ -176,10 +178,12 @@ "-keepgoing" "-usequeue" "-rebuild-db" "-rollup" "-update-meta" + "-server" + "-v" ;; verbose 2, more than normal (normal is 1) "-q" ;; quiet 0, errors/warnings only ) args:arg-hash 0)) @@ -379,10 +383,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) + (debug:print 0 "ERROR: Failed to setup for megatest")))) + +;;;====================================================================== ;; Rollup into a run ;;====================================================================== (if (args:get-arg "-rollup") (general-run-call "-rollup" @@ -541,11 +555,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)))) @@ -604,11 +618,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) @@ -626,11 +640,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 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) +(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 @@ -24,18 +36,40 @@ (define (server:start db) (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))) + 'rpc:server)) + (host:port (conc (get-host-name) ":" (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) + ;; (debug:print 2 "rdb:set-tests-state-status newstate: " newstate " newstatus: " 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) + ;; (debug:print 2 "rdb:teststep-state-set-status! test-name: " test-name " teststep-name: " teststep-name) + (db:teststep-set-status! db run-id test-name teststep-name state-in status-in item-path comment logfile))) + + (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 +81,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 @@ -369,28 +368,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")))