Overview
Comment: | Fixed cleaning of steps window after fresh run. Fixd stuck gui on test-panel |
---|---|
Downloads: | Tarball | ZIP archive | SQL archive |
Timelines: | family | ancestors | descendants | both | refactor-api |
Files: | files | file ages | folders |
SHA1: |
9a62bcf487c4fffb841800f5597cbaf2 |
User & Date: | matt on 2013-07-29 00:12:12 |
Other Links: | branch diff | manifest | tags |
Context
2013-07-29
| ||
00:20 | Missed removal of one print statement check-in: 188db4d0d0 user: matt tags: refactor-api | |
00:12 | Fixed cleaning of steps window after fresh run. Fixd stuck gui on test-panel check-in: 9a62bcf487 user: matt tags: refactor-api | |
2013-07-28
| ||
22:04 | Almost 80% on api conversion for test control panel check-in: 82e43c52e7 user: matt tags: refactor-api | |
Changes
Modified api.scm from [c0c3ff9c7b] to [bb24492b2f].
︙ | ︙ | |||
13 14 15 16 17 18 19 20 21 22 23 24 25 26 27 28 29 30 31 32 33 34 | (declare (uses rmt)) (declare (uses db)) ;; 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) (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))) ;; 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 (list "ERROR" 0)))) | > > | 13 14 15 16 17 18 19 20 21 22 23 24 25 26 27 28 29 30 31 32 33 34 35 36 | (declare (uses rmt)) (declare (uses db)) ;; 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 (list "ERROR" 0)))) |
︙ | ︙ |
Modified dashboard-tests.scm from [90fbf09413] to [07161126c3].
︙ | ︙ | |||
204 205 206 207 208 209 210 | (newstatus #f) (newstate #f)) (iup:frame #:title "Set fields" (iup:vbox (iup:hbox (iup:label "Comment:") (iup:textbox #:action (lambda (val a b) | | | | | 204 205 206 207 208 209 210 211 212 213 214 215 216 217 218 219 220 221 222 223 224 225 226 227 228 229 230 231 232 233 234 235 236 237 238 239 240 241 242 243 244 245 246 247 248 | (newstatus #f) (newstate #f)) (iup:frame #:title "Set fields" (iup:vbox (iup:hbox (iup:label "Comment:") (iup:textbox #:action (lambda (val a 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) (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) (for-each (lambda (btn) (let* ((name (iup:attribute btn "TITLE")) (newcolor (if (equal? name state) color "192 192 192"))) (if (not (colors-similar? newcolor (iup:attribute btn "BGCOLOR"))) (iup:attribute-set! btn "BGCOLOR" newcolor)))) btns))) btns)) (apply iup:hbox (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) (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) (for-each (lambda (btn) |
︙ | ︙ | |||
363 364 365 366 367 368 369 370 371 372 373 374 375 376 | (runname (if testdat (db:get-value-by-header (db:get-row rundat) (db:get-header rundat) "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) (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))) (if tm tm (make-db:testmeta))) (make-db:testmeta))) | > | 363 364 365 366 367 368 369 370 371 372 373 374 375 376 377 | (runname (if testdat (db:get-value-by-header (db:get-row rundat) (db:get-header rundat) "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))) (if tm tm (make-db:testmeta))) (make-db:testmeta))) |
︙ | ︙ | |||
398 399 400 401 402 403 404 405 | (if (directory-exists? rundir) (let ((shell (if (get-environment-variable "SHELL") (conc "-e " (get-environment-variable "SHELL")) ""))) (system (conc "cd " rundir ";xterm -T \"" (string-translate testfullname "()" " ") "\" " shell "&"))) (message-window (conc "Directory " rundir " not found"))))) (refreshdat (lambda () | > | > > > > > | > | > > > > | > > > > > > > | > > > | 399 400 401 402 403 404 405 406 407 408 409 410 411 412 413 414 415 416 417 418 419 420 421 422 423 424 425 426 427 428 429 430 431 432 433 434 435 436 437 438 439 440 441 442 443 444 445 446 447 448 449 450 451 452 453 454 455 | (if (directory-exists? rundir) (let ((shell (if (get-environment-variable "SHELL") (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 (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-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 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"))) (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) (let ((newval (cmd testdat)) (oldval (iup:attribute lbl "TITLE"))) |
︙ | ︙ | |||
538 539 540 541 542 543 544 | (iup:attribute-set! steps-matrix "0:5" "Duration") (iup:attribute-set! steps-matrix "0:6" "Log File") (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) | > | | | | | > | | | | | | | > > > > > > > > > > > > > > > > > > > > | | 560 561 562 563 564 565 566 567 568 569 570 571 572 573 574 575 576 577 578 579 580 581 582 583 584 585 586 587 588 589 590 591 592 593 594 595 596 597 598 599 600 601 602 603 604 605 606 607 608 | (iup:attribute-set! steps-matrix "0:5" "Duration") (iup:attribute-set! steps-matrix "0:6" "Log File") (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) (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 #:title "Test Data" (let ((test-data |
︙ | ︙ | |||
600 601 602 603 604 605 606 | tabs)))) (iup:show self) (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) | < < < < < < < < | 644 645 646 647 648 649 650 651 652 653 | tabs)))) (iup:show self) (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) (if *exit-started* (set! *exit-started* 'ok)))))))))) |
Modified dashboard.scm from [91e2b07405] to [509d618322].
︙ | ︙ | |||
1336 1337 1338 1339 1340 1341 1342 | (set! *last-db-update-time* modtime) (set! *last-update* run-update-time))))) ;;====================================================================== ;; The heavy lifting starts here ;;====================================================================== | | | | 1336 1337 1338 1339 1340 1341 1342 1343 1344 1345 1346 1347 1348 1349 1350 1351 | (set! *last-db-update-time* modtime) (set! *last-update* run-update-time))))) ;;====================================================================== ;; The heavy lifting starts here ;;====================================================================== ;; ease debugging by loading ~/.dashboardrc (let ((debugcontrolf (conc (get-environment-variable "HOME") "/.dashboardrc"))) (if (file-exists? debugcontrolf) (load debugcontrolf))) (cond ((args:get-arg "-run") (let ((runid (string->number (args:get-arg "-run")))) (if runid |
︙ | ︙ |
Modified db.scm from [62d66dee17] to [7172822a6c].
︙ | ︙ | |||
1115 1116 1117 1118 1119 1120 1121 | ((and newstate newstatus newcomment) (sqlite3:execute db "UPDATE tests SET state=?,status=?,comment=? WHERE id=?;" newstate newstatus newcomment test-id)) ((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)) | | > > | 1115 1116 1117 1118 1119 1120 1121 1122 1123 1124 1125 1126 1127 1128 1129 1130 1131 | ((and newstate newstatus newcomment) (sqlite3:execute db "UPDATE tests SET state=?,status=?,comment=? WHERE id=?;" newstate newstatus newcomment test-id)) ((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)) )) #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)) (define (db:get-count-tests-running db) (let ((res 0)) |
︙ | ︙ |
Modified http-transport.scm from [56910ff5a9] to [cfbe6dec89].
︙ | ︙ | |||
98 99 100 101 102 103 104 | (if (not db)(set! db (open-db))) (let* (($ (request-vars source: 'both)) (dat ($ 'dat)) (res #f)) (cond ((equal? (uri-path (request-uri (current-request))) '(/ "api")) | < | > > > | 98 99 100 101 102 103 104 105 106 107 108 109 110 111 112 113 114 115 116 | (if (not db)(set! db (open-db))) (let* (($ (request-vars source: 'both)) (dat ($ 'dat)) (res #f)) (cond ((equal? (uri-path (request-uri (current-request))) '(/ "api")) (send-response body: (api:process-request db $) ;; the $ is the request vars proc 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)) (qtype (cdb:packet-get-qtype packet))) (debug:print-info 12 "server=> received packet=" packet) |
︙ | ︙ |
Modified rmt.scm from [706a072116] to [851932b993].
︙ | ︙ | |||
87 88 89 90 91 92 93 94 95 96 97 98 99 100 | (debug:print 3 "TEST PATH: " test-path) (open-test-db test-path))) (define (rmt:testmeta-get-record testname) (list->vector (rmt:send-receive 'testmeta-get-record (list testname)))) ;;====================================================================== ;; R U N S ;;====================================================================== (define (rmt:get-run-info run-id) (let ((res (rmt:send-receive 'get-run-info (list run-id)))) (vector (car res) | > > > > | 87 88 89 90 91 92 93 94 95 96 97 98 99 100 101 102 103 104 | (debug:print 3 "TEST PATH: " test-path) (open-test-db test-path))) (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) (let ((res (rmt:send-receive 'get-run-info (list run-id)))) (vector (car res) |
︙ | ︙ |