Index: dashboard.scm ================================================================== --- dashboard.scm +++ dashboard.scm @@ -95,10 +95,13 @@ (itempath (db:test-get-item-path test)) (testfullname (runs:test-get-full-path test)) (currstatus (db:test-get-status test)) (currstate (db:test-get-state test)) (currcomment (db:test-get-comment test)) + (host (db:test-get-host test)) + (cpuload (db:test-get-cpuload test)) + (runtime (db:test-get-run)duration test) (logfile (conc (db:test-get-rundir test) "/" (db:test-get-final_logf test))) (viewlog (lambda (x) (if (file-exists? logfile) (system (conc "firefox " logfile "&")) (message-window (conc "File " logfile " not found"))))) @@ -130,11 +133,11 @@ ;; (print val " a: " a " b: " b " c: " c) (set! newstate a)) #:editbox "YES" #:expand "YES"))) (iuplistbox-fill-list lb - (list "COMPLETED" "NOT_STARTED" "RUNNING" "REMOTEHOSTSTART" "KILLED" "KILLREQ") + (list "COMPLETED" "NOT_STARTED" "RUNNING" "REMOTEHOSTSTART" "KILLED" "KILLREQ" "CHECK") currstate) lb)) (iup:vbox ;; the status (iup:label "STATUS:" #:size "30x") (let ((lb (iup:listbox #:action (lambda (val a b c) @@ -259,23 +262,29 @@ (testname (db:test-get-testname test)) (itempath (db:test-get-item-path test)) (testfullname (test:test-get-fullname test)) (teststatus (db:test-get-status test)) (teststate (db:test-get-state test)) + (teststart (db:test-get-event_time test)) + (runtime (db:test-get-run_duration test)) (buttontxt (if (equal? teststate "COMPLETED") teststatus teststate)) (button (vector-ref columndat rown)) (color (case (string->symbol teststate) ((COMPLETED) (if (equal? teststatus "PASS") "70 249 73" "223 33 49")) ;; greenish redish ((LAUNCHED) "101 123 142") + ((CHECK) "255 100 50") ((REMOTEHOSTSTART) "50 130 195") ((RUNNING) "9 131 232") ((KILLREQ) "39 82 206") ((KILLED) "234 101 17") (else "192 192 192"))) (curr-color (vector-ref buttondat 1)) ;; (iup:attribute button "BGCOLOR")) (curr-title (vector-ref buttondat 2))) ;; (iup:attribute button "TITLE"))) + ;; (if (and (equal? teststate "RUNNING") + ;; (> (- (current-seconds) (+ teststart runtime)) 100)) ;; if test has been dead for more than 100 seconds, call it dead + (if (not (equal? curr-color color)) (iup:attribute-set! button "BGCOLOR" color)) (if (not (equal? curr-title buttontxt)) (iup:attribute-set! button "TITLE" buttontxt)) (vector-set! buttondat 0 run-id) Index: runs.scm ================================================================== --- runs.scm +++ runs.scm @@ -58,19 +58,19 @@ (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))) -;; TODO: Converge this with db:get-test-info -(define (runs:get-test-info db run-id test-name item-path) - (let ((res #f)) ;; (vector #f #f #f #f #f #f))) - (sqlite3:for-each-row - (lambda (id run-id test-name state status) - (set! res (vector id run-id test-name state status item-path))) - db "SELECT id,run_id,testname,state,status FROM tests WHERE run_id=? AND testname=? AND item_path=?;" - run-id test-name item-path) - res)) +;; ;; TODO: Converge this with db:get-test-info +;; (define (runs:get-test-info db run-id test-name item-path) +;; (let ((res #f)) ;; (vector #f #f #f #f #f #f))) +;; (sqlite3:for-each-row +;; (lambda (id run-id test-name state status) +;; (set! res (vector id run-id test-name state status item-path))) +;; db "SELECT id,run_id,testname,state,status FROM tests WHERE run_id=? AND testname=? AND item_path=?;" +;; run-id test-name item-path) +;; res)) (define-inline (test:get-id vec) (vector-ref vec 0)) (define-inline (test:get-run_id vec) (vector-ref vec 1)) (define-inline (test:get-test-name vec)(vector-ref vec 2)) (define-inline (test:get-state vec) (vector-ref vec 3)) @@ -244,11 +244,11 @@ (if (and (not ts) (< ct 10)) (begin (register-test db run-id test-name item-path) (db:delete-test-step-records db run-id test-name) ;; clean out if this is a re-run - (loop2 (runs:get-test-info db run-id test-name item-path) + (loop2 (db:get-test-info db run-id test-name item-path) (+ ct 1))) (if ts (set! test-status ts) (begin (print "WARNING: Couldn't register test " test-name " with item path " item-path ", skipping") @@ -270,23 +270,30 @@ ((NOT_STARTED COMPLETED) ;; (cadr status is the row id for the run record) (if (and (equal? (test:get-state test-status) "COMPLETED") (equal? (test:get-status test-status) "PASS") (equal? (test:get-status test-status) "CHECK") (not (args:get-arg "-force"))) - (print "NOTE: Not starting test " new-test-name " as it is state \"COMPLETED\" and status \"PASS\", use -force to override") + (print "NOTE: Not starting test " new-test-name " as it is state \"COMPLETED\" and status \"" (test:get-status test-status) "\", use -force to override") (let* ((get-prereqs-cmd (lambda () (db-get-prereqs-not-met db run-id waiton))) ;; check before running .... (launch-cmd (lambda () (launch-test db run-id test-conf keyvallst test-name test-path itemdat))) (testrundat (list get-prereqs-cmd launch-cmd))) (if (or (args:get-arg "-force") (null? ((car testrundat)))) ;; are there any tests that must be run before this one... ((cadr testrundat)) ;; this is the line that launches the test to the remote host (hash-table-set! *waiting-queue* new-test-name testrundat))))) - ((LAUNCHED REMOTEHOSTSTART KILLED) + ((KILLED) (print "NOTE: " new-test-name " is already running or was explictly killed, use -force to launch it.")) - ((RUNNING) (print "NOTE: " test-name " is already running")) + ((LAUNCHED REMOTEHOSTSTART RUNNING) + (if (> (- (current-seconds)(+ (db:test-get-event_time test-status) + (db:test-get-run_duration test-status))) + 100) ;; i.e. no update for more than 100 seconds + (begin + (print "WARNING: Test " test-name " appears to be dead.") + (test-set-status! db run-id test-name "INCOMPLETE" "STUCK/DEAD" itemdat "Test is stuck or dead")) + (print "NOTE: " test-name " is already running"))) (else (print "ERROR: Failed to launch test " new-test-name ". Unrecognised state " (test:get-state test-status)))))) (if (not (null? tal)) (loop (car tal)(cdr tal))))))))) (define (run-waiting-tests db)