Index: api.scm ================================================================== --- api.scm +++ api.scm @@ -15,18 +15,20 @@ ;; These are called by the server on recipt of /api calls (define (api:execute-requests db cmd params) (debug:print-info 1 "api:execute-requests cmd=" cmd " params=" params) + (db:process-cached-writes db) (case (string->symbol cmd) ;; KEYS ((get-key-val-pairs) (apply db:get-key-val-pairs db params)) ;; TESTS ;; json doesn't do vectors, convert to list ((get-test-info-by-id) (vector->list (apply db:get-test-info-by-id db params))) ((test-get-rundir-from-test-id) (apply db:test-get-rundir-from-test-id db params)) ((testmeta-get-record) (vector->list (apply db:testmeta-get-record db params))) + ((test-set-state-status-by-id) (apply db:test-set-state-status-by-id db params)) ;; RUNS ((get-run-info) (let ((res (apply db:get-run-info db params))) (list (vector-ref res 0) (vector->list (vector-ref res 1))))) (else Index: dashboard-tests.scm ================================================================== --- dashboard-tests.scm +++ dashboard-tests.scm @@ -206,21 +206,21 @@ (iup:frame #:title "Set fields" (iup:vbox (iup:hbox (iup:label "Comment:") (iup:textbox #:action (lambda (val a b) - (cdb:remote-run db:test-set-state-status-by-id #f test-id #f #f b) + (rmt:test-set-state-status-by-id test-id #f #f b) (set! newcomment b)) #:value (db:test-get-comment testdat) #:expand "HORIZONTAL")) (apply iup:hbox (iup:label "STATE:" #:size "30x") (let* ((btns (map (lambda (state) (let ((btn (iup:button state #:expand "HORIZONTAL" #:size "50x" #:font "Courier New, -10" #:action (lambda (x) - (cdb:remote-run db:test-set-state-status-by-id #f test-id state #f #f) + (rmt:test-set-state-status-by-id test-id state #f #f) (db:test-set-state! testdat state))))) btn)) (list "COMPLETED" "NOT_STARTED" "RUNNING" "REMOTEHOSTSTART" "KILLED" "KILLREQ")))) (vector-set! *state-status* 0 (lambda (state color) @@ -236,11 +236,11 @@ (iup:label "STATUS:" #:size "30x") (let* ((btns (map (lambda (status) (let ((btn (iup:button status #:expand "HORIZONTAL" #:size "50x" #:font "Courier New, -10" #:action (lambda (x) - (cdb:remote-run db:test-set-state-status-by-id #f test-id #f status #f) + (rmt:test-set-state-status-by-id test-id #f status #f) (db:test-set-status! testdat status))))) btn)) (list "PASS" "WARN" "FAIL" "CHECK" "n/a" "WAIVED" "SKIP")))) (vector-set! *state-status* 1 (lambda (status color) @@ -365,10 +365,11 @@ "runname") #f)) ;; These next two are intentional bad values to ensure errors if they should not ;; get filled in properly. (logfile "/this/dir/better/not/exist") (rundir logfile) + (testdat-path (conc rundir "/testdat.db")) ;; this gets recalculated until found (teststeps (if testdat (dashboard-tests:get-compressed-steps test-id work-area: rundir) '())) (testfullname (if testdat (db:test-get-fullname testdat) "Gathering data ...")) (testname (if testdat (db:test-get-testname testdat) "n/a")) (testmeta (if testdat (let ((tm (rmt:testmeta-get-record testname))) @@ -400,32 +401,53 @@ (conc "-e " (get-environment-variable "SHELL")) ""))) (system (conc "cd " rundir ";xterm -T \"" (string-translate testfullname "()" " ") "\" " shell "&"))) (message-window (conc "Directory " rundir " not found"))))) + (widgets (make-hash-table)) (refreshdat (lambda () - (let* ((curr-mod-time (file-modification-time db-path)) + (let* ((curr-mod-time (max (file-modification-time db-path) + (if (file-exists? testdat-path) + (file-modification-time testdat-path) + (begin + (set! testdat-path (conc rundir "/testdat.db")) + 0)))) (need-update (or (and (> curr-mod-time db-mod-time) - (> (current-seconds) (+ last-update 2))) ;; every two seconds if db touched + (> (current-milliseconds)(+ last-update 250))) ;; every half seconds if db touched + (> (current-milliseconds)(+ last-update 10000)) ;; force update even 10 seconds request-update)) (newtestdat (if need-update (handle-exceptions exn - (debug:print-info 2 "test db access issue: " ((condition-property-accessor 'exn 'message) exn)) + (debug:print-info 0 "test db access issue: " ((condition-property-accessor 'exn 'message) exn)) (rmt:get-test-info-by-id test-id ))))) + ;; (debug:print-info 0 "need-update= " need-update " curr-mod-time = " curr-mod-time) (cond ((and need-update newtestdat) (set! testdat newtestdat) (set! teststeps (dashboard-tests:get-compressed-steps test-id work-area: rundir)) (set! logfile (conc (db:test-get-rundir testdat) "/" (db:test-get-final_logf testdat))) (set! rundir (db:test-get-rundir testdat)) (set! testfullname (db:test-get-fullname testdat)) ;; (debug:print 0 "INFO: teststeps=" (intersperse teststeps "\n ")) + (set! db-mod-time curr-mod-time) + (set! last-update (current-milliseconds)) + (set! request-update #f) ;; met the need ... ) (need-update ;; if this was true and yet there is no data .... - (db:test-set-testname! testdat "DEAD OR DELETED TEST")))))) - (widgets (make-hash-table)) + (db:test-set-testname! testdat "DEAD OR DELETED TEST"))) + (if need-update + (begin + ;; update the gui elements here + (for-each + (lambda (key) + ;; (print "Updating " key) + ((hash-table-ref widgets key) testdat)) + (hash-table-keys widgets)) + (update-state-status-buttons testdat))) + ;; (iup:refresh self) + ))) (meta-widgets (make-hash-table)) (self #f) (store-label (lambda (name lbl cmd) (hash-table-set! widgets name (lambda (testdat) @@ -540,23 +562,45 @@ (iup:attribute-set! steps-matrix "ALIGNMENT1" "ALEFT") ;; (iup:attribute-set! steps-matrix "FIXTOTEXT" "C1") (iup:attribute-set! steps-matrix "RESIZEMATRIX" "YES") (let ((proc (lambda (testdat) - (if (not (null? teststeps)) - (let loop ((hed (car teststeps)) - (tal (cdr teststeps)) - (rownum 1) - (colnum 1)) - (let ((val (vector-ref hed (- colnum 1))) - (mtrx-rc (conc rownum ":" colnum))) - (iup:attribute-set! steps-matrix mtrx-rc (if val (conc val) "")) - (if (< colnum 6) - (loop hed tal rownum (+ colnum 1)) - (if (not (null? tal)) - (loop (car tal)(cdr tal)(+ rownum 1) 1)))) - (iup:attribute-set! steps-matrix "REDRAW" "ALL")))))) + (let ((max-row 0)) + (if (not (null? teststeps)) + (let loop ((hed (car teststeps)) + (tal (cdr teststeps)) + (rownum 1) + (colnum 1)) + (if (> rownum max-row)(set! max-row rownum)) + (let ((val (vector-ref hed (- colnum 1))) + (mtrx-rc (conc rownum ":" colnum))) + (iup:attribute-set! steps-matrix mtrx-rc (if val (conc val) "")) + (if (< colnum 6) + (loop hed tal rownum (+ colnum 1)) + (if (not (null? tal)) + (loop (car tal)(cdr tal)(+ rownum 1) 1)))))) + (if (> max-row 0) + (begin + ;; we are going to speculatively clear rows until we find a row that is already cleared + (let loop ((rownum (+ max-row 1)) + (colnum 0) + (deleted #f)) + (debug:print-info 0 "cleaning " rownum ":" colnum) + (let* ((next-row (if (eq? colnum 6) (+ rownum 1) rownum)) + (next-col (if (eq? colnum 6) 1 (+ colnum 1))) + (mtrx-rc (conc rownum ":" colnum)) + (curr-val (iup:attribute steps-matrix mtrx-rc))) + ;; (debug:print-info 0 "cleaning " rownum ":" colnum " currval= " curr-val) + (if (and (string? curr-val) + (not (equal? curr-val ""))) + (begin + (iup:attribute-set! steps-matrix mtrx-rc "") + (loop next-row next-col #t)) + (if (eq? colnum 6) ;; not done, didn't get a full blank row + (if deleted (loop next-row next-col #f)) ;; exit on this not met + (loop next-row next-col deleted))))) + (iup:attribute-set! steps-matrix "REDRAW" "ALL"))))))) (hash-table-set! widgets "StepsMatrix" proc) (proc testdat)) steps-matrix) ;; populate the Test Data panel (iup:frame @@ -602,16 +646,8 @@ (iup:callback-set! *tim* "ACTION_CB" (lambda (x) ;; Now start keeping the gui updated from the db (refreshdat) ;; update from the db here ;(thread-suspend! other-thread) - ;; update the gui elements here - (for-each - (lambda (key) - ;; (print "Updating " key) - ((hash-table-ref widgets key) testdat)) - (hash-table-keys widgets)) - (update-state-status-buttons testdat) - ; (iup:refresh self) (if *exit-started* (set! *exit-started* 'ok)))))))))) Index: dashboard.scm ================================================================== --- dashboard.scm +++ dashboard.scm @@ -1338,12 +1338,12 @@ ;;====================================================================== ;; The heavy lifting starts here ;;====================================================================== -;; ease debugging by loading ~/.megatestrc -(let ((debugcontrolf (conc (get-environment-variable "HOME") "/.megatestrc"))) +;; ease debugging by loading ~/.dashboardrc +(let ((debugcontrolf (conc (get-environment-variable "HOME") "/.dashboardrc"))) (if (file-exists? debugcontrolf) (load debugcontrolf))) (cond ((args:get-arg "-run") Index: db.scm ================================================================== --- db.scm +++ db.scm @@ -1117,11 +1117,13 @@ ((and newstate newstatus) (sqlite3:execute db "UPDATE tests SET state=?,status=? WHERE id=?;" newstate newstatus test-id)) (else (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))))) + (if newcomment (sqlite3:execute db "UPDATE tests SET comment=? WHERE id=?;" newcomment test-id)) + )) + #t) ;; retrun something to keep the remote calls happy (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)) Index: http-transport.scm ================================================================== --- http-transport.scm +++ http-transport.scm @@ -100,13 +100,15 @@ (dat ($ 'dat)) (res #f)) (cond ((equal? (uri-path (request-uri (current-request))) '(/ "api")) - (print "Got api request") (send-response body: (api:process-request db $) ;; the $ is the request vars proc - headers: '((content-type text/plain)))) + headers: '((content-type text/plain))) + (mutex-lock! *heartbeat-mutex*) + (set! *last-db-access* (current-seconds)) + (mutex-unlock! *heartbeat-mutex*)) ;; This is the /ctrl path where data is handed to the server and ;; responses ((equal? (uri-path (request-uri (current-request))) '(/ "ctrl")) (let* ((packet (db:string->obj dat)) Index: rmt.scm ================================================================== --- rmt.scm +++ rmt.scm @@ -89,10 +89,14 @@ (define (rmt:testmeta-get-record testname) (list->vector (rmt:send-receive 'testmeta-get-record (list testname)))) +;; WARNING: This currently bypasses the transaction wrapped writes system +(define (rmt:test-set-state-status-by-id test-id newstate newstatus newcomment) + (rmt:send-receive 'test-set-state-status-by-id (list test-id newstate newstatus newcomment))) + ;;====================================================================== ;; R U N S ;;====================================================================== (define (rmt:get-run-info run-id)