Index: db.scm ================================================================== --- db.scm +++ db.scm @@ -1017,19 +1017,22 @@ (let loop ((start-time (current-time))) (thread-sleep! 0.5) ;; move save time around to minimize regular collisions? (db:write-cached-data) (loop start-time))) -(define (cdb:test-set-state-status test-id status state) +(define (cdb:test-set-status-state test-id status state #!key (msg #f)) (debug:print 4 "INFO: Adding status/state to queue: " status "/" state) (mutex-lock! *incoming-mutex*) - (set! *incoming-data* (cons (vector 'state-status - (current-seconds) - (list state - status - test-id)) ;; run-id test-name item-path minutes cpuload diskfree tmpfree) - *incoming-data*)) + (if msg + (set! *incoming-data* (cons (vector 'state-status-msg + (current-seconds) + (list state status msg test-id)) + *incoming-data*)) + (set! *incoming-data* (cons (vector 'state-status + (current-seconds) + (list state status test-id)) ;; run-id test-name item-path minutes cpuload diskfree tmpfree) + *incoming-data*))) (mutex-unlock! *incoming-mutex*) (if *cache-on* (debug:print 6 "INFO: *cache-on* is " *cache-on* ", skipping cache write") (db:write-cached-data))) @@ -1052,14 +1055,15 @@ ;; values to be applied ;; (define (db:write-cached-data) (open-run-close (lambda (db . params) - (let ((meta-stmt (sqlite3:prepare db "UPDATE tests SET cpuload=?,diskfree=?,run_duration=?,state='RUNNING' WHERE id=? AND state NOT IN ('COMPLETED','KILLREQ','KILLED');")) - (state-status-stmt (sqlite3:prepare db "UPDATE tests SET state=?,status=? WHERE id=?;")) - (step-stmt (sqlite3:prepare db "INSERT OR REPLACE into test_steps (test_id,stepname,state,status,event_time,comment,logfile) VALUES(?,?,?,?,?,?,?);")) ;; strftime('%s','now')#f) - (data #f)) + (let ((meta-stmt (sqlite3:prepare db "UPDATE tests SET cpuload=?,diskfree=?,run_duration=?,state='RUNNING' WHERE id=? AND state NOT IN ('COMPLETED','KILLREQ','KILLED');")) + (state-status-stmt (sqlite3:prepare db "UPDATE tests SET state=?,status=? WHERE id=?;")) + (state-status-msg-stmt (sqlite3:prepare db "UPDATE tests SET state=?,status=?,comment=? WHERE id=?;")) + (step-stmt (sqlite3:prepare db "INSERT OR REPLACE into test_steps (test_id,stepname,state,status,event_time,comment,logfile) VALUES(?,?,?,?,?,?,?);")) ;; strftime('%s','now')#f) + (data #f)) (mutex-lock! *incoming-mutex*) (set! data (sort *incoming-data* (lambda (a b)(< (vector-ref a 1)(vector-ref b 1))))) (set! *incoming-data* '()) (mutex-unlock! *incoming-mutex*) (if (> (length data) 0) @@ -1074,16 +1078,19 @@ (apply sqlite3:execute meta-stmt (vector-ref entry 2))) ((step-status) (apply sqlite3:execute step-stmt (vector-ref entry 2))) ((state-status) (apply sqlite3:execute state-status-stmt (vector-ref entry 2))) + ((state-status-msg) + (apply sqlite3:execute state-status-msg-stmt (vector-ref entry 2))) (else (debug:print 0 "ERROR: Queued entry not recognised " entry)))) data))) (sqlite3:finalize! meta-stmt) ;; sqlite is the bottleneck, clear the statements asap? (sqlite3:finalize! step-stmt) (sqlite3:finalize! state-status-stmt) + (sqlite3:finalize! state-status-msg-stmt) )) #f)) ;; (define (db:write-cached-data db) ;; (let ((meta-stmt (sqlite3:prepare db "UPDATE tests SET cpuload=?,diskfree=?,run_duration=?,state='RUNNING' WHERE id=? AND state NOT IN ('COMPLETED','KILLREQ','KILLED');")) @@ -1122,11 +1129,11 @@ "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) - (thread-sleep! 0.1) ;; give other processes a chance here + ;; (thread-sleep! 0.1) ;; give other processes a chance here, no, better to be done ASAP? (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 Index: launch.scm ================================================================== --- launch.scm +++ launch.scm @@ -40,16 +40,23 @@ ;; given an exit code and whether or not logpro was used calculate OK/BAD ;; return #t if we are ok, #f otherwise (define (steprun-good? logpro exitcode) (or (eq? exitcode 0) (and logpro (eq? exitcode 2)))) + +;; if handed a string, process it, else look for MT_CMDINFO +(define (launch:get-cmdinfo-assoc-list #!key (encoded-cmd #f)) + (let ((enccmd (if encoded-cmd encoded-cmd (getenv "MT_CMDINFO")))) + (if enccdm + (read (open-input-string (base64:base64-decode enccmd))) + '()))) (define (launch:execute encoded-cmd) (let* ((cmdinfo (read (open-input-string (base64:base64-decode encoded-cmd))))) (setenv "MT_CMDINFO" encoded-cmd) (if (list? cmdinfo) ;; ((testpath /tmp/mrwellan/jazzmind/src/example_run/tests/sqlitespeed) - ;; (test-name sqlitespeed) (runscript runscript.rb) (db-host localhost) (run-id 1)) + ;; (test-name sqlitespeed) (runscript runscript.rb) (db-host localhost) (run-id 1)) (let* ((testpath (assoc/default 'testpath cmdinfo)) (top-path (assoc/default 'toppath cmdinfo)) (work-area (assoc/default 'work-area cmdinfo)) (test-name (assoc/default 'test-name cmdinfo)) (runscript (assoc/default 'runscript cmdinfo)) @@ -107,11 +114,11 @@ (alist->env-vars env-ovrd) (open-run-close set-megatest-env-vars #f run-id) (set-item-env-vars itemdat) (save-environment-as-files "megatest") (open-run-close test-set-meta-info #f test-id run-id test-name itemdat 0) - (open-run-close tests:test-set-status! #f test-id "REMOTEHOSTSTART" "n/a" (args:get-arg "-m") #f) + (tests:test-set-status! test-id "REMOTEHOSTSTART" "n/a" (args:get-arg "-m") #f) (if (args:get-arg "-xterm") (set! fullrunscript "xterm") (if (and fullrunscript (not (file-execute-access? fullrunscript))) (system (conc "chmod ug+x " fullrunscript)))) ;; We are about to actually kick off the test @@ -125,11 +132,11 @@ (job-thread #f) (runit (lambda () ;; (let-values ;; (((pid exit-status exit-code) ;; (run-n-wait fullrunscript))) - (open-run-close tests:test-set-status! #f test-id "RUNNING" "n/a" #f #f) + (tests:test-set-status! test-id "RUNNING" "n/a" #f #f) ;; if there is a runscript do it first (if fullrunscript (let ((pid (process-run fullrunscript))) (let loop ((i 0)) (let-values @@ -198,12 +205,12 @@ (thread-sleep! 2) (processloop (+ i 1)))) )) (let ((exinfo (vector-ref exit-info 2)) (logfna (if logpro-used (conc stepname ".html") ""))) - ;; testing if procedures called in a remote call cause problems (ans: no or so I suspect) - (open-run-close db:teststep-set-status! #f test-id stepname "end" exinfo itemdat #f logfna)) + ;; testing if procedures called in a remote call cause problems (ans: no or so I suspect) + (open-run-close db:teststep-set-status! #f test-id stepname "end" exinfo itemdat #f logfna)) (if logpro-used (open-run-close db:test-set-log! #f test-id (conc stepname ".html"))) ;; set the test final status (let* ((this-step-status (cond ((and (eq? (vector-ref exit-info 2) 2) logpro-used) 'warn) @@ -223,23 +230,23 @@ " next-status: " next-status " rollup-status: " rollup-status) (case next-status ((warn) (set! rollup-status 2) ;; NB// test-set-status! does rdb calls under the hood - (open-run-close tests:test-set-status! #f test-id "RUNNING" "WARN" - (if (eq? this-step-status 'warn) "Logpro warning found" #f) - #f)) + (tests:test-set-status! test-id "RUNNING" "WARN" + (if (eq? this-step-status 'warn) "Logpro warning found" #f) + #f)) ((pass) - (open-run-close tests:test-set-status! #f test-id "RUNNING" "PASS" #f #f)) + (tests:test-set-status! test-id "RUNNING" "PASS" #f #f)) (else ;; 'fail (set! rollup-status 1) ;; force fail - (open-run-close tests:test-set-status! #f test-id "RUNNING" "FAIL" (conc "Failed at step " stepname) #f) + (tests:test-set-status! test-id "RUNNING" "FAIL" (conc "Failed at step " stepname) #f) )))) (if (and (steprun-good? logpro-used (vector-ref exit-info 2)) (not (null? tal))) (loop (car tal) (cdr tal) stepname))) - (debug:print 4 "WARNING: a prior step failed, stopping at " ezstep)))))))) + (debug:print 4 "WARNING: a prior step failed, stopping at " ezstep)))))))) (monitorjob (lambda () (let* ((start-seconds (current-seconds)) (calc-minutes (lambda () (inexact->exact (round @@ -271,12 +278,12 @@ (system (conc "kill -9 " p-id)))))) (car processes)) (system (conc "kill -9 " pid)))) (begin (debug:print 0 "WARNING: Request received to kill job but problem with process, attempting to kill manager process") - (open-run-close tests:test-set-status! #f test-id "KILLED" "FAIL" - (args:get-arg "-m") #f) + (tests:test-set-status! test-id "KILLED" "FAIL" + (args:get-arg "-m") #f) (sqlite3:finalize! tdb) (exit 1)))) (set! kill-tries (+ 1 kill-tries)) (mutex-unlock! m))) ;; (sqlite3:finalize! db) @@ -292,23 +299,23 @@ (let* ((item-path (item-list->path itemdat)) (testinfo (open-run-close db:get-test-info-by-id #f test-id))) ;; )) ;; run-id test-name item-path))) (if (not (equal? (db:test-get-state testinfo) "COMPLETED")) (begin (debug:print 2 "Test NOT logged as COMPLETED, (state=" (db:test-get-state testinfo) "), updating result, rollup-status is " rollup-status) - (open-run-close tests:test-set-status! #f test-id - (if kill-job? "KILLED" "COMPLETED") - (cond - ((not (vector-ref exit-info 1)) "FAIL") ;; job failed to run - ((eq? rollup-status 0) - ;; if the current status is AUTO the defer to the calculated value (i.e. leave this AUTO) - (if (equal? (db:test-get-status testinfo) "AUTO") "AUTO" "PASS")) - ((eq? rollup-status 1) "FAIL") - ((eq? rollup-status 2) - ;; if the current status is AUTO the defer to the calculated value but qualify (i.e. make this AUTO-WARN) - (if (equal? (db:test-get-status testinfo) "AUTO") "AUTO-WARN" "WARN")) - (else "FAIL")) - (args:get-arg "-m") #f))) + (tests:test-set-status! test-id + (if kill-job? "KILLED" "COMPLETED") + (cond + ((not (vector-ref exit-info 1)) "FAIL") ;; job failed to run + ((eq? rollup-status 0) + ;; if the current status is AUTO the defer to the calculated value (i.e. leave this AUTO) + (if (equal? (db:test-get-status testinfo) "AUTO") "AUTO" "PASS")) + ((eq? rollup-status 1) "FAIL") + ((eq? rollup-status 2) + ;; if the current status is AUTO the defer to the calculated value but qualify (i.e. make this AUTO-WARN) + (if (equal? (db:test-get-status testinfo) "AUTO") "AUTO-WARN" "WARN")) + (else "FAIL")) + (args:get-arg "-m") #f))) ;; for automated creation of the rollup html file this is a good place... (if (not (equal? item-path "")) (open-run-close tests:summarize-items #f run-id test-name #f)) ;; don't force - just update if no ) (mutex-unlock! m) @@ -399,11 +406,11 @@ (toptest-path (conc disk-path "/" testtop-base)) (test-path (conc disk-path "/" test-base)) ;; ensure this exists first as links to subtests must be created there (linktree (let ((rd (config-lookup *configdat* "setup" "linktree"))) - (if rd rd (conc *toppath* "/runs")))) + (if rd rd (conc *toppath* "/runs")))) (lnkbase (conc linktree "/" target "/" runname)) (lnkpath (conc lnkbase "/" testname)) (lnkpathf (conc lnkpath (if not-iterated "" "/") item-path))) @@ -491,16 +498,16 @@ ;; (launch-test db (cadr status) test-conf)) (define (launch-test db run-id runname test-conf keyvallst test-name test-path itemdat params) (change-directory *toppath*) (alist->env-vars ;; consolidate this code with the code in megatest.scm for "-execute" (list ;; (list "MT_TEST_RUN_DIR" work-area) - (list "MT_RUN_AREA_HOME" *toppath*) - (list "MT_TEST_NAME" test-name) - ;; (list "MT_ITEM_INFO" (conc itemdat)) - (list "MT_RUNNAME" runname) - ;; (list "MT_TARGET" mt_target) - )) + (list "MT_RUN_AREA_HOME" *toppath*) + (list "MT_TEST_NAME" test-name) + ;; (list "MT_ITEM_INFO" (conc itemdat)) + (list "MT_RUNNAME" runname) + ;; (list "MT_TARGET" mt_target) + )) (let* ((useshell (config-lookup *configdat* "jobtools" "useshell")) (launcher (config-lookup *configdat* "jobtools" "launcher")) (runscript (config-lookup test-conf "setup" "runscript")) (ezsteps (> (length (hash-table-ref/default test-conf "ezsteps" '())) 0)) ;; don't send all the steps, could be big (diskspace (config-lookup test-conf "requirements" "diskspace")) @@ -566,11 +573,11 @@ (list 'mt-bindir-path mt-bindir-path))))))) ;; (string-intersperse keyvallst " ")))) ;; clean out step records from previous run if they exist (debug:print 4 "INFO: FIXMEEEEE!!!! This can be removed some day, perhaps move all test records to the test db?") (open-run-close db:delete-test-step-records db test-id) (change-directory work-area) ;; so that log files from the launch process don't clutter the test dir - (open-run-close tests:test-set-status! db test-id "LAUNCHED" "n/a" #f #f) ;; (if launch-results launch-results "FAILED")) + (tests:test-set-status! test-id "LAUNCHED" "n/a" #f #f) ;; (if launch-results launch-results "FAILED")) (cond ((and launcher hosts) ;; must be using ssh hostname (set! fullcmd (append launcher (car hosts)(list remote-megatest test-sig "-execute" cmdparms) debug-param))) ;; (set! fullcmd (append launcher (car hosts)(list remote-megatest test-sig "-execute" cmdparms)))) (launcher Index: megatest.scm ================================================================== --- megatest.scm +++ megatest.scm @@ -716,14 +716,14 @@ (not status))) (begin (debug:print 0 "ERROR: You must specify :state and :status with every call to -test-status\n" help) ;; (sqlite3:finalize! db) (exit 6))) - (let ((msg (args:get-arg "-m"))) - ;; Convert to rpc - ;; (rdb:open-run-close 'tests:test-set-status! #f test-id state newstatus msg otherdata)))) - (tests:test-set-status! db test-id state newstatus msg otherdata)))) + (let* ((msg (args:get-arg "-m")) + (numoth (length (hash-table-keys otherdata)))) + ;; Convert to rpc inside the tests:test-set-status! call, not here + (tests:test-set-status! test-id state newstatus msg otherdata)))) (if db (sqlite3:finalize! db)) (set! *didsomething* #t)))) ;;====================================================================== ;; Various helper commands can go below here Index: runs.scm ================================================================== --- runs.scm +++ runs.scm @@ -655,11 +655,11 @@ (if (> (- (current-seconds)(+ (db:test-get-event_time testdat) (db:test-get-run_duration testdat))) 600) ;; i.e. no update for more than 600 seconds (begin (debug:print 0 "WARNING: Test " test-name " appears to be dead. Forcing it to state INCOMPLETE and status STUCK/DEAD") - (open-run-close tests:test-set-status! db test-id "INCOMPLETE" "STUCK/DEAD" "Test is stuck or dead" #f)) + (tests:test-set-status! test-id "INCOMPLETE" "STUCK/DEAD" "Test is stuck or dead" #f)) (debug:print 2 "NOTE: " test-name " is already running"))) (else (debug:print 0 "ERROR: Failed to launch test " new-test-name ". Unrecognised state " (test:get-state testdat))))))) ;;====================================================================== ;; END OF NEW STUFF Index: server.scm ================================================================== --- server.scm +++ server.scm @@ -70,14 +70,14 @@ (debug:print 4 "INFO: rdb:open-run-close " procname " " remargs) (set! *last-db-access* (current-seconds)) (apply open-run-close (eval procname) remargs))) (rpc:publish-procedure! - 'cdb:test-set-state-status + 'cdb:test-set-status-state (lambda (test-id status state) - (debug:print 4 "INFO: cdb:test-set-state-status " procname " " remargs) - (apply cdb:test-set-state-status remargs))) + (debug:print 4 "INFO: cdb:test-set-status-state " procname " " remargs) + (apply cdb:test-set-status-state remargs))) ;;====================================================================== ;; end of publish-procedure section ;;====================================================================== Index: tests.scm ================================================================== --- tests.scm +++ tests.scm @@ -111,21 +111,22 @@ (if (null? tal) (map cdr (hash-table->alist tests-hash)) ;; return a list of the most recent tests (loop (car tal)(cdr tal)))))))))) ;; Do not rpc this one, do the underlying calls!!! -(define (tests:test-set-status! db test-id state status comment dat) - (let* ((real-status status) +(define (tests:test-set-status! test-id state status comment dat) + (let* ((db #f) + (real-status status) (otherdat (if dat dat (make-hash-table))) (testdat (open-run-close db:get-test-info-by-id db test-id)) (run-id (db:test-get-run_id testdat)) (test-name (db:test-get-testname testdat)) (item-path (db:test-get-item-path testdat)) ;; before proceeding we must find out if the previous test (where all keys matched except runname) ;; was WAIVED if this test is FAIL (waived (if (equal? status "FAIL") - (let ((prev-test (test:get-previous-test-run-record db run-id test-name item-path))) + (let ((prev-test (open-run-close test:get-previous-test-run-record db run-id test-name item-path))) (if prev-test ;; true if we found a previous test in this run series (let ((prev-status (db:test-get-status prev-test)) (prev-state (db:test-get-state prev-test)) (prev-comment (db:test-get-comment prev-test))) (debug:print 4 "prev-status " prev-status ", prev-state " prev-state ", prev-comment " prev-comment) @@ -139,11 +140,11 @@ (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) ;; (rdb:open-run-close 'cdb:test-set-state-status #f test-id real-status state)) ;; this one works - (cdb:test-set-state-status test-id real-status state)) + (cdb:test-set-status-state test-id real-status state)) ;; 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")) (open-run-close db:test-data-rollup db test-id status)) @@ -202,10 +203,11 @@ ;; 1. logf is "log/final.log ;; 2. logf is same as outputfilename (let ((outputfilename (conc "megatest-rollup-" test-name ".html")) (orig-dir (current-directory)) (logf #f)) + ;; This query finds the path and changes the directory to it for the test (sqlite3:for-each-row (lambda (path final_logf) (set! logf final_logf) (if (directory? path) (begin @@ -438,30 +440,5 @@ #f) (define (test:archive-tests db keynames target) #f) -;;====================================================================== -;; R P C -;;====================================================================== - -(define (rtests:register-test db run-id test-name item-path) - (if *runremote* - (let ((host (vector-ref *runremote* 0)) - (port (vector-ref *runremote* 1))) - ((rpc:procedure 'rtests:register-test host port) run-id test-name item-path)) - (tests:register-test db run-id test-name item-path))) - -(define (rtests:test-set-status! db test-id state status comment dat) - (if *runremote* - (let ((host (vector-ref *runremote* 0)) - (port (vector-ref *runremote* 1))) - ((rpc:procedure 'rtests:test-set-status! host port) test-id state status comment dat)) - (tests:test-set-status! db test-id state status comment dat))) - -(define (rtests:test-set-toplog! db run-id test-name logf) - (if *runremote* - (let ((host (vector-ref *runremote* 0)) - (port (vector-ref *runremote* 1))) - ((rpc:procedure 'rtests:test-set-toplog! host port) run-id test-name logf)) - (tests:test-set-toplog! db run-id test-name logf))) -