Megatest

dashboard-new-runs-view.scm at [5d8e30ec14]
Login

File attic_modular/dashboard-new-runs-view.scm artifact 24de2d2df6 part of check-in 5d8e30ec14


;;======================================================================
;; Extracting the data to display for runs
;;
;; This needs to be re-entrant such that it does one column per call
;; on the zeroeth call update runs data
;; on each subsequent call update one run (configurable - could do two, three ... or update until tdelta exceeded
;; on last run reset to zeroeth
;;
;;   1. select with run filters; area, target, runname, runstate, runstatus, starttime, duration
;;       - put this information into two data structures:
;;         a. hash of area/target/runname => runstruct #< ordernun, id, area, target, runname, state,
;;                                                        status, starttime, duration, non-deleted testcount>
;;            ordernum reflects order as received from sql query
;;         b. sparsevec of id => runstruct
;;   2. for each run in runshash ordered by ordernum do:
;;         retrieve data since last update for that run
;;         if there is a deleted test - retrieve full data
;;         if there are non-deleted tests register this run in the columns sparsevec
;;         if this is the zeroeth column regenerate the rows sparsevec
;;         if this column is in the visible zone update visible cells
;;
;; Other factors:
;;   1. left index handling:
;;       - add test/itempaths to left index as discovered, re-order and
;;         update row -> test/itempath mapping on each read run
;;======================================================================

;; runs is <vec header runs>
;;   get ALL runs info
;;   update rdat-targ-run-id
;;   update rdat-runs
;;
(define (dashboard:update-runs-data rdat)
  (let* ((tb               (dboard:rdat-runs-tree rdat))
	 (targ-sql-filt    (dboard:rdat-targ-sql-filt    rdat))
	 (runname-sql-filt (dboard:rdat-runname-sql-filt rdat))
	 (state-sql-filt   (dboard:rdat-run-state-sql-filt   rdat))
	 (status-sql-filt  (dboard:rdat-run-status-sql-filt  rdat))
	 ;; Use (db:get-value-by-header (db:get-header runinfo)(db:get-rows runinfo))
	 (data             (rmt:simple-get-runs runname-sql-filt #f #f targ-sql-filt #f))
	 (numruns          (length data)))
    ;; store in the runsbynum vector
    (dboard:rdat-runsbynum-set! rdat (list->vector data))
    ;; update runs       id              => runrec
    ;; update targ-runid target/runname  => run-id
    (for-each
     (lambda (runrec)
       (let* ((run-id (simple-run-id runrec))
	      (full-targ-runname (conc (simple-run-target runrec) "/"
				       (simple-run-runname runrec))))
	 ;; (debug:print 0 *default-log-port* "Update run  " run-id)
	 (sparse-vector-set! (dboard:rdat-runs rdat) run-id runrec)
	 (hash-table-set! (dboard:rdat-targ-runid rdat) full-targ-runname run-id)
	 (tree:add-node tb "Runs" (string-split full-targ-runname "/"))
	 ))
     data)
    numruns))

;;======================================================================
;; The "new" runs browser, this one sets up the view and registers the
;; updater
;;
(define (dashboard:runs-browse commondat tabdat #!key (tab-num 5))
  (let* ((rdat     (make-dboard:rdat))
	 (runsmtx  (dboard:runs-new-matrix commondat rdat))
	 (itemsmtx (dboard:runs-new-matrix commondat rdat)))
    (dboard:rdat-runs-mtx-set! rdat runsmtx)
    (dboard:rdat-items-mtx-set! rdat itemsmtx)
    (dboard:commondat-add-updater
     commondat
     (lambda ()
       (dashboard:new-runs-updater commondat tabdat rdat))
     tab-num: tab-num)
    (iup:split
     #:orientation "VERTICAL"
     #:value 100
     #:shrink "YES"
     (iup:vbox
      (dboard:runs-tree-new-view-browser commondat rdat))
     (iup:split
      #:orientation "VERTICAL"
      #:value 100
      (iup:vbox runsmtx)
      (iup:vbox
       (iup:split
	#:orientation "VERTICAL"
	#:value 500
	itemsmtx
	(dboard:test-info-matrix commondat rdat)
	))))))

(define (dashboard:new-runs-updater commondat tabdat rdat)
  (let* ((runnum           (dboard:rdat-runnum          rdat))
	 (start-time       (current-milliseconds))
	 (tot-runs         #f))
    (if (eq? runnum 0)(dashboard:update-runs-data rdat))
    (set! tot-runs (vector-length (dboard:rdat-runsbynum rdat)))
    (let loop ((rn   runnum))
      (if (and (< (- (current-milliseconds) start-time) 250)
	       (< rn tot-runs))
	  (let* ((newrn (if (>= runnum (vector-length (dboard:rdat-runsbynum rdat)))
			    0 ;; start over
			    (+ rn 1)))) ;; (+ runnum 1)))
	    (dashboard:update-run-data rn rdat)
	    (dboard:rdat-runnum-set! rdat newrn)
	    (if (> newrn 0)
		(loop newrn)))))
    (if (>=  (dboard:rdat-runnum rdat) tot-runs)
	(dboard:rdat-runnum-set! rdat 0))
    ;; (dboard:rdat-runnum-set! rdat rn))) ;; not needed as it is set above
    ;; (dboard:rdat-last-update-set! rdat (- (current-seconds) 10))
    (dashboard:update-new-runs-view-runs-matrix commondat rdat)
    '()))

;; NOTE: runnum is NOT the run-id, it is a pointer into the runsbynum vector
;;
(define (dashboard:update-run-data runnum rdat)
  (let* ((curr-time            (current-seconds))
	 (runrec               (vector-ref (dboard:rdat-runsbynum rdat) runnum))
	 (run-id               (simple-run-id runrec))
	 (last-update          (sparse-vector-ref (dboard:rdat-last-updates rdat) run-id))
	 ;; filters
	 (testname-sql-filt    (dboard:rdat-testname-sql-filt    rdat))
	 ;; (itempath-sql-filt    (dboard:rdat-itempath-sql-filt    rdat))
	 (test-state-sql-filt  (dboard:rdat-test-state-sql-filt  rdat))  ;; not used yet
	 (test-status-sql-filt (dboard:rdat-test-status-sql-filt rdat))  ;; not used yet
	 (tests                (rmt:get-tests-for-run-state-status run-id
						      testname-sql-filt
						      last-update                ;; last-update
						      )))
    ;; (debug:print 0 *default-log-port* "tests: " tests)
    (sparse-vector-set! (dboard:rdat-last-updates rdat) run-id (- curr-time 1))
    (sparse-vector-set! (dboard:rdat-run-tests rdat) run-id
			(delete-duplicates
			 (append tests (sparse-vector-ref (dboard:rdat-run-tests rdat) run-id))
			 (lambda (a b)
			   (eq? (vector-ref a 0)(vector-ref b 0))))) ;; de-duplicate based on test id
    #;(debug:print 0 *default-log-port* "Got " (length tests) " tests for run-id "
		 run-id " testname-sql-filt " testname-sql-filt " and last-update " last-update
		 " first test info: " tests) ;; (if (not (null? tests))(car tests) '()))
    (length tests)))

;; NB// start at 1.
;;
(define (dashboard:get-row-num mtrx rownames tname)
  (or (hash-table-ref/default rownames tname #f)
      (let* ((numentries (hash-table-size rownames))
	     (nextnum    (+ numentries 1)))
	(hash-table-set! rownames tname nextnum)
	(iup:attribute-set! mtrx (conc nextnum ":0") tname)
	nextnum)))

(define (dashboard:update-new-runs-view-runs-matrix commondat rdat)
  (let* ((run-tests-data (dboard:rdat-run-tests rdat)) ;; from dbmod.scm (define-record simple-run target id runname state status owner event_time)
	 (run-tests-mtx  (dboard:rdat-runs-mtx  rdat))
	 (runs-by-num    (dboard:rdat-runsbynum rdat)) ;; this is the sequence num
	 (num-runs       (vector-length runs-by-num))
	 )
    (debug:print 0 *default-log-port* "num-runs: " num-runs)
    (let loop ((col-num 1))
      (let* ((runrec    (vector-ref runs-by-num (- col-num 1)))
	     (run-id    (simple-run-id runrec))
	     (target    (simple-run-target runrec))
	     (runname   (simple-run-runname runrec))
	     (vert-targ (string-translate (conc target "/" runname) "/" "\n"))
	     (run-tests (sparse-vector-ref run-tests-data run-id))
	     (changed   #f))  ;; manage redraws on a column by column basis
	(debug:print 0 *default-log-port* "run-tests: " run-tests)
	(if (null? run-tests) ;; empty run
	    (if (< col-num num-runs) ;; NOT CORRECT
		(loop (+ col-num)))
	    (begin
	      (set! changed (dcommon:modifiy-if-different ;; set the col header
			     run-tests-mtx
			     (conc "0:" col-num)
			     vert-targ
			     changed))
	      (let testloop ((inum    0)
			     (tail    run-tests))
		(let* ((test-dat   (car tail))
		       (tname      (db:test-get-testname test-dat))
		       (state      (db:test-get-state    test-dat))
		       (status     (db:test-get-status   test-dat))
		       (item-path  (db:test-get-item-path test-dat))
		       (color      (gutils:get-color-for-state-status state status))
		       (is-deleted (equal? state "DELETED"))
		       (row-num    (if is-deleted
				       #f
				       (dashboard:get-row-num run-tests-mtx
							      (dboard:rdat-rownames rdat) tname)))
		       (cell-name (conc row-num ":" col-num)))
		  (if (or (not is-deleted)
			  (equal? item-path ""))
		      (begin
 			(set! changed (dcommon:modifiy-if-different 
 				       run-tests-mtx
 				       (conc "BGCOLOR" row-num ":" col-num)
 				       (car color)
 				       changed))
			(set! changed (dcommon:modifiy-if-different 
 				       run-tests-mtx
 				       cell-name
 				       (cadr color)
 				       changed))))
		  (if (not (null? (cdr tail)))
		      (testloop (+ inum 1)(cdr tail))
		      (begin
			(iup:attribute-set! run-tests-mtx (conc "C" col-num) "REDRAW")
			(if (< col-num num-runs)
			    (loop (+ col-num 1)))))))))))))

(define (dboard:runs-new-matrix commondat rdat)
  (iup:matrix
   #:alignment1 "ALEFT"
   #:expand "YES" ;; "HORIZONTAL"
   #:scrollbar "YES"
   #:numcol 100
   #:numlin 200
   #:numcol-visible 3 ;; (min 8)
   #:numlin-visible 10
   #:widthdef 20
   #:click-cb
   (lambda (obj row col status)
     (let* ((cell (conc row ":" col)))
       #f))
   ))

;; run info, test info
(define (dboard:test-info-matrix commondat rdat)
  (let* ((run-fields
	  '(("Run Info"  . 1)
	    ("Fields"    . 2)
	    ("Target"    . 3)
	    ("Runname"   . 4)
	    ("Run-id"    . 5)
	    ("Run-date"  . 6)))
	 (test-fields
	  '(("Test Info" . 1)
	    ("Testname"  . 2)
	    ("Item path" . 3)
	    ("State"     . 4)
	    ("Status"    . 5)
	    ("Comment"   . 6)
	    ("Test-id"   . 7)
	    ("Test-date" . 8)))
	 (test-meta-fields
	  '(("Test Meta Data" . 1)
	    ("Author"    . 2)
	    ("Owner"     . 3)
	    ("Reviewed"  . 4)
	    ("Tags"      . 5)
	    ("Description" . 6)))
	 (remhost-run-info-fields
	  '(("Host/run info" . 1)
	    ("Hostname"  . 2)
	    ("Disk free" . 3)
	    ("CPU Load"  . 4)
	    ("Run duration" . 5)
	    ("Logfile"   . 6)
	    ("Process ID" . 7)
	    ("Machine info" . 8)))
	 (mk-matrix (lambda (cfgdat)
		      (let ((mtx (iup:matrix
				  #:alignment1 "ALEFT"
				  ;; #:expand "YES" ;; "HORIZONTAL"
				  #:scrollbar "YES"
				  #:numcol 1
				  #:numlin (length cfgdat)
				  #:numcol-visible 1 ;; (min 8)
				  #:numlin-visible (length cfgdat)
				  #:widthdef 50
				  #:width0 50
				  #:click-cb
				  (lambda (obj row col status)
				    (let* ((cell (conc row ":" col)))
				      #f)))))
			(for-each (lambda (finfo)
				    (match finfo
				      ((fieldname . rownum)
				       (iup:attribute-set! mtx (conc rownum":0") fieldname))
				      (else (debug:print 0 *default-log-port* "ERROR: bad finfo "finfo))))
				  cfgdat)
			mtx)))
	 (runmtx  (mk-matrix run-fields))
	 (testmtx (mk-matrix test-fields))
	 (metamtx (mk-matrix test-meta-fields))
	 (remhostmtx (mk-matrix remhost-run-info-fields)))
    ;; (dboard:rdat-runs-mtx-set! rdat runmtx)
    ;; (dboard:rdat-items-mtx-set! rdat testmtx)
    ;; (
    (iup:vbox
     #:expandchildren #t
     #:expand #f
     runmtx testmtx
     metamtx remhostmtx
     )))

;; browse runs as a tree. Used in both "Runs" tab and
;; in the runs control panel.
;;
;;  THIS IS THE NEW ONE
;;
(define (dboard:runs-tree-new-view-browser commondat rdat)
  (let* ((txtbox (iup:textbox
		  #:action (lambda (val a b)
			     (debug:catch-and-dump
			      (lambda ()
				;; for the Runs view we put the list
				;; of keyvals into tabdat target for
				;; the Run Controls we put then update
				;; the run-command
				(if b (dboard:rdat-targ-sql-filt-set! rdat
								 (string-split b "/")))
				#;(dashboard:update-run-command tabdat))
			      "command-testname-selector tb action"))
		  ;; #:value (dboard:test-patt->lines  ;; This seems like it was wrong, BUG in code where it was copied from?
	          ;;		   (dboard:tabdat-test-patts-use tabdat))
		  #:expand "HORIZONTAL"
		  ;; #:size "10x"
		  ))
	 (tb
          (iup:treebox
           #:value 0
           #:title "Runs"     ;;  was #:name -- iup 3.19 changed
			      ;;  this... "Changed: [DEPRECATED
			      ;;  REMOVED] removed the old attribute
			      ;;  NAMEid from IupTree to avoid
			      ;;  conflict with the common attribute
			      ;;  NAME. Use the TITLEid attribute."
           #:expand "YES"
           #:addexpanded "YES"
           #:size "120x"
           #:selection-cb
           (lambda (obj id state)
             (debug:catch-and-dump
              (lambda ()
                (let* ((run-path (tree:node->path obj id))
                       (run-id    (new-tree-path->run-id rdat (cdr run-path))))
                  ;; (dboard:tabdat-view-changed-set! tabdat #t) ;; ??
                  ;; done below when run-id is a number
                  (dboard:rdat-targ-sql-filt-set! rdat (cdr run-path)) ;; (print
								    ;; "run-path:
								    ;; "
								    ;; run-path)
		  (iup:attribute-set! txtbox "VALUE"
				      (string-intersperse (cdr run-path) "/"))
		  #;(dashboard:update-run-command tabdat)
                  #;(dboard:tabdat-layout-update-ok-set! tabdat #f)
                  (if (number? run-id)
                      (begin
                        ;; capture last two in tabdat.
                        (dboard:rdat-push-run-id rdat run-id)
			(dboard:rdat-view-changed-set! rdat #t))
                      (debug:print-error 5 *default-log-port* "tree-path->run-id returned non-number " run-id))))
              "treebox"))
           ;; (print "path: " (tree:node->path obj id) " run-id: " run-id)
           )))
    (dboard:rdat-runs-tree-set! rdat tb)
    (iup:detachbox
     (iup:vbox 
      txtbox
      tb
      ))))