Index: Makefile ================================================================== --- Makefile +++ Makefile @@ -9,11 +9,11 @@ db.scm keys.scm margs.scm megatest-version.scm \ process.scm runs.scm tasks.scm tests.scm genexample.scm \ http-transport.scm filedb.scm \ client.scm daemon.scm mt.scm \ ezsteps.scm lock-queue.scm sdb.scm \ - rmt.scm api.scm tdb.scm rpc-transport.scm \ + rmt.scm mrmt.scm api.scm tdb.scm rpc-transport.scm \ portlogger.scm archive.scm env.scm diff-report.scm cgisetup/models/pgdb.scm # Eggs to install (straightforward ones) EGGS=matchable readline apropos base64 regex-literals format regex-case test coops trace csv \ dot-locking posix-utils posix-extras directory-utils hostinfo tcp-server rpc csv-xml fmt \ @@ -44,11 +44,11 @@ all : $(PREFIX)/bin/.$(ARCHSTR) mtest dboard mtut mtest: $(OFILES) readline-fix.scm megatest.o csc $(CSCOPTS) $(OFILES) megatest.o -o mtest -dboard : $(OFILES) $(GOFILES) dashboard.scm +dboard : $(OFILES) $(GOFILES) dashboard.scm dashboard-areas.scm csc $(CSCOPTS) $(OFILES) dashboard.scm $(GOFILES) -o dboard ndboard : newdashboard.scm $(OFILES) $(GOFILES) csc $(CSCOPTS) $(OFILES) $(GOFILES) newdashboard.scm -o ndboard Index: common.scm ================================================================== --- common.scm +++ common.scm @@ -7,18 +7,17 @@ ;; This program is distributed WITHOUT ANY WARRANTY; without even the ;; implied warranty of MERCHANTABILITY or FITNESS FOR A PARTICULAR ;; PURPOSE. ;;====================================================================== -(use srfi-1 data-structures posix regex-case base64 format dot-locking csv-xml z3 sql-de-lite hostinfo md5 message-digest typed-records directory-utils stack - matchable) -(require-extension regex posix) - -(require-extension (srfi 18) extras tcp rpc) - -(import (prefix sqlite3 sqlite3:)) -(import (prefix base64 base64:)) +(use srfi-1 data-structures posix regex-case (prefix base64 base64:) + format dot-locking csv-xml z3 ;; sql-de-lite + hostinfo md5 message-digest typed-records directory-utils stack + matchable regex posix (srfi 18) extras ;; tcp + (prefix nanomsg nmsg:) + (prefix sqlite3 sqlite3:) + ) (declare (unit common)) (include "common_records.scm") @@ -100,11 +99,11 @@ ;; A hash table that can be accessed by #{scheme ...} calls in ;; config files. Allows communicating between confgs ;; (define *user-hash-data* (make-hash-table)) -(define *db-keys* #f) +;; (define *db-keys* #f) (define *configinfo* #f) ;; raw results from setup, includes toppath and table from megatest.config (define *runconfigdat* #f) ;; run configs data (define *configdat* #f) ;; megatest.config data (define *configstatus* #f) ;; status of data; 'fulldata : all processing done, #f : no data yet, 'partialdata : partial read done @@ -134,11 +133,11 @@ ;; task db (define *task-db* #f) ;; (vector db path-to-db) (define *db-access-allowed* #t) ;; flag to allow access (define *db-access-mutex* (make-mutex)) (define *db-transaction-mutex* (make-mutex)) -(define *db-cache-path* #f) +;; (define *db-cache-path* #f) (define *db-with-db-mutex* (make-mutex)) (define *db-api-call-time* (make-hash-table)) ;; hash of command => (list of times) ;; no sync db (define *no-sync-db* #f) @@ -644,27 +643,33 @@ (pathname-file *toppath*) #f))) ;; (pathname-file (current-directory))))) (define common:get-area-name common:get-testsuite-name) -(define (common:get-db-tmp-area . junk) - (if *db-cache-path* - *db-cache-path* - (if *toppath* ;; common:get-create-writeable-dir - (handle-exceptions - exn - (begin - (debug:print-error 0 *default-log-port* "Couldn't create path to " dbdir) - (exit 1)) - (let ((dbpath (common:get-create-writeable-dir - (list (conc "/tmp/" (current-user-name) - "/megatest_localdb/" - (common:get-testsuite-name) "/" - (string-translate *toppath* "/" ".")))))) ;; #t)))) - (set! *db-cache-path* dbpath) - dbpath)) - #f))) +;; WARNING: This code falls back to using the global Megatest +;; variable *toppath* +;; +(define (common:get-db-tmp-area #!key (dbstruct #f)) + (if (and dbstruct (dbr:dbstruct-tmpdb-path dbstruct)) ;; *db-cache-path* + (dbr:dbstruct-tmpdb-path dbstruct) ;; *db-cache-path* + (let ((toppath (or (and dbstruct (dbr:dbstruct-area-path dbstruct)) *toppath*)) + (tsname (or (and dbstruct (dbr:dbstruct-area-name dbstruct))(common:get-testsuite-name)))) + (if toppath ;; common:get-create-writeable-dir + (handle-exceptions + exn + (begin + (debug:print-error 0 *default-log-port* "Couldn't create path to " dbdir) + (exit 1)) + (let ((dbpath (common:get-create-writeable-dir + (list (conc "/tmp/" (current-user-name) + "/megatest_localdb/" + tsname "/" + (string-translate toppath "/" ".")))))) ;; #t)))) + ;; (set! *db-cache-path* dbpath) + (if dbstruct (dbr:dbstruct-tmpdb-path-set! dbstruct dbpath)) + dbpath)) + #f)))) (define (common:get-area-path-signature) (message-digest-string (md5-primitive) *toppath*)) (define (common:get-signature str) @@ -972,23 +977,27 @@ (begin (if message (debug:print-info 0 *default-log-port* message)) #f) (thunk) )) -(define (common:file-exists? path-string) +(define (common:file-exists? path-string #!key (quiet-mode #f)) ;; this avoids stack dumps in the case where ;;;; TODO: catch permission denied exceptions and emit appropriate warnings, eg: system error while trying to access file: "/nfs/pdx/disks/icf_env_disk001/bjbarcla/gwa/issues/mtdev/randy-slow/reproduce/q... - (common:false-on-exception (lambda () (file-exists? path-string)) - message: (conc "Unable to access path: " path-string) - )) + (common:false-on-exception + (lambda () (file-exists? path-string)) + message: (if quiet-mode + #f + (conc "Unable to access path: " path-string)))) -(define (common:directory-exists? path-string) +(define (common:directory-exists? path-string #!key (quiet-mode #f)) ;;;; TODO: catch permission denied exceptions and emit appropriate warnings, eg: system error while trying to access file: "/nfs/pdx/disks/icf_env_disk001/bjbarcla/gwa/issues/mtdev/randy-slow/reproduce/q... - (common:false-on-exception (lambda () (directory-exists? path-string)) - message: (conc "Unable to access path: " path-string) - )) + (common:false-on-exception + (lambda () (directory-exists? path-string)) + message: (if quiet-mode + #f + (conc "Unable to access path: " path-string)))) ;; does the directory exist and do we have write access? ;; ;; returns the directory or #f ;; @@ -1102,17 +1111,46 @@ (equal? homehost bestadrs)))) (set! *home-host* (cons homehost at-home)) (mutex-unlock! *homehost-mutex*) *home-host*)))) +;; get homehost info for a given area - but only if .homehost file already exists +(define (common:minimal-get-homehost toppath) + (let ((hh-file (conc toppath "/.homehost"))) + (if (common:file-exists? hh-file quiet-mode: #t) + (with-input-from-file hh-file read-line) + #f))) + +;; are we on the given host? +(define (common:on-host? hh) + (let* ((currhost (get-host-name)) + (bestadrs (server:get-best-guess-address currhost))) + (or (equal? hh currhost) + (equal? hh bestadrs)))) + ;; am I on the homehost? ;; (define (common:on-homehost?) (let ((hh (common:get-homehost))) (if hh (cdr hh) #f))) + +;; minimal loading of megatest.config +;; +(define (common:simple-setup toppath #!key (cfgf-ovrd #f)) + (let* ((mtconfigf (or cfgf-ovrd "megatest.config")) + (mtconfdat (find-and-read-config + mtconfigf + ;; environ-patt: "env-override" + given-toppath: toppath + ;; pathenvvar: "MT_RUN_AREA_HOME" + )) + (mtconf (if mtconfdat (car mtconfdat) #f))) + (if mtconf + (configf:section-var-set! mtconf "dyndat" "toppath" toppath)) + mtconfdat)) ;; do we honor the caches of the config files? ;; (define (common:use-cache?) (let ((res #t)) ;; priority by order of evaluation @@ -1643,11 +1681,11 @@ ;; (define (common:check-db-dir-space) (let* ((required (string->number (or (configf:lookup *configdat* "setup" "dbdir-space-required") "100000"))) - (dbdir (common:get-db-tmp-area)) ;; (db:get-dbdir)) + (dbdir (common:get-db-tmp-area #f)) ;; (db:get-dbdir)) (tdbspace (common:check-space-in-dir dbdir required)) (mdbspace (common:check-space-in-dir *toppath* required))) (sort (list tdbspace mdbspace) (lambda (a b) (< (cadr a)(cadr b)))))) @@ -2298,11 +2336,51 @@ ;; no match, try again (if (null? tal) fallback-launcher (loop (car tal)(cdr tal)))))))) fallback-launcher))) + +;;====================================================================== +;; NMSG AND NEW API +;;====================================================================== + +;; nm based server +;; +(define (nm:start-server dbconn #!key (given-host-name #f)) + (let* ((srvdat (start-raw-server given-host-name: given-host-name)) + (host-name (srvdat-host srvdat)) + (soc (srvdat-soc srvdat))) + + ;; start the queue processor (save for second round of development) + ;; + ;; (thread-start! (queue-processory dbconn) "Queue processor") + ;; msg is an alist + ;; 'r host:port <== where to return the data + ;; 'p params <== data to apply the command to + ;; 'e j|s|l <== encoding of the params. default is s (sexp), if not specified is assumed to be default + ;; 'c command <== look up the function to call using this key + ;; + (let loop ((msg-in (nn-recv soc))) + (if (not (equal? msg-in "quit")) + (let* ((dat (decode msg-in)) + (host-port (alist-ref 'r dat)) ;; this is for the reverse req rep where the server is a client of the original client + (params (alist-ref 'p dat)) + (command (let ((c (alist-ref 'c dat)))(if c (string->symbol c) #f))) + (all-good (and host-port params command (hash-table-exists? *commands* command)))) + (if all-good + (let ((cmddat (make-qitem + command: command + host-port: host-port + params: params))) + (queue-push cmddat) ;; put request into the queue + (nn-send soc "queued")) ;; reply with "queued" + (print "ERROR: BAD request " dat)) + (loop (nn-recv soc))))) + (nn-close soc))) + + ;;====================================================================== ;; D A S H B O A R D U S E R V I E W S ;;====================================================================== ;; first read ~/views.config if it exists, then read $MTRAH/views.config if it exists @@ -2354,5 +2432,70 @@ restore-thunk)) delta-env-alist)))) (let ((rv (thunk))) (for-each (lambda (x) (x)) restore-thunks) ;; restore env to original state rv))) +;;====================================================================== +;; H I E R A R C H I C A L H A S H T A B L E S +;;====================================================================== + +;; Every element including top element is a vector: +;; + +(define (hh:make-hh #!key (ht #f)(value #f)) + (vector (or ht (make-hash-table)) value)) + +;; used internally +(define-inline (hh:set-ht! hh ht) (vector-set! hh 0 ht)) +(define-inline (hh:get-ht hh) (vector-ref hh 0)) +(define-inline (hh:set-value! hh value) (vector-set! hh 1 value)) +(define-inline (hh:get-value hh value) (vector-ref hh 1)) + +;; given a hierarchial hash and some keys look up the value ... +;; +(define (hh:get-value hh . keys) + (if (null? keys) + (vector-ref hh 1) ;; we have reached the end of the line, return the value sought + (let ((sub-ht (hh:get-ht hh))) + (if sub-ht ;; yes, there is more hierarchy + (let ((sub-hh (hash-table-ref/default sub-ht (car keys) #f))) + (if sub-hh + (apply hh:get-value sub-hh (cdr keys)) + #f)) + #f)))) + +(define (hh:get-subhash hh . keys) + (if (null? keys) + (vector-ref hh 0) ;; we have reached the end of the line, return the value sought + (let ((sub-ht (hh:get-ht hh))) + (if sub-ht ;; yes, there is more hierarchy + (let ((sub-hh (hash-table-ref/default sub-ht (car keys) #f))) + (if sub-hh + (apply hh:get-subhash sub-hh (cdr keys)) + #f)) + #f)))) + +;; given a hierarchial hash, a value and some keys, add needed hierarcy and insert the value +;; +(define (hh:set! hh value . keys) + (if (null? keys) + (hh:set-value! hh value) ;; we have reached the end of the line, store the value + (let ((sub-ht (hh:get-ht hh))) + (if sub-ht ;; yes, there is more hierarchy + (let ((sub-hh (hash-table-ref/default sub-ht (car keys) #f))) + (if (not sub-hh) ;; we'll need to add the next level of hierarchy + (let ((new-sub-hh (hh:make-hh))) + (hash-table-set! sub-ht (car keys) new-sub-hh) + (apply hh:set! new-sub-hh value (cdr keys))) + (apply hh:set! sub-hh value (cdr keys)))) ;; call the sub-hierhash with remaining keys + (begin + (hh:set-ht! hh (make-hash-table)) + (apply hh:set! hh value keys)))))) + +;; given a hierarchial hash and some keys, return the keys for that hash level +;; +(define (hh:get-keys hh . keys) + (let ((ht (apply hh:get-subhash hh keys))) + (if ht + (hash-table-keys ht) + '()))) + ADDED dashboard-areas.scm Index: dashboard-areas.scm ================================================================== --- /dev/null +++ dashboard-areas.scm @@ -0,0 +1,783 @@ +;;====================================================================== +;; AREAS +;;====================================================================== + +(define (dashboard:areas-summary-updater commondat tabdat tb cell-lookup run-matrix) + ;; maps data from tabdat view-dat to the matrix + ;; if input databases have changed, refresh view-dat + ;; if filters have changed, refresh view-dat from input databases + ;; if pivots have changed, refresh view-dat from input databases + (let* ((runs-hash (dashboard:areas-get-runs-hash commondat tabdat)) + (runs-header '("contour_name" "release" "iteration" "testsuite_mode" "id" "runname" "state" "status" "owner" "event_time")) + (tree-path (dboard:tabdat-tree-path tabdat))) + (dboard:areas-update-tree tabdat runs-hash runs-header tb) + (print "Tree path: " tree-path) + (iup:attribute-set! run-matrix "CLEARVALUE" "ALL") ;; NOTE: Was CONTENTS + (iup:attribute-set! run-matrix "CLEARATTRIB" "CONTENTS") + (iup:attribute-set! run-matrix "RESIZEMATRIX" "YES") + + ;; (if (> max-col (string->number (iup:attribute run-matrix "NUMCOL"))) + (iup:attribute-set! run-matrix "NUMCOL" 10) ;; max-col )) + + ;; (let ((effective-max-row (if (< max-row max-visible) max-visible max-row))) + ;; (if (> effective-max-row (string->number (iup:attribute run-matrix "NUMLIN"))) + (iup:attribute-set! run-matrix "NUMLIN" 10) ;; effective-max-row ))) + (iup:attribute-set! run-matrix "1:1" (conc tree-path)) + (iup:attribute-set! run-matrix "REDRAW" "ALL"))) + + ;; (dashboard:areas-do-update-rundat commondat tabdat) ;; ) + ;; (dboard:areas-summary-control-panel-updater tabdat) + ;; (let* ((last-runs-update (dboard:tabdat-last-runs-update tabdat)) + ;; (runs-dat (db:get-runs-by-patt dbstruct (dboard:tabdat-keys tabdat) "%" #f #f #f #f last-runs-update)) + ;; (runs-header (vector-ref runs-dat 0)) ;; 0 is header, 1 is list of records + ;; (runs (vector-ref runs-dat 1)) + ;; (run-id (dboard:tabdat-curr-run-id tabdat)) + ;; (runs-hash (dashboard:areas-get-runs-hash tabdat)) + ;; ;; (runs-hash (let ((ht (make-hash-table))) + ;; ;; (for-each (lambda (run) + ;; ;; (hash-table-set! ht (db:get-value-by-header run runs-header "id") run)) + ;; ;; runs) + ;; ;; ht)) + ;; ) + ;; (if (dashboard:areas-database-changed? commondat tabdat context-key: 'runs-summary-tree) + ;; (dboard:areas-update-tree tabdat runs-hash runs-header tb)) + ;; (if run-id + ;; (let* ((matrix-content + ;; (case (dboard:tabdat-runs-summary-mode tabdat) + ;; ((one-run) (dashboard:areas-run-id->tests-mindat run-id tabdat runs-hash)) + ;; ((xor-two-runs) (dashboard:areas-runs-summary-xor-matrix-content tabdat runs-hash)) + ;; ((xor-two-runs-hide-clean) (dashboard:areas-runs-summary-xor-matrix-content tabdat runs-hash hide-clean: #t)) + ;; (else (dashboard:areas-run-id->tests-mindat run-id tabdat runs-hash))))) + ;; (when matrix-content + ;; (let* ((indices (common:sparse-list-generate-index matrix-content)) ;; proc: set-cell)) + ;; (row-indices (cadr indices)) + ;; (col-indices (car indices)) + ;; (max-row (if (null? row-indices) 1 (common:max (map cadr row-indices)))) + ;; (max-col (if (null? col-indices) 1 (common:max (map cadr col-indices)))) + ;; (max-visible (max (- (dboard:tabdat-num-tests tabdat) 15) 3)) ;; (dboard:tabdat-num-tests tabdat) is proportional to the size of the window + ;; (numrows 1) + ;; (numcols 1) + ;; (changed #f) + ;; ) + ;; + ;; (dboard:tabdat-filters-changed-set! tabdat #f) + ;; (let loop ((pass-num 0) + ;; (changed #f)) + ;; (if (eq? pass-num 1) + ;; (begin ;; big reset + ;; (iup:attribute-set! run-matrix "CLEARVALUE" "ALL") ;; NOTE: Was CONTENTS + ;; (iup:attribute-set! run-matrix "CLEARATTRIB" "CONTENTS") + ;; (iup:attribute-set! run-matrix "RESIZEMATRIX" "YES"))) + ;; + ;; (if (> max-col (string->number (iup:attribute run-matrix "NUMCOL"))) + ;; (iup:attribute-set! run-matrix "NUMCOL" max-col )) + ;; + ;; (let ((effective-max-row (if (< max-row max-visible) max-visible max-row))) + ;; (if (> effective-max-row (string->number (iup:attribute run-matrix "NUMLIN"))) + ;; (iup:attribute-set! run-matrix "NUMLIN" effective-max-row ))) + ;; + ;; ;; Row labels + ;; (for-each (lambda (ind) + ;; (let* ((name (car ind)) + ;; (num (cadr ind)) + ;; (key (conc num ":0"))) + ;; (if (not (equal? (iup:attribute run-matrix key) name)) + ;; (begin + ;; (set! changed #t) + ;; (iup:attribute-set! run-matrix key name))))) + ;; row-indices) + ;; ;; (print "row-indices: " row-indices " col-indices: " col-indices) + ;; (if (and (eq? pass-num 0) changed) + ;; (loop 1 #t)) ;; force second pass + ;; + ;; ;; Cell contents + ;; (for-each (lambda (entry) + ;; ;; (print "entry: " entry) + ;; (let* ((row-name (cadr entry)) + ;; (col-name (car entry)) + ;; (valuedat (caddr entry)) + ;; (test-id (list-ref valuedat 0)) + ;; (test-name row-name) ;; (list-ref valuedat 1)) + ;; (item-path col-name) ;; (list-ref valuedat 2)) + ;; (state (list-ref valuedat 1)) + ;; (status (list-ref valuedat 2)) + ;; (value (gutils:get-color-for-state-status state status)) + ;; (row-num (cadr (assoc row-name row-indices))) + ;; (col-num (cadr (assoc col-name col-indices))) + ;; (key (conc row-num ":" col-num))) + ;; (hash-table-set! cell-lookup key test-id) + ;; (if (not (equal? (iup:attribute run-matrix key) (cadr value))) + ;; (begin + ;; (set! changed #t) + ;; (iup:attribute-set! run-matrix key (cadr value)) + ;; (iup:attribute-set! run-matrix (conc "BGCOLOR" key) (car value)))))) + ;; matrix-content) + ;; + ;; ;; Col labels - do after setting Cell contents so they are accounted for in the size calc. + ;; + ;; (for-each (lambda (ind) + ;; (let* ((name (car ind)) + ;; (num (cadr ind)) + ;; (key (conc "0:" num))) + ;; (if (not (equal? (iup:attribute run-matrix key) name)) + ;; (begin + ;; (set! changed #t) + ;; (iup:attribute-set! run-matrix key name) + ;; (if (<= num max-col) + ;; (iup:attribute-set! run-matrix "FITTOTEXT" (conc "C" num))))))) + ;; col-indices) + ;; + ;; (if (and (eq? pass-num 0) changed) + ;; (loop 1 #t)) ;; force second pass due to column labels changing + ;; + ;; ;; (debug:print 0 *default-log-port* "runs-summary-updater, changed: " changed " pass-num: " pass-num) + ;; ;; (print "runs-summary-updater, changed: " changed " pass-num: " pass-num) + ;; (if changed (iup:attribute-set! run-matrix "REDRAW" "ALL"))))))))) + +(define (dboard:areas-make-matrix commondat tabdat ) + (iup:matrix + #:expand "YES" + #:click-cb + + (lambda (obj lin col status) + (debug:catch-and-dump + (lambda () + + ;; Bummer - we dont have the global get/set api mapped in chicken + ;; (let* ((modkeys (iup:global "MODKEYSTATE"))) + ;; (BB> "modkeys="modkeys)) + + (debug:print-info 13 *default-log-port* "click-cb: obj="obj" lin="lin" col="col" status="status) + ;; status is corrupted on Brandon's home machine. will have to wait until after shutdown to see if it is still broken in PDX SLES + (let* ((dbstruct (dboard:get-dbstruct commondat #f)) + (toolpath (car (argv))) + (key (conc lin ":" col)) + (test-id (hash-table-ref/default cell-lookup key -1)) + (run-id (dboard:tabdat-curr-run-id tabdat)) + (run-info (db:get-run-info dbstruct run-id)) + (target (db:get-target dbstruct run-id)) + (runname (db:get-value-by-header (db:get-rows run-info) + (db:get-header run-info) "runname")) + (test-info (db:get-test-info-by-id dbstruct run-id test-id)) + (test-name (db:test-get-testname test-info)) + (testpatt (let ((tlast (db:tasks-get-last dbstruct target runname))) + (if tlast + (let ((tpatt (tasks:task-get-testpatt tlast))) + (if (member tpatt '("0" 0)) ;; known bad historical value - remove in 2017 + "%" + tpatt)) + "%"))) + (item-path (db:test-get-item-path (db:get-test-info-by-id dbstruct run-id test-id))) + (item-test-path (conc test-name "/" (if (equal? item-path "") + "%" + item-path))) + (status-chars (char-set->list (string->char-set status))) + (testpanel-cmd (conc toolpath " -test " (dboard:tabdat-curr-run-id tabdat) "," test-id " &"))) + (debug:print-info 13 *default-log-port* "status-chars=["status-chars"] status=["status"]") + (cond + ((member #\1 status-chars) ;; 1 is left mouse button + (system testpanel-cmd)) + + ((member #\2 status-chars) ;; 2 is middle mouse button + + (debug:print-info 13 *default-log-port* "mmb- test-name="test-name" testpatt="testpatt) + (iup:show (dashboard:areas-popup-menu run-id test-id target runname test-name testpatt item-test-path test-info) ;; popup-menu + #:x 'mouse + #:y 'mouse + #:modal? "NO") + ) + (else + (debug:print-info 13 *default-log-port* "unhandled status in run-summary-click-cb. Doing right click action. (status is corrupted on Brandon's ubuntu host - bad/buggy iup install??" ) + (iup:show (dashboard:areas-popup-menu run-id test-id target runname test-name testpatt item-test-path test-info) ;; popup-menu + #:x 'mouse + #:y 'mouse + #:modal? "NO") + )))) "runs-summary-click-callback")))) + +;; This is the Areas Summary tab +;; +(define (dashboard:areas-summary commondat tabdat #!key (tab-num #f)) + (let* ((update-mutex (dboard:commondat-update-mutex commondat)) + (tb (iup:treebox + #:value 0 + #:name "Areas" + #:expand "YES" + #:addexpanded "YES" + #:selection-cb + (lambda (obj id state) + (debug:catch-and-dump + (lambda () + ;; (print "obj: " obj ", id: " id ", state: " state) + (let* ((prev-tree-path (dboard:tabdat-tree-path tabdat)) + (tree-path (tree:node->path obj id)) + ;; Need to get the path construction from the pivot data but for now assume: + ;; Area Target Runname + + + + + + ;;; ADD STUFF HERE .... + + + ) + (if (not (equal? prev-tree-path tree-path)) + (dboard:tabdat-view-changed tabdat)) + + (dboard:tabdat-tree-path-set! tabdat tree-path))) + ;; (run-id (tree-path->run-id tabdat (cdr run-path)))) + ;; (if (number? run-id) + ;; (begin + ;; (dboard:tabdat-prev-run-id-set! + ;; tabdat + ;; (dboard:tabdat-curr-run-id tabdat)) + ;; + ;; (dboard:tabdat-curr-run-id-set! tabdat run-id) + ;; (dboard:tabdat-layout-update-ok-set! tabdat #f) + ;; ;; (dashboard:update-run-summary-tab) + ;; ) + ;; ;; (debug:print-error 0 *default-log-port* "tree-path->run-id returned non-number " run-id) + ;; ))) + "selection-cb in areas-summary") + ;; (print "path: " (tree:node->path obj id) " run-id: " run-id) + ))) + (cell-lookup (make-hash-table)) + (areas-matrix (dboard:areas-make-matrix commondat tabdat)) + (areas-summary-updater (lambda () + ;; maps data from tabdat view-dat to the matrix + ;; if input databases have changed, refresh view-dat + ;; if filters have changed, refresh view-dat from input databases + ;; if pivots have changed, refresh view-dat from input databases + (mutex-lock! update-mutex) + (if (or ;; (dashboard:areas-database-changed? commondat tabdat context-key: 'runs-summary-updater) + (dboard:tabdat-view-changed tabdat)) + (debug:catch-and-dump + (lambda () ;; check that areas-matrix is initialized before calling the updater + (if areas-matrix + (dashboard:areas-summary-updater commondat tabdat tb cell-lookup areas-matrix))) + "dashboard:areas-summary-updater") + ) + (mutex-unlock! update-mutex))) + (runs-summary-control-panel (dashboard:areas-summary-control-panel commondat tabdat))) + (dboard:commondat-add-updater commondat areas-summary-updater tab-num: tab-num) + (dboard:tabdat-runs-tree-set! tabdat tb) + (iup:vbox + (iup:split + #:value 200 + tb + areas-matrix) + (dboard:make-controls commondat tabdat extra-widget: runs-summary-control-panel)))) + +;; this calls dboard:get-tests-for-run-duplicate for each run +;; +;; create a virtual table of all the tests +;; keypatts: ( (KEY1 "abc%def")(KEY2 "%") ) +;; +(define (dboard:areas-update-rundat commondat tabdat runnamepatt numruns testnamepatt keypatts) + (let* ((access-mode (dboard:tabdat-access-mode tabdat)) + (dbstruct (dboard:get-dbstruct commondat #f)) + (keys (dboard:tabdat-keys tabdat)) + (last-runs-update (- (dboard:tabdat-last-runs-update tabdat) 2)) + (allruns (db:get-runs dbstruct runnamepatt numruns (dboard:tabdat-start-run-offset tabdat) keypatts)) + ;;(allruns-tree (mrmt:get-runs-by-patt (dboard:tabdat-keys tabdat) "%" #f #f #f #f)) + (allruns-tree (db:get-runs-by-patt dbstruct keys "%" #f #f #f #f 0)) ;; last-runs-update));;'("id" "runname") + (header (db:get-header allruns)) + (runs (db:get-rows allruns)) ;; RA => Filtered as per runpatt selected + (runs-tree (db:get-rows allruns-tree)) ;; RA => Returns complete list of runs + (start-time (current-seconds)) + (runs-hash (let ((ht (make-hash-table))) + (for-each (lambda (run) + (hash-table-set! ht (db:get-value-by-header run header "id") run)) + runs-tree) ;; (vector-ref runs-dat 1)) + ht)) + (tb (dboard:tabdat-runs-tree tabdat))) + (dboard:tabdat-last-runs-update-set! tabdat (- (current-seconds) 2)) + (dboard:tabdat-header-set! tabdat header) + ;; + ;; trim runs to only those that are changing often here + ;; + (if (null? runs) + (begin + (dboard:tabdat-allruns-set! tabdat '()) + (dboard:tabdat-all-test-names-set! tabdat '()) + (dboard:tabdat-item-test-names-set! tabdat '()) + (hash-table-clear! (dboard:tabdat-allruns-by-id tabdat))) + (let loop ((run (car runs)) + (tal (cdr runs)) + (res '()) + (maxtests 0)) + (let* ((run-id (db:get-value-by-header run header "id")) + (run-struct (hash-table-ref/default (dboard:tabdat-allruns-by-id tabdat) run-id #f)) + ;; (last-update (if run-struct (dboard:rundat-last-update run-struct) 0)) + (key-vals (db:get-key-vals dbstruct run-id)) + (tests-ht (dboard:get-tests-for-run-duplicate tabdat run-id run testnamepatt key-vals)) + ;; GET RID OF dboard:get-tests-dat - it is superceded by dboard:get-tests-for-run-duplicate + ;; dboard:get-tests-for-run-duplicate - returns a hash table + ;; (dboard:get-tests-dat tabdat run-id last-update)) + (all-test-ids (hash-table-keys tests-ht)) + (num-tests (length all-test-ids))) + ;; (print "run-struct: " run-struct) + ;; NOTE: bubble-up also sets the global (dboard:tabdat-item-test-names tabdat) + ;; (tests (bubble-up tmptests priority: bubble-type)) + ;; NOTE: 11/01/2013 This routine is *NOT* getting called excessively. + ;; (debug:print 0 *default-log-port* "Getting data for run " run-id " with key-vals=" key-vals) + ;; Not sure this is needed? + (let* ((newmaxtests (max num-tests maxtests)) + ;; (last-update (- (current-seconds) 10)) + (run-struct (or run-struct + (dboard:rundat-make-init + run: run + tests: tests-ht + key-vals: key-vals))) + (new-res (if (null? all-test-ids) + res + (delete-duplicates + (cons run-struct res) + (lambda (a b) + (eq? (db:get-value-by-header (dboard:rundat-run a) header "id") + (db:get-value-by-header (dboard:rundat-run b) header "id")))))) + (elapsed-time (- (current-seconds) start-time))) + (if (null? all-test-ids) + (hash-table-delete! (dboard:tabdat-allruns-by-id tabdat) run-id) + (hash-table-set! (dboard:tabdat-allruns-by-id tabdat) run-id run-struct)) + (if (or (null? tal) + (> elapsed-time 2)) ;; stop loading data after 5 seconds, on the next call more data *should* be loaded since get-tests-for-run uses last update + (begin + (when (> elapsed-time 2) + (debug:print 0 *default-log-port* "NOTE: updates are taking a long time, " elapsed-time "s elapsed.") + (let* ((old-val (iup:attribute *tim* "TIME")) + (new-val (number->string (inexact->exact (floor (* 2 (string->number old-val))))))) + (debug:print 0 *default-log-port* "NOTE: increasing poll interval from "old-val" to "new-val) + (iup:attribute-set! *tim* "TIME" new-val)) + + + ) + (dboard:tabdat-allruns-set! tabdat new-res) + maxtests) + (if (> (dboard:rundat-run-data-offset run-struct) 0) + (loop run tal new-res newmaxtests) ;; not done getting data for this run + (loop (car tal)(cdr tal) new-res newmaxtests))))))) + (dboard:tabdat-filters-changed-set! tabdat #f) + (dboard:areas-update-tree tabdat runs-hash header tb))) + +;; runs update-rundat using the various filters from the gui +;; +(define (dashboard:areas-do-update-rundat commondat tabdat) + (dboard:areas-update-rundat + commondat + tabdat + (hash-table-ref/default (dboard:tabdat-searchpatts tabdat) "runname" "%") + (dboard:tabdat-numruns tabdat) + (hash-table-ref/default (dboard:tabdat-searchpatts tabdat) "test-name" "%/%") + ;; generate key patterns from the target stored in tabdat + (let* ((dbkeys (dboard:tabdat-dbkeys tabdat))) + (let ((fres (if (dboard:tabdat-target tabdat) + (let ((ptparts (append (dboard:tabdat-target tabdat)(make-list (length dbkeys) "%")))) + (map (lambda (k v)(list k v)) dbkeys ptparts)) + (let ((res '())) + (for-each (lambda (key) + (if (not (equal? key "runname")) + (let ((val (hash-table-ref/default (dboard:tabdat-searchpatts tabdat) key #f))) + (if val (set! res (cons (list key val) res)))))) + dbkeys) + res)))) + fres)))) + +(define (dashboard:areas-get-runs-hash commondat tabdat) + (let* ((access-mode (dboard:tabdat-access-mode tabdat)) + (dbstruct (dboard:get-dbstruct commondat #f)) + (last-runs-update 0);;(dboard:tabdat-last-runs-update tabdat)) + (runs-dat (db:get-runs-by-patt dbstruct (dboard:tabdat-keys tabdat) "%" #f #f #f #f last-runs-update)) + (runs-header (vector-ref runs-dat 0)) ;; 0 is header, 1 is list of records + (runs (vector-ref runs-dat 1)) + (run-id (dboard:tabdat-curr-run-id tabdat)) + (runs-hash (let ((ht (make-hash-table))) + (for-each (lambda (run) + (hash-table-set! ht (db:get-value-by-header run runs-header "id") run)) + runs) ht))) + runs-hash)) + +;; DOES NOT WORK RELIABLY WITH /tmp WAL mode files. Timestamps only change when the db +;; is closed (I think). If db dir starts with /tmp always return true +;; +(define (dashboard:areas-database-changed? commondat tabdat #!key (context-key 'default)) + (let* ((run-update-time (current-seconds)) + (dbdir (dboard:tabdat-dbdir tabdat)) + (modtime (dashboard:areas-get-youngest-run-db-mod-time dbdir)) + (recalc (dashboard:areas-recalc modtime + (dboard:commondat-please-update commondat) + (dboard:get-last-db-update tabdat context-key)))) + ;; (dboard:tabdat-last-db-update tabdat)))) + (if recalc + (dboard:set-last-db-update! tabdat context-key run-update-time)) + (dboard:commondat-please-update-set! commondat #f) + recalc)) + +;; open the area dbs, given list of areas that are "cared about" +;; areas: '( (area_name . path) ... ) ;; NOT necessarily the section [areas] from megatest.config +;; +(define (dboard:areas-open-areas commondat tabdat areas) + (let ((areas-ht (dboard:commondat-areas commondat))) + (for-each + (lambda (area-dat) + (db:dashboard-open-dbstruct areas (car area-dat)(cdr area-dat))) + areas))) + + + +(define (dboard:areas-update-tree tabdat runs-hash runs-header tb) + (let* ((tree-path (dboard:tabdat-tree-path tabdat)) + ;; (access-mode (dboard:tabdat-access-mode tabdat)) + ;; (run-ids (sort (filter number? (hash-table-keys runs-hash)) + ;; (lambda (a b) + ;; (let* ((record-a (hash-table-ref runs-hash a)) + ;; (record-b (hash-table-ref runs-hash b)) + ;; (time-a (db:get-value-by-header record-a runs-header "event_time")) + ;; (time-b (db:get-value-by-header record-b runs-header "event_time"))) + ;; (< time-a time-b))))) + ;; (changed #f) + ;; (last-runs-update (dboard:tabdat-last-runs-update tabdat)) + ;; (runs-dat (mrmt:get-runs-by-patt (dboard:tabdat-keys tabdat) "%" #f #f #f #f 0)) ;; last-runs-update)) + ;; (runs-header (vector-ref runs-dat 0)) ;; 0 is header, 1 is list of records + ;; (runs (vector-ref runs-dat 1)) + ;; (new-run-ids (map (lambda (run) + ;; (db:get-value-by-header run runs-header "id")) + ;; runs)) + (areas (configf:get-section *configdat* "areas"))) + (dboard:tabdat-last-runs-update-set! tabdat (- (current-seconds) 2)) + (for-each + (lambda (area) + (let ((run-path (list area))) + (if (not (hash-table-ref/default (dboard:tabdat-path-run-ids tabdat) run-path #f)) + (begin + (tree:add-node tb "Areas" run-path) + (hash-table-set! (dboard:tabdat-path-run-ids tabdat) run-path 0))))) + (map car areas)) + ;; here the local area + ;;(for-each + ;; (lambda (run-id) + ;; (let* ((run-record (hash-table-ref/default runs-hash run-id #f)) + ;; (key-vals (map (lambda (key)(db:get-value-by-header run-record runs-header key)) + ;; (dboard:tabdat-keys tabdat))) + ;; (run-name (db:get-value-by-header run-record runs-header "runname")) + ;; (col-name (conc (string-intersperse key-vals "\n") "\n" run-name)) + ;; (run-path (cons "local " (append key-vals (list run-name))))) + ;; (if (not (hash-table-ref/default (dboard:tabdat-path-run-ids tabdat) run-path #f)) + ;; ;; (let ((existing (tree:find-node tb run-path))) + ;; ;; (if (not existing) + ;; (begin + ;; (hash-table-set! (dboard:tabdat-run-keys tabdat) run-id run-path) + ;; ;; (iup:attribute-set! (dboard:tabdat-runs-matrix tabdat) + ;; ;; (conc rownum ":" colnum) col-name) + ;; ;; (hash-table-set! runid-to-col run-id (list colnum run-record)) + ;; ;; Here we update the tests treebox and tree keys + ;; (tree:add-node tb "Areas" run-path) ;; (append key-vals (list run-name)) + ;; ;; userdata: (conc "run-id: " run-id)))) + ;; (hash-table-set! (dboard:tabdat-path-run-ids tabdat) run-path run-id) + ;; ;; (set! colnum (+ colnum 1)) + ;; )))) + ;; (append new-run-ids run-ids)))) ;; for-each run-id + )) + +(define (dashboard:areas-run-id->tests-mindat dbstruct run-id tabdat runs-hash) + (let* ((run (hash-table-ref/default runs-hash run-id #f)) + (key-vals (db:get-key-vals dbstruct run-id)) + (testnamepatt (or (dboard:tabdat-test-patts tabdat) "%/%")) + (tests-ht (dboard:get-tests-for-run-duplicate tabdat run-id run testnamepatt key-vals)) + (tests-dat (dashboard:tests-ht->tests-dat tests-ht)) + (tests-mindat (dcommon:minimize-test-data tests-dat))) ;; reduces data for display + (dboard:tabdat-last-runs-update-set! tabdat (- (current-seconds) 2)) + (hash-table-set! (dboard:tabdat-last-test-dat tabdat) run-id tests-dat) + (hash-table-set! (dboard:tabdat-run-update-times tabdat) run-id (- (current-seconds) 10)) + (when (not run) + (debug:print-info 13 *default-log-port* "ERROR: NO RUN FOR RUN-ID run-id="run-id) + (debug:print-info 13 *default-log-port* "runs-hash-> " (hash-table->alist runs-hash)) + ) + tests-mindat)) + +(define (dashboard:areas-runs-summary-xor-matrix-content commondat tabdat runs-hash #!key (hide-clean #f)) + (let* ((dbstruct (dboard:get-dbstruct commondat #f)) + (src-run-id (dboard:tabdat-prev-run-id tabdat)) + (dest-run-id (dboard:tabdat-curr-run-id tabdat))) + (if (and src-run-id dest-run-id) + (dcommon:xor-tests-mindat + (dashboard:run-id->tests-mindat dbstruct src-run-id tabdat runs-hash) + (dashboard:run-id->tests-mindat dbstruct dest-run-id tabdat runs-hash) + hide-clean: hide-clean) + #f))) + +(define (dashboard:areas-popup-menu run-id test-id target runname test-name testpatt item-test-path test-info) + (iup:menu + (iup:menu-item + "Test Control Panel" + #:action + (lambda (obj) + (let* ((toolpath (car (argv))) + (testpanel-cmd + (conc toolpath " -test " run-id "," test-id " &"))) + (system testpanel-cmd) + ))) + + (iup:menu-item + (conc "View Log " item-test-path) + #:action + (lambda (obj) + (let* ((rundir (db:test-get-rundir test-info)) + (logf (db:test-get-final_logf test-info)) + (fullfile (conc rundir "/" logf))) + (if (common:file-exists? fullfile) + (dcommon:run-html-viewer fullfile) + (message-window (conc "file " fullfile " not found."))))) + ) + (let* ((steps (tests:get-compressed-steps run-id test-id)) ;; # + (rundir (db:test-get-rundir test-info))) + (iup:menu-item + "Step logs" + (apply iup:menu + (map (lambda (step) + (let ((stepname (vector-ref step 0)) + (logfile (vector-ref step 5)) + (status (vector-ref step 3))) + (iup:menu-item + (conc stepname "/" (if (string=? logfile "") "no log!" logfile) " (" status ")") + #:action (lambda (obj) + (let ((fullfile (conc rundir "/" logfile))) + (if (common:file-exists? fullfile) + (dcommon:run-html-viewer fullfile) + (message-window (conc "file " fullfile " not found")))))))) + steps)))) + (iup:menu-item + (conc "Rerun " item-test-path) + #:action + (lambda (obj) + (common:run-a-command + (conc "megatest -set-state-status NOT_STARTED,n/a -run -target " target + " -runname " runname + " -testpatt " item-test-path + " -preclean -clean-cache")))) + + (iup:menu-item + "Start xterm" + #:action + (lambda (obj) + (dcommon:examine-xterm run-id test-id))) + + (iup:menu-item + (conc "Kill " item-test-path) + #:action + (lambda (obj) + (common:run-a-command + (conc "megatest -set-state-status KILLREQ,n/a -target " target + " -runname " runname + " -testpatt " item-test-path + " -state RUNNING,REMOTEHOSTSTART,LAUNCHED,NOT_STARTED")))) + + + (iup:menu-item + "Run" + (iup:menu + (iup:menu-item + (conc "Rerun " testpatt) + #:action + (lambda (obj) + ;; (print " run-id: " run-id " test-id: " test-id " target: " target " runname: " runname " test-name: " test-name " testpatt: " testpatt "item-path : " item-path) + (common:run-a-command + (conc "megatest -run -target " target + " -runname " runname + " -testpatt " testpatt + " -preclean -clean-cache") + ))) + (iup:menu-item + "Rerun Complete Run" + #:action + (lambda (obj) + (common:run-a-command + (conc "megatest -set-state-status NOT_STARTED,n/a -run -target " target + " -runname " runname + " -testpatt % " + " -preclean -clean-cache")))) + (iup:menu-item + "Clean Complete Run" + #:action + (lambda (obj) + (common:run-a-command + (conc "megatest -remove-runs -target " target + " -runname " runname + " -testpatt % ")))) + (iup:menu-item + "Kill Complete Run" + #:action + (lambda (obj) + (common:run-a-command + (conc "megatest -set-state-status KILLREQ,n/a -target " target + " -runname " runname + " -testpatt % " + " -state RUNNING,REMOTEHOSTSTART,LAUNCHED,NOT_STARTED")))) + (iup:menu-item + "Delete Run Data" + #:action + (lambda (obj) + (common:run-a-command + (conc "megatest -remove-runs -target " target + " -runname " runname + " -testpatt % " + " -keep-records")))))) + (iup:menu-item + "Test" + (iup:menu + (iup:menu-item + (conc "Rerun " item-test-path) + #:action + (lambda (obj) + (common:run-a-command + (conc "megatest -set-state-status NOT_STARTED,n/a -run -target " target + " -runname " runname + " -testpatt " item-test-path + " -preclean -clean-cache")))) + (iup:menu-item + (conc "Kill " item-test-path) + #:action + (lambda (obj) + (common:run-a-command + (conc "megatest -set-state-status KILLREQ,n/a -target " target + " -runname " runname + " -testpatt " item-test-path + " -state RUNNING,REMOTEHOSTSTART,LAUNCHED")))) + (iup:menu-item + (conc "Delete data : " item-test-path) + #:action + (lambda (obj) + (common:run-a-command + (conc "megatest -remove-runs -target " target + " -runname " runname + " -testpatt " item-test-path + " -keep-records")))) + (iup:menu-item + (conc "Clean "item-test-path) + #:action + (lambda (obj) + (common:run-a-command + (conc "megatest -remove-runs -target " target + " -runname " runname + " -testpatt " item-test-path)))) + (iup:menu-item + "Start xterm" + #:action + (lambda (obj) + (dcommon:examine-xterm run-id test-id))) + ;;(let* ((cmd (conc (car (argv)) " -xterm " run-id "," test-id "&"))) + ;; (system cmd)))) + (iup:menu-item + "Edit testconfig" + #:action + (lambda (obj) + (let* ((all-tests (tests:get-all)) + (editor-rx (or (configf:lookup *configdat* "setup" "editor-regex") + "\\b(vim?|nano|pico)\\b")) + (editor (or (configf:lookup *configdat* "setup" "editor") + (get-environment-variable "VISUAL") + (get-environment-variable "EDITOR") "vi")) + (tconfig (conc (hash-table-ref all-tests test-name) "/testconfig")) + (cmd (conc (if (string-search editor-rx editor) + (conc "xterm -e " editor) + editor) + " " tconfig " &"))) + (system cmd)))) + )))) + + +(define (dashboard:areas-get-youngest-run-db-mod-time dbdir) + (handle-exceptions + exn + (begin + (debug:print 2 *default-log-port* "WARNING: error in accessing databases in get-youngest-run-db-mod-time: " ((condition-property-accessor 'exn 'message) exn) " db-dir="dbdir) + (current-seconds)) ;; something went wrong - just print an error and return current-seconds + (common:max (map (lambda (filen) + (file-modification-time filen)) + (glob (conc dbdir "/*.db*")))))) + +(define (dashboard:areas-recalc modtime please-update-buttons last-db-update-time) + (or please-update-buttons + (and ;; (> (current-milliseconds)(+ *last-recalc-ended-time* 150)) ;; can't use this - it needs to be tab specific + (> modtime (- last-db-update-time 3)) ;; add three seconds of margin + (> (current-seconds)(+ last-db-update-time 1))))) + +;; setup buttons and callbacks to switch between modes in runs summary tab +;; +(define (dashboard:areas-summary-control-panel commondat tabdat) + (let* ((summary-buttons ;; build buttons + (map + (lambda (mode-item) + (let* ((this-mode (car mode-item)) + (this-mode-label (cdr mode-item))) + (iup:button this-mode-label + #:action + (lambda (obj) + (debug:catch-and-dump + (lambda () + (dboard:tabdat-runs-summary-mode-set! tabdat this-mode) + (dboard:areas-summary-control-panel-updater commondat tabdat)) + "runs summary control panel updater"))))) + (dboard:tabdat-runs-summary-modes tabdat))) + (summary-buttons-hbox (apply iup:hbox summary-buttons)) + (xor-runname-labels-hbox + (iup:hbox + (let ((temp-label + (iup:label "" #:size "125x15" #:fontsize "10" ))) + (dboard:tabdat-runs-summary-source-runname-label-set! tabdat temp-label) + temp-label + ) + (let ((temp-label + (iup:label "" #:size "125x15" #:fontsize "10"))) + (dboard:tabdat-runs-summary-dest-runname-label-set! tabdat temp-label) + temp-label)))) + (dboard:tabdat-runs-summary-mode-buttons-set! tabdat summary-buttons) + + ;; maybe wrap in a frame + (let ((res (iup:vbox summary-buttons-hbox xor-runname-labels-hbox ))) + (dboard:areas-summary-control-panel-updater commondat tabdat) + res + ))) + +(define (dboard:areas-summary-control-panel-updater commondat tabdat) + (dboard:areas-summary-xor-labels-updater commondat tabdat) + (dboard:areas-summary-buttons-updater tabdat)) + +(define (dboard:areas-summary-xor-labels-updater commondat tabdat) + (let ((source-runname-label (dboard:tabdat-runs-summary-source-runname-label tabdat)) + (dest-runname-label (dboard:tabdat-runs-summary-dest-runname-label tabdat)) + (mode (dboard:tabdat-runs-summary-mode tabdat)) + (dbstruct (dboard:get-dbstruct commondat #f))) + (when (and source-runname-label dest-runname-label) + (case mode + ((xor-two-runs xor-two-runs-hide-clean) + (let* ((curr-run-id (dboard:tabdat-curr-run-id tabdat)) + (prev-run-id (dboard:tabdat-prev-run-id tabdat)) + (curr-runname (if curr-run-id + (db:get-run-name-from-id dbstruct curr-run-id) + "None")) + (prev-runname (if prev-run-id + (db:get-run-name-from-id dbstruct prev-run-id) + "None"))) + (iup:attribute-set! source-runname-label "TITLE" (conc " SRC: "prev-runname" ")) + (iup:attribute-set! dest-runname-label "TITLE" (conc "DEST: "curr-runname" ")))) + (else + (iup:attribute-set! source-runname-label "TITLE" "") + (iup:attribute-set! dest-runname-label "TITLE" "")))))) + +(define (dboard:areas-summary-buttons-updater tabdat) + (let loop ((buttons-left (dboard:tabdat-runs-summary-mode-buttons tabdat)) + (modes-left (dboard:tabdat-runs-summary-modes tabdat))) + (if (or (null? buttons-left) (null? modes-left)) + #t + (let* ((this-button (car buttons-left)) + (mode-item (car modes-left)) + (this-mode (car mode-item)) + (sel-color "180 100 100") + (nonsel-color "170 170 170") + (current-mode (dboard:tabdat-runs-summary-mode tabdat))) + (if (eq? this-mode current-mode) + (iup:attribute-set! this-button "BGCOLOR" sel-color) + (iup:attribute-set! this-button "BGCOLOR" nonsel-color)) + (loop (cdr buttons-left) (cdr modes-left)))))) + Index: dashboard.scm ================================================================== --- dashboard.scm +++ dashboard.scm @@ -22,11 +22,11 @@ (declare (uses common)) (declare (uses margs)) (declare (uses keys)) (declare (uses items)) -(declare (uses db)) +;; (declare (uses db)) (declare (uses configf)) (declare (uses process)) (declare (uses launch)) (declare (uses runs)) (declare (uses dashboard-tests)) @@ -35,11 +35,12 @@ (declare (uses dcommon)) (declare (uses vg)) ;; (declare (uses dashboard-main)) (declare (uses megatest-version)) -(declare (uses mt)) +(declare (uses mrmt)) +;; (declare (uses mt)) (include "common_records.scm") (include "db_records.scm") (include "run_records.scm") (include "task_records.scm") @@ -53,11 +54,10 @@ Usage: dashboard [options] -h : this help -test run-id,test-id : control test identified by testid -skip-version-check : skip the version check - -use-db-cache : access database via cache Misc -rows R : set number of rows -cols C : set number of columns ")) @@ -82,11 +82,11 @@ "-use-server" "-guimonitor" "-main" "-v" "-q" - "-use-db-cache" + ;; "-use-db-cache" "-skip-version-check" "-repl" "-rh5.11" ;; fix to allow running on rh5.11 ) args:arg-hash @@ -102,32 +102,36 @@ (print help) (exit))) ;; TODO: Move this inside (main) ;; -(if (not (launch:setup)) - (begin - (print "Failed to find megatest.config, exiting") - (exit 1))) +;; (if (not (launch:setup)) +;; (begin +;; (print "Failed to find megatest.config, exiting") +;; (exit 1))) ;; deal with RH 5.11 gtk lib or iup lib missing detachbox feature ;; first check for the switch ;; (if (or (args:get-arg "-rh5.11") (configf:lookup *configdat* "dashboard" "no-detachbox")) (set! iup:detachbox iup:vbox)) -(if (not (common:on-homehost?)) - (begin - (debug:print 0 *default-log-port* "WARNING: Current policy requires running dashboard on homehost: " (common:get-homehost)))) +;; (if (not (common:on-homehost?)) +;; (begin +;; (debug:print 0 *default-log-port* "WARNING: Current policy requires running dashboard on homehost: " (common:get-homehost)))) ;; RA => Might require revert for filters ;; create a watch dog to move changes from lt/.db/*.db to megatest.db ;; ;;;(if (file-write-access? (conc *toppath* "/megatest.db")) ;;(debug:print-info 13 *default-log-port* "Before common:watchdog spawn") -(thread-start! (make-thread common:watchdog "Watchdog thread")) + + +;; (thread-start! (make-thread common:watchdog "Watchdog thread")) + + ;;(debug:print-info 13 *default-log-port* "After common:watchdog spawn") ;; (if (not (args:get-arg "-use-db-cache")) ;; (begin ;; (debug:print-info 0 *default-log-port* "Forcing db-cache mode due to read-only access to megatest.db") ;; (hash-table-set! args:arg-hash "-use-db-cache" #t)));;;) @@ -136,28 +140,30 @@ ;; data common to all tabs goes here ;; (defstruct dboard:commondat ((curr-tab-num 0) : number) please-update - tabdats - update-mutex - updaters - updating - uidat ;; needs to move to tabdat at some time - hide-not-hide-tabs - ) - -(define (dboard:commondat-make) - (make-dboard:commondat - curr-tab-num: 0 - tabdats: (make-hash-table) - please-update: #t - update-mutex: (make-mutex) - updaters: (make-hash-table) - updating: #f - hide-not-hide-tabs: #f - )) + (tabdats (make-hash-table)) + (update-mutex (make-mutex)) + (updaters (make-hash-table)) + (updating #f) + uidat ;; needs to move to tabdat at some time + (hide-not-hide-tabs #f) + (default-area-path #f) ;; the area of the path where the dashboard was started, if it is a megatest area + (areas (make-hash-table)) ;; area-name ==> dbstruct + ;; (area-dbs #f) ;; use db:dashboard-open-db to add areas to the areas hash + ) + +;; general "db getter" +;; +(define (dboard:get-dbstruct commondat area-path-in) ;; area-path=#f gets local connection + (let ((areas (dboard:commondat-areas commondat)) + (apath (or area-path-in (current-directory)))) + (or (db:dashboard-open-dbstruct areas "local" apath) + (begin + (debug:print 0 *default-debug-port* "Failed to open db in directory " apath ", are you staring dashboard in a Megatest area? Exiting...") + (exit 1))))) ;; RA => returns the tabdat stored at hashkey passed in commondat-tabdats table (e.g. 0 gives summary) ;; (define (dboard:common-get-tabdat commondat #!key (tab-num #f)) (let* ((tnum (or tab-num @@ -164,11 +170,11 @@ (dboard:commondat-curr-tab-num commondat) 0)) ;; tab-num value is curr-tab-num value in passed commondat (ht (dboard:commondat-tabdats commondat)) (res (hash-table-ref/default ht tnum #f))) (or res - (let ((new-tabdat (dboard:tabdat-make-data))) + (let ((new-tabdat (dboard:tabdat-make-data commondat))) (hash-table-set! ht tnum new-tabdat) new-tabdat)))) ;; RA => sets the tabdat passed to the hashkey at commondat:tabdats hash table ;; @@ -308,13 +314,16 @@ ((runs-summary-mode-buttons '()) : list) ((runs-summary-mode 'one-run) : symbol) ((runs-summary-mode-change-callbacks '()) : list) (runs-summary-source-runname-label #f) (runs-summary-dest-runname-label #f) - ;; runs summary view - - tests-tree ;; used in newdashboard + + ;; Areas summary view + (tree-path '()) + (pivots #f) + (filters #f) + (view-dat (hh:make-hh)) ;; hierarchial hash of the data to view ) ;; register tabdat with BBpp ;; this is used by BBpp (Brandon's pretty printer) to convert dboard:tabdat into a composition of lists that pp will handle (hash-table-set! *BBpp_custom_expanders_list* TABDAT: @@ -335,28 +344,31 @@ ;; additional setters for dboard:data (define (dboard:tabdat-test-patts-set!-use vec val) (dboard:tabdat-test-patts-set! vec (if (equal? val "") #f val))) -(define (dboard:tabdat-make-data) +(define (dboard:tabdat-make-data commondat) (let ((dat (make-dboard:tabdat))) - (dboard:setup-tabdat dat) + (dboard:setup-tabdat commondat dat) (dboard:setup-num-rows dat) dat)) -(define (dboard:setup-tabdat tabdat) - (dboard:tabdat-dbdir-set! tabdat (db:dbfile-path)) ;; (conc (configf:lookup *configdat* "setup" "linktree") "/.db")) - (dboard:tabdat-dbfpath-set! tabdat (db:dbfile-path)) - (dboard:tabdat-monitor-db-path-set! tabdat (conc (dboard:tabdat-dbdir tabdat) "/monitor.db")) - - ;; HACK ALERT: this is a hack, please fix. - (dboard:tabdat-ro-set! tabdat (not (file-read-access? (dboard:tabdat-dbfpath tabdat)))) - - (dboard:tabdat-keys-set! tabdat (rmt:get-keys)) - (dboard:tabdat-dbkeys-set! tabdat (append (dboard:tabdat-keys tabdat) (list "runname"))) - (dboard:tabdat-tot-runs-set! tabdat (rmt:get-num-runs "%")) - ) +(define (dboard:setup-tabdat commondat tabdat) + ;; (dboard:tabdat-dbdir-set! tabdat (db:dbfile-path)) ;; (conc (configf:lookup *configdat* "setup" "linktree") "/.db")) + ;; (dboard:tabdat-dbfpath-set! tabdat (db:dbfile-path)) + ;; (dboard:tabdat-monitor-db-path-set! tabdat (conc (dboard:tabdat-dbdir tabdat) "/monitor.db")) + + (let ((dbstruct (dboard:get-dbstruct commondat #f))) + ;; HACK ALERT: this is a hack, please fix. + (if #f + (dboard:tabdat-ro-set! tabdat (not (file-read-access? (dboard:tabdat-dbfpath tabdat)))) + (print "FIXME on line 350")) + + (dboard:tabdat-keys-set! tabdat (db:get-keys dbstruct)) + (dboard:tabdat-dbkeys-set! tabdat (append (dboard:tabdat-keys tabdat) (list "runname"))) + (dboard:tabdat-tot-runs-set! tabdat (db:get-num-runs dbstruct "%")) + )) ;; RADT => Matrix defstruct addition (defstruct dboard:graph-dat ((id #f) : string) ((color #f) : vector) @@ -377,11 +389,11 @@ (make-dboard:runsdat runs-index: (make-hash-table) tests-index: (make-hash-table) matrix-dat: (make-sparse-array))) -;; used to keep the rundata from rmt:get-tests-for-run +;; used to keep the rundata from db:get-tests-for-run ;; in sync. ;; (defstruct dboard:rundat run tests-drawn ;; list of id's already drawn on screen @@ -537,12 +549,13 @@ ;; ;; gets all the tests for run-id that match testnamepatt and key-vals, merges them ;; ;; NOTE: Yes, this is used ;; -(define (dboard:get-tests-for-run-duplicate tabdat run-id run testnamepatt key-vals) - (let* ((start-time (current-seconds)) +(define (dboard:get-tests-for-run-duplicate commondat tabdat run-id run testnamepatt key-vals) + (let* ((dbstruct (dboard:get-dbstruct commondat #f)) + (start-time (current-seconds)) (access-mode (dboard:tabdat-access-mode tabdat)) (num-to-get (string->number (or (configf:lookup *configdat* "setup" "num-tests-to-get") "200"))) (states (hash-table-keys (dboard:tabdat-state-ignore-hash tabdat))) (statuses (hash-table-keys (dboard:tabdat-status-ignore-hash tabdat))) @@ -567,21 +580,21 @@ (dboard:rundat-last-update run-dat))) (last-db-time (if do-not-use-db-file-timestamps 0 (dboard:rundat-last-db-time run-dat))) (db-path (or (dboard:rundat-db-path run-dat) - (let* ((db-dir (common:get-db-tmp-area)) + (let* ((db-dir (common:get-db-tmp-area dbstruct)) (db-pth (conc db-dir "/megatest.db"))) (dboard:rundat-db-path-set! run-dat db-pth) db-pth))) (db-mod-time (common:lazy-sqlite-db-modification-time db-path)) (db-modified (>= db-mod-time last-db-time)) (multi-get (> (dboard:rundat-run-data-offset run-dat) 0)) ;; multi-get in progress (tmptests (if (or do-not-use-db-file-timestamps (dboard:tabdat-filters-changed tabdat) db-modified) - (rmt:get-tests-for-run run-id testnamepatt states statuses ;; run-id testpatt states statuses + (db:get-tests-for-run dbstruct run-id testnamepatt states statuses ;; run-id testpatt states statuses (dboard:rundat-run-data-offset run-dat) ;; query offset num-to-get (dboard:tabdat-hide-not-hide tabdat) ;; no-in sort-by ;; sort-by sort-order ;; sort-order @@ -649,17 +662,17 @@ ;; this calls dboard:get-tests-for-run-duplicate for each run ;; ;; create a virtual table of all the tests ;; keypatts: ( (KEY1 "abc%def")(KEY2 "%") ) ;; -(define (update-rundat tabdat runnamepatt numruns testnamepatt keypatts) - (let* ((access-mode (dboard:tabdat-access-mode tabdat)) - (keys (rmt:get-keys)) +(define (update-rundat commondat tabdat runnamepatt numruns testnamepatt keypatts) + (let* ((dbstruct (dboard:get-dbstruct commondat #f)) ;; get access to local area + (access-mode (dboard:tabdat-access-mode tabdat)) + (keys (db:get-keys dbstruct)) (last-runs-update (- (dboard:tabdat-last-runs-update tabdat) 2)) - (allruns (rmt:get-runs runnamepatt numruns (dboard:tabdat-start-run-offset tabdat) keypatts)) - ;;(allruns-tree (rmt:get-runs-by-patt (dboard:tabdat-keys tabdat) "%" #f #f #f #f)) - (allruns-tree (rmt:get-runs-by-patt keys "%" #f #f #f #f last-runs-update)) ;;'("id" "runname") + (allruns (db:get-runs dbstruct runnamepatt numruns (dboard:tabdat-start-run-offset tabdat) keypatts)) + (allruns-tree (db:get-runs-by-patt dbstruct keys "%" #f #f #f #f last-runs-update)) ;;'("id" "runname") (header (db:get-header allruns)) (runs (db:get-rows allruns)) ;; RA => Filtered as per runpatt selected (runs-tree (db:get-rows allruns-tree)) ;; RA => Returns complete list of runs (start-time (current-seconds)) (runs-hash (let ((ht (make-hash-table))) @@ -686,12 +699,12 @@ (res '()) (maxtests 0)) (let* ((run-id (db:get-value-by-header run header "id")) (run-struct (hash-table-ref/default (dboard:tabdat-allruns-by-id tabdat) run-id #f)) (last-update (if run-struct (dboard:rundat-last-update run-struct) 0)) - (key-vals (rmt:get-key-vals run-id)) - (tests-ht (dboard:get-tests-for-run-duplicate tabdat run-id run testnamepatt key-vals)) + (key-vals (db:get-key-vals dbstruct run-id)) + (tests-ht (dboard:get-tests-for-run-duplicate commondat tabdat run-id run testnamepatt key-vals)) ;; GET RID OF dboard:get-tests-dat - it is superceded by dboard:get-tests-for-run-duplicate ;; dboard:get-tests-for-run-duplicate - returns a hash table ;; (dboard:get-tests-dat tabdat run-id last-update)) (all-test-ids (hash-table-keys tests-ht)) (num-tests (length all-test-ids))) @@ -728,17 +741,18 @@ ;; this calls dboard:get-tests-for-run-duplicate for each run ;; ;; create a virtual table of all the tests ;; keypatts: ( (KEY1 "abc%def")(KEY2 "%") ) ;; -(define (dboard:update-rundat tabdat runnamepatt numruns testnamepatt keypatts) - (let* ((access-mode (dboard:tabdat-access-mode tabdat)) - (keys (dboard:tabdat-keys tabdat)) ;; (db:dispatch-query access-mode rmt:get-keys db:get-keys))) +(define (dboard:update-rundat commondat tabdat runnamepatt numruns testnamepatt keypatts) + (let* ((dbstruct (dboard:get-dbstruct commondat #f)) + (access-mode (dboard:tabdat-access-mode tabdat)) + (keys (dboard:tabdat-keys tabdat)) (last-runs-update (- (dboard:tabdat-last-runs-update tabdat) 2)) - (allruns (rmt:get-runs runnamepatt numruns (dboard:tabdat-start-run-offset tabdat) keypatts)) - ;;(allruns-tree (rmt:get-runs-by-patt (dboard:tabdat-keys tabdat) "%" #f #f #f #f)) - (allruns-tree (rmt:get-runs-by-patt keys "%" #f #f #f #f 0)) ;; last-runs-update));;'("id" "runname") + (allruns (db:get-runs dbstruct runnamepatt numruns (dboard:tabdat-start-run-offset tabdat) keypatts)) + ;;(allruns-tree (db:get-runs-by-patt dbstruct (dboard:tabdat-keys tabdat) "%" #f #f #f #f)) + (allruns-tree (db:get-runs-by-patt dbstruct keys "%" #f #f #f #f 0)) ;; last-runs-update));;'("id" "runname") (header (db:get-header allruns)) (runs (db:get-rows allruns)) ;; RA => Filtered as per runpatt selected (runs-tree (db:get-rows allruns-tree)) ;; RA => Returns complete list of runs (start-time (current-seconds)) (runs-hash (let ((ht (make-hash-table))) @@ -763,12 +777,12 @@ (res '()) (maxtests 0)) (let* ((run-id (db:get-value-by-header run header "id")) (run-struct (hash-table-ref/default (dboard:tabdat-allruns-by-id tabdat) run-id #f)) ;; (last-update (if run-struct (dboard:rundat-last-update run-struct) 0)) - (key-vals (rmt:get-key-vals run-id)) - (tests-ht (dboard:get-tests-for-run-duplicate tabdat run-id run testnamepatt key-vals)) + (key-vals (db:get-key-vals dbstruct run-id)) + (tests-ht (dboard:get-tests-for-run-duplicate commondat tabdat run-id run testnamepatt key-vals)) ;; GET RID OF dboard:get-tests-dat - it is superceded by dboard:get-tests-for-run-duplicate ;; dboard:get-tests-for-run-duplicate - returns a hash table ;; (dboard:get-tests-dat tabdat run-id last-update)) (all-test-ids (hash-table-keys tests-ht)) (num-tests (length all-test-ids))) @@ -1152,14 +1166,15 @@ (if (not (null? values)) (let ((newval (car values))) (iup:attribute-set! lb "VALUE" newval) newval)))))) -(define (dashboard:update-target-selector tabdat #!key (action-proc #f)) - (let* ((runconf-targs (common:get-runconfig-targets)) +(define (dashboard:update-target-selector commondat tabdat #!key (action-proc #f)) + (let* ((dbstruct (dboard:get-dbstruct commondat #f)) + (runconf-targs (common:get-runconfig-targets)) (key-lbs (dboard:tabdat-key-listboxes tabdat)) - (db-target-dat (rmt:get-targets)) + (db-target-dat (db:get-targets dbstruct)) (header (vector-ref db-target-dat 0)) (db-targets (vector-ref db-target-dat 1)) (munge-target (lambda (x) ;; create a target vector from a string. Pad with na if needed. (list->vector (take (append (string-split x "/") @@ -1310,14 +1325,14 @@ ;;====================================================================== ;; ;; A gui for launching tests ;; -(define (dboard:target-updater tabdat) ;; key-listboxes) +(define (dboard:target-updater commondat tabdat) ;; key-listboxes) (let ((targ (map (lambda (x) (iup:attribute x "VALUE")) - (car (dashboard:update-target-selector tabdat)))) + (car (dashboard:update-target-selector commondat tabdat)))) (curr-runname (dboard:tabdat-run-name tabdat))) (dboard:tabdat-target-set! tabdat targ) ;; (if (dboard:tabdat-updater-for-runs tabdat) ;; ((dboard:tabdat-updater-for-runs tabdat))) (if (or (not (equal? curr-runname (dboard:tabdat-run-name tabdat))) @@ -1325,14 +1340,15 @@ (dboard:tabdat-run-name-set! tabdat curr-runname)) (dashboard:update-run-command tabdat))) ;; used by run-controls ;; -(define (dashboard:update-tree-selector tabdat #!key (action-proc #f)) - (let* ((tb (dboard:tabdat-runs-tree tabdat)) +(define (dashboard:update-tree-selector commondat tabdat #!key (action-proc #f)) + (let* ((dbstruct (dboard:get-dbstruct commondat #f)) + (tb (dboard:tabdat-runs-tree tabdat)) (runconf-targs (common:get-runconfig-targets)) - (db-target-dat (rmt:get-targets)) + (db-target-dat (db:get-targets dbstruct)) (runs-tree-ht (dboard:tabdat-runs-tree-ht tabdat)) (header (vector-ref db-target-dat 0)) (db-targets (vector-ref db-target-dat 1)) (munge-target (lambda (x) ;; create a target vector from a string. Pad with na if needed. (take (append (string-split x "/") @@ -1366,11 +1382,11 @@ (action "-run") (cmdln "") (runlogs (make-hash-table)) ;;; (key-listboxes #f) (update-keyvals (lambda () ;; gets called in dashboard:update-target-selector as "action-proc" - (dboard:target-updater (dboard:tabdat-key-listboxes tabdat)))) + (dboard:target-updater commondat (dboard:tabdat-key-listboxes tabdat)))) (tests-draw-state (make-hash-table)) ;; use for keeping state of the test canvas (test-patterns-textbox #f)) (hash-table-set! tests-draw-state 'first-time #t) ;; (hash-table-set! tests-draw-state 'scalef 1) (tests:get-full-data test-names test-records '() all-tests-registry) @@ -1400,11 +1416,11 @@ (tb (dboard:tabdat-runs-tree tabdat))) (dboard:commondat-add-updater commondat (lambda () (if (dashboard:database-changed? commondat tabdat context-key: 'run-control) - (dashboard:update-tree-selector tabdat))) + (dashboard:update-tree-selector commondat tabdat))) tab-num: tab-num) result))) ;;(iup:frame ;; #:title "Logs" ;; To be replaced with tabs @@ -1499,11 +1515,11 @@ "run-times-tab-layout-updater"))) )))))) "dashboard:run-times-tab-updater"))) (key-listboxes #f) ;; (update-keyvals (lambda () - (dboard:target-updater tabdat)))) + (dboard:target-updater commondat tabdat)))) (dboard:tabdat-drawing-set! tabdat drawing) (dboard:commondat-add-updater commondat run-times-tab-updater tab-num: tab-num) (iup:split #:orientation "VERTICAL" ;; "HORIZONTAL" #:value 150 @@ -1634,36 +1650,10 @@ (define (tree-path->run-id tabdat path) (if (not (null? path)) (hash-table-ref/default (dboard:tabdat-path-run-ids tabdat) path #f) #f)) -;; (define (dboard:get-tests-dat tabdat run-id last-update) -;; (let* ((access-mode (dboard:tabdat-access-mode tabdat)) -;; (tdat (if run-id (db:dispatch-query access-mode rmt:get-tests-for-run db:get-tests-for-run -;; run-id -;; (hash-table-ref/default (dboard:tabdat-searchpatts tabdat) "test-name" "%/%") -;; (hash-table-keys (dboard:tabdat-state-ignore-hash tabdat)) ;; '() -;; (hash-table-keys (dboard:tabdat-status-ignore-hash tabdat)) ;; '() -;; #f #f ;; offset limit -;; (dboard:tabdat-hide-not-hide tabdat) ;; not-in -;; #f #f ;; sort-by sort-order -;; #f ;; get all? "id,testname,item_path,state,status,event_time,run_duration" ;; qryval -;; (if (dboard:tabdat-filters-changed tabdat) -;; 0 -;; last-update) -;; *dashboard-mode*) -;; '()))) ;; get 'em all -;; ;; (debug:print 0 *default-log-port* "dboard:get-tests-dat: got " (length tdat) " test records for run " run-id) -;; (sort tdat (lambda (a b) -;; (let* ((aval (vector-ref a 2)) -;; (bval (vector-ref b 2)) -;; (anum (string->number aval)) -;; (bnum (string->number bval))) -;; (if (and anum bnum) -;; (< anum bnum) -;; (string<= aval bval))))))) - (define (dashboard:safe-cadr-assoc name lst) (let ((res (assoc name lst))) (if (and res (> (length res) 1)) (cadr res) @@ -1677,12 +1667,12 @@ (record-b (hash-table-ref runs-hash b)) (time-a (db:get-value-by-header record-a runs-header "event_time")) (time-b (db:get-value-by-header record-b runs-header "event_time"))) (< time-a time-b))))) (changed #f) - (last-runs-update (dboard:tabdat-last-runs-update tabdat)) - (runs-dat (rmt:get-runs-by-patt (dboard:tabdat-keys tabdat) "%" #f #f #f #f last-runs-update))) + (last-runs-update (dboard:tabdat-last-runs-update tabdat))) + ;; (runs-dat (db:get-runs-by-patt dbstruct (dboard:tabdat-keys tabdat) "%" #f #f #f #f last-runs-update))) (dboard:tabdat-last-runs-update-set! tabdat (- (current-seconds) 2)) (for-each (lambda (run-id) (let* ((run-record (hash-table-ref/default runs-hash run-id #f)) (key-vals (map (lambda (key)(db:get-value-by-header run-record runs-header key)) (dboard:tabdat-keys tabdat))) @@ -1719,15 +1709,16 @@ ((> 0 (string-compare3 a-test-name b-test-name)) #f) ((< 0 (string-compare3 a-item-path b-item-path)) #t) (else #f))))))) -(define (dashboard:run-id->tests-mindat run-id tabdat runs-hash) +(define (dashboard:run-id->tests-mindat commondat run-id tabdat runs-hash) (let* ((run (hash-table-ref/default runs-hash run-id #f)) - (key-vals (rmt:get-key-vals run-id)) + (dbstruct (dboard:get-dbstruct commondat #f)) + (key-vals (db:get-key-vals dbstruct run-id)) (testnamepatt (or (dboard:tabdat-test-patts tabdat) "%/%")) - (tests-ht (dboard:get-tests-for-run-duplicate tabdat run-id run testnamepatt key-vals)) + (tests-ht (dboard:get-tests-for-run-duplicate commondat tabdat run-id run testnamepatt key-vals)) (tests-dat (dashboard:tests-ht->tests-dat tests-ht)) (tests-mindat (dcommon:minimize-test-data tests-dat))) ;; reduces data for display (dboard:tabdat-last-runs-update-set! tabdat (- (current-seconds) 2)) (hash-table-set! (dboard:tabdat-last-test-dat tabdat) run-id tests-dat) (hash-table-set! (dboard:tabdat-run-update-times tabdat) run-id (- (current-seconds) 10)) @@ -1735,25 +1726,27 @@ (debug:print-info 13 *default-log-port* "ERROR: NO RUN FOR RUN-ID run-id="run-id) (debug:print-info 13 *default-log-port* "runs-hash-> " (hash-table->alist runs-hash)) ) tests-mindat)) -(define (dashboard:runs-summary-xor-matrix-content tabdat runs-hash #!key (hide-clean #f)) - (let* ((src-run-id (dboard:tabdat-prev-run-id tabdat)) +(define (dashboard:runs-summary-xor-matrix-content commondat tabdat runs-hash #!key (hide-clean #f)) + (let* (;; (dbstruct (dboard:get-dbstruct commondat #f)) + (src-run-id (dboard:tabdat-prev-run-id tabdat)) (dest-run-id (dboard:tabdat-curr-run-id tabdat))) (if (and src-run-id dest-run-id) (dcommon:xor-tests-mindat - (dashboard:run-id->tests-mindat src-run-id tabdat runs-hash) - (dashboard:run-id->tests-mindat dest-run-id tabdat runs-hash) + (dashboard:run-id->tests-mindat commondat src-run-id tabdat runs-hash) + (dashboard:run-id->tests-mindat commondat dest-run-id tabdat runs-hash) hide-clean: hide-clean) #f))) -(define (dashboard:get-runs-hash tabdat) +(define (dashboard:get-runs-hash commondat tabdat) (let* ((access-mode (dboard:tabdat-access-mode tabdat)) + (dbstruct (dboard:get-dbstruct commondat #f)) (last-runs-update 0);;(dboard:tabdat-last-runs-update tabdat)) - (runs-dat (rmt:get-runs-by-patt (dboard:tabdat-keys tabdat) "%" #f #f #f #f last-runs-update)) + (runs-dat (db:get-runs-by-patt dbstruct (dboard:tabdat-keys tabdat) "%" #f #f #f #f last-runs-update)) (runs-header (vector-ref runs-dat 0)) ;; 0 is header, 1 is list of records (runs (vector-ref runs-dat 1)) (run-id (dboard:tabdat-curr-run-id tabdat)) (runs-hash (let ((ht (make-hash-table))) (for-each (lambda (run) @@ -1762,44 +1755,38 @@ runs-hash)) (define (dashboard:runs-summary-updater commondat tabdat tb cell-lookup run-matrix) ;; (if (dashboard:database-changed? commondat tabdat context-key: 'runs-summary-rundat) - (dashboard:do-update-rundat tabdat) ;; ) - (dboard:runs-summary-control-panel-updater tabdat) - (let* ((last-runs-update (dboard:tabdat-last-runs-update tabdat)) - (runs-dat (rmt:get-runs-by-patt (dboard:tabdat-keys tabdat) "%" #f #f #f #f last-runs-update)) - (runs-header (vector-ref runs-dat 0)) ;; 0 is header, 1 is list of records - (runs (vector-ref runs-dat 1)) - (run-id (dboard:tabdat-curr-run-id tabdat)) - (runs-hash (dashboard:get-runs-hash tabdat)) - ;; (runs-hash (let ((ht (make-hash-table))) - ;; (for-each (lambda (run) - ;; (hash-table-set! ht (db:get-value-by-header run runs-header "id") run)) - ;; runs) - ;; ht)) - ) + (dashboard:do-update-rundat commondat tabdat) ;; ) + (dboard:runs-summary-control-panel-updater commondat tabdat) + (let* ((dbstruct (dboard:get-dbstruct commondat #f)) + (last-runs-update (dboard:tabdat-last-runs-update tabdat)) + (runs-dat (db:get-runs-by-patt dbstruct (dboard:tabdat-keys tabdat) "%" #f #f #f #f last-runs-update)) + (runs-header (vector-ref runs-dat 0)) ;; 0 is header, 1 is list of records + (runs (vector-ref runs-dat 1)) + (run-id (dboard:tabdat-curr-run-id tabdat)) + (runs-hash (dashboard:get-runs-hash commondat tabdat))) (if (dashboard:database-changed? commondat tabdat context-key: 'runs-summary-tree) (dboard:update-tree tabdat runs-hash runs-header tb)) (if run-id (let* ((matrix-content (case (dboard:tabdat-runs-summary-mode tabdat) - ((one-run) (dashboard:run-id->tests-mindat run-id tabdat runs-hash)) - ((xor-two-runs) (dashboard:runs-summary-xor-matrix-content tabdat runs-hash)) - ((xor-two-runs-hide-clean) (dashboard:runs-summary-xor-matrix-content tabdat runs-hash hide-clean: #t)) - (else (dashboard:run-id->tests-mindat run-id tabdat runs-hash))))) + ((one-run) (dashboard:run-id->tests-mindat commondat run-id tabdat runs-hash)) + ((xor-two-runs) (dashboard:runs-summary-xor-matrix-content commondat tabdat runs-hash)) + ((xor-two-runs-hide-clean) (dashboard:runs-summary-xor-matrix-content commondat tabdat runs-hash hide-clean: #t)) + (else (dashboard:run-id->tests-mindat commondat run-id tabdat runs-hash))))) (when matrix-content (let* ((indices (common:sparse-list-generate-index matrix-content)) ;; proc: set-cell)) (row-indices (cadr indices)) (col-indices (car indices)) (max-row (if (null? row-indices) 1 (common:max (map cadr row-indices)))) (max-col (if (null? col-indices) 1 (common:max (map cadr col-indices)))) (max-visible (max (- (dboard:tabdat-num-tests tabdat) 15) 3)) ;; (dboard:tabdat-num-tests tabdat) is proportional to the size of the window (numrows 1) (numcols 1) - (changed #f) - ) + (changed #f)) (dboard:tabdat-filters-changed-set! tabdat #f) (let loop ((pass-num 0) (changed #f)) ;; Update the runs tree @@ -1873,18 +1860,22 @@ (loop 1 #t)) ;; force second pass due to column labels changing ;; (debug:print 0 *default-log-port* "runs-summary-updater, changed: " changed " pass-num: " pass-num) ;; (print "runs-summary-updater, changed: " changed " pass-num: " pass-num) (if changed (iup:attribute-set! run-matrix "REDRAW" "ALL"))))))))) + ;;====================================================================== ;; S U M M A R Y ;;====================================================================== ;; ;; General info about the run(s) and megatest area (define (dashboard:summary commondat tabdat #!key (tab-num #f)) - (let* ((rawconfig (read-config (conc *toppath* "/megatest.config") #f #f)) ;; changed to #f since I want #{} to be expanded by [system ...] to NOT be expanded. WAS: 'return-string))) + (let* ((dbstruct (dboard:get-dbstruct commondat #f)) + (configdat (dbr:dbstruct-configdat dbstruct)) + (rawconfig configdat) + ;; (rawconfig (read-config (conc *toppath* "/megatest.config") #f #f)) ;; changed to #f since I want #{} to be expanded by [system ...] to NOT be expanded. WAS: 'return-string))) (changed #f)) (iup:vbox (iup:split #:value 300 (iup:frame @@ -1988,39 +1979,40 @@ (if (eq? this-mode current-mode) (iup:attribute-set! this-button "BGCOLOR" sel-color) (iup:attribute-set! this-button "BGCOLOR" nonsel-color)) (loop (cdr buttons-left) (cdr modes-left)))))) -(define (dboard:runs-summary-xor-labels-updater tabdat) +(define (dboard:runs-summary-xor-labels-updater commondat tabdat) (let ((source-runname-label (dboard:tabdat-runs-summary-source-runname-label tabdat)) - (dest-runname-label (dboard:tabdat-runs-summary-dest-runname-label tabdat)) - (mode (dboard:tabdat-runs-summary-mode tabdat))) + (dest-runname-label (dboard:tabdat-runs-summary-dest-runname-label tabdat)) + (mode (dboard:tabdat-runs-summary-mode tabdat)) + (dbstruct (dboard:get-dbstruct commondat #f))) (when (and source-runname-label dest-runname-label) (case mode ((xor-two-runs xor-two-runs-hide-clean) (let* ((curr-run-id (dboard:tabdat-curr-run-id tabdat)) (prev-run-id (dboard:tabdat-prev-run-id tabdat)) (curr-runname (if curr-run-id - (rmt:get-run-name-from-id curr-run-id) + (db:get-run-name-from-id dbstruct curr-run-id) "None")) (prev-runname (if prev-run-id - (rmt:get-run-name-from-id prev-run-id) + (db:get-run-name-from-id dbstruct prev-run-id) "None"))) (iup:attribute-set! source-runname-label "TITLE" (conc " SRC: "prev-runname" ")) (iup:attribute-set! dest-runname-label "TITLE" (conc "DEST: "curr-runname" ")))) (else (iup:attribute-set! source-runname-label "TITLE" "") (iup:attribute-set! dest-runname-label "TITLE" "")))))) -(define (dboard:runs-summary-control-panel-updater tabdat) - (dboard:runs-summary-xor-labels-updater tabdat) +(define (dboard:runs-summary-control-panel-updater commondat tabdat) + (dboard:runs-summary-xor-labels-updater commondat tabdat) (dboard:runs-summary-buttons-updater tabdat)) ;; setup buttons and callbacks to switch between modes in runs summary tab ;; -(define (dashboard:runs-summary-control-panel tabdat) +(define (dashboard:runs-summary-control-panel commondat tabdat) (let* ((summary-buttons ;; build buttons (map (lambda (mode-item) (let* ((this-mode (car mode-item)) (this-mode-label (cdr mode-item))) @@ -2028,11 +2020,11 @@ #:action (lambda (obj) (debug:catch-and-dump (lambda () (dboard:tabdat-runs-summary-mode-set! tabdat this-mode) - (dboard:runs-summary-control-panel-updater tabdat)) + (dboard:runs-summary-control-panel-updater commondattabdat)) "runs summary control panel updater"))))) (dboard:tabdat-runs-summary-modes tabdat))) (summary-buttons-hbox (apply iup:hbox summary-buttons)) (xor-runname-labels-hbox (iup:hbox @@ -2047,15 +2039,13 @@ temp-label)))) (dboard:tabdat-runs-summary-mode-buttons-set! tabdat summary-buttons) ;; maybe wrap in a frame (let ((res (iup:vbox summary-buttons-hbox xor-runname-labels-hbox ))) - (dboard:runs-summary-control-panel-updater tabdat) + (dboard:runs-summary-control-panel-updater commondat tabdat) res ))) - - ;;====================================================================== ;; R U N ;;====================================================================== ;; @@ -2062,11 +2052,12 @@ ;; display and manage a single run at a time ;; This is the Run Summary tab ;; (define (dashboard:runs-summary commondat tabdat #!key (tab-num #f)) - (let* ((update-mutex (dboard:commondat-update-mutex commondat)) + (let* ((dbstruct (dboard:get-dbstruct commondat #f)) + (update-mutex (dboard:commondat-update-mutex commondat)) (tb (iup:treebox #:value 0 #:name "Runs" #:expand "YES" #:addexpanded "YES" @@ -2109,24 +2100,24 @@ ;; status is corrupted on Brandon's home machine. will have to wait until after shutdown to see if it is still broken in PDX SLES (let* ((toolpath (car (argv))) (key (conc lin ":" col)) (test-id (hash-table-ref/default cell-lookup key -1)) (run-id (dboard:tabdat-curr-run-id tabdat)) - (run-info (rmt:get-run-info run-id)) - (target (rmt:get-target run-id)) + (run-info (db:get-run-info dbstruct run-id)) + (target (db:get-target dbstruct run-id)) (runname (db:get-value-by-header (db:get-rows run-info) (db:get-header run-info) "runname")) - (test-info (rmt:get-test-info-by-id run-id test-id)) + (test-info (db:get-test-info-by-id dbstruct run-id test-id)) (test-name (db:test-get-testname test-info)) - (testpatt (let ((tlast (rmt:tasks-get-last target runname))) + (testpatt (let ((tlast (db:tasks-get-last dbstruct target runname))) (if tlast - (let ((tpatt (tasks:task-get-testpatt tlast))) + (let ((tpatt (tasks:task-get-testpatt tlast))) ;; tasks:task-get-testpatt is an accessor defined in task_records.scm (if (member tpatt '("0" 0)) ;; known bad historical value - remove in 2017 "%" tpatt)) "%"))) - (item-path (db:test-get-item-path (rmt:get-test-info-by-id run-id test-id))) + (item-path (db:test-get-item-path (db:get-test-info-by-id dbstruct run-id test-id))) (item-test-path (conc test-name "/" (if (equal? item-path "") "%" item-path))) (status-chars (char-set->list (string->char-set status))) (testpanel-cmd (conc toolpath " -test " (dboard:tabdat-curr-run-id tabdat) "," test-id " &"))) @@ -2163,20 +2154,22 @@ (if run-matrix (dashboard:runs-summary-updater commondat tabdat tb cell-lookup run-matrix))) "dashboard:runs-summary-updater") ) (mutex-unlock! update-mutex))) - (runs-summary-control-panel (dashboard:runs-summary-control-panel tabdat)) + (runs-summary-control-panel (dashboard:runs-summary-control-panel commondat tabdat)) ) (dboard:commondat-add-updater commondat runs-summary-updater tab-num: tab-num) (dboard:tabdat-runs-tree-set! tabdat tb) (iup:vbox (iup:split #:value 200 tb run-matrix) (dboard:make-controls commondat tabdat extra-widget: runs-summary-control-panel)))) + +(include "dashboard-areas.scm") ;;====================================================================== ;; R U N S ;;====================================================================== @@ -2334,25 +2327,38 @@ (hash-table-delete! (dboard:tabdat-state-ignore-hash tabdat) state)) (set-bg-on-filter commondat tabdat)))) (map cadr *common:std-states*))) ;; '("RUNNING" "COMPLETED" "INCOMPLETE" "LAUNCHED" "NOT_STARTED" "KILLED" "DELETED"))) (num-toggle-cols (inexact->exact (round (/ (max (length status-toggles)(length state-toggles)) 3))))) (iup:vbox - (iup:hbox - (iup:frame - #:title "states" - (apply - iup:hbox - (map (lambda (colgrp) - (apply iup:vbox colgrp)) - (dboard:squarify state-toggles 3)))) - (iup:frame - #:title "statuses" - (apply - iup:hbox - (map (lambda (colgrp) - (apply iup:vbox colgrp)) - (dboard:squarify status-toggles 3))))) + + (let ((filter-pivot (iup:tabs + (iup:hbox + (iup:frame + #:title "states" + (apply + iup:hbox + (map (lambda (colgrp) + (apply iup:vbox colgrp)) + (dboard:squarify state-toggles 3)))) + (iup:frame + #:title "statuses" + (apply + iup:hbox + (map (lambda (colgrp) + (apply iup:vbox colgrp)) + (dboard:squarify status-toggles 3))))) + (iup:hbox + (iup:frame + #:title "Rows" + (iup:button "Rows pivot")) + (iup:frame + #:title "Cols" + (iup:button "Cols pivot")))))) + (iup:attribute-set! filter-pivot "TABTITLE0" "Filters") + (iup:attribute-set! filter-pivot "TABTITLE1" "Pivots ") + filter-pivot) + ;; ;; (iup:frame ;; #:title "state/status filter" ;; (iup:vbox ;; (apply @@ -2441,11 +2447,10 @@ (iup:menu-item (conc "Kill " item-test-path) #:action (lambda (obj) - ;; (rmt:test-set-state-status-by-id run-id test-id "KILLREQ" #f #f) (common:run-a-command (conc "megatest -set-state-status KILLREQ,n/a -target " target " -runname " runname " -testpatt " item-test-path " -state RUNNING,REMOTEHOSTSTART,LAUNCHED,NOT_STARTED")))) @@ -2514,11 +2519,10 @@ " -preclean -clean-cache")))) (iup:menu-item (conc "Kill " item-test-path) #:action (lambda (obj) - ;; (rmt:test-set-state-status-by-id run-id test-id "KILLREQ" #f #f) (common:run-a-command (conc "megatest -set-state-status KILLREQ,n/a -target " target " -runname " runname " -testpatt " item-test-path " -state RUNNING,REMOTEHOSTSTART,LAUNCHED")))) @@ -2563,15 +2567,17 @@ " " tconfig " &"))) (system cmd)))) )))) (define (make-dashboard-buttons commondat) ;; runs-sum-dat new-view-dat) - (let* ((stats-dat (dboard:tabdat-make-data)) - (runs-dat (dboard:tabdat-make-data)) - (onerun-dat (dboard:tabdat-make-data)) ;; name for run-summary structure - (runcontrols-dat (dboard:tabdat-make-data)) - (runtimes-dat (dboard:tabdat-make-data)) + (let* ((dbstruct (dboard:get-dbstruct commondat #f)) + (stats-dat (dboard:tabdat-make-data commondat)) + (runs-dat (dboard:tabdat-make-data commondat)) + (onerun-dat (dboard:tabdat-make-data commondat)) ;; name for run-summary structure + (runcontrols-dat (dboard:tabdat-make-data commondat)) + (runtimes-dat (dboard:tabdat-make-data commondat)) + (areas-dat (dboard:tabdat-make-data commondat)) (nruns (dboard:tabdat-numruns runs-dat)) (ntests (dboard:tabdat-num-tests runs-dat)) (keynames (dboard:tabdat-dbkeys runs-dat)) (nkeys (length keynames)) (runsvec (make-vector nruns)) @@ -2612,11 +2618,11 @@ (cond ((>= testnum ntests) ;; now lftlst will be an hbox with the test keys and the test name labels (set! lftlst (append lftlst (list (iup:hbox #:expand "HORIZONTAL" (iup:valuator #:valuechanged_cb (lambda (obj) - (let ((val (string->number (iup:attribute obj "VALUE"))) + 668 (let ((val (string->number (iup:attribute obj "VALUE"))) (oldmax (string->number (iup:attribute obj "MAX"))) (newmax (* 10 (length (dboard:tabdat-all-test-names runs-dat))))) (dboard:commondat-please-update-set! commondat #t) (dboard:tabdat-start-test-offset-set! runs-dat (inexact->exact (round (/ val 10)))) (debug:print 6 *default-log-port* "(dboard:tabdat-start-test-offset runs-dat) " (dboard:tabdat-start-test-offset runs-dat) " val: " val " newmax: " newmax " oldmax: " oldmax) @@ -2682,24 +2688,24 @@ (if (eq? pressed 1) (let* ((toolpath (car (argv))) (buttndat (hash-table-ref (dboard:tabdat-buttondat runs-dat) button-key)) (test-id (db:test-get-id (vector-ref buttndat 3))) (run-id (db:test-get-run_id (vector-ref buttndat 3))) - (run-info (rmt:get-run-info run-id)) - (target (rmt:get-target run-id)) + (run-info (db:get-run-info dbstruct run-id)) + (target (db:get-target dbstruct run-id)) (runname (db:get-value-by-header (db:get-rows run-info) (db:get-header run-info) "runname")) - (test-info (rmt:get-test-info-by-id run-id test-id)) + (test-info (db:get-test-info-by-id dbstruct run-id test-id)) (test-name (db:test-get-testname test-info)) - (testpatt (let ((tlast (rmt:tasks-get-last target runname))) + (testpatt (let ((tlast (db:tasks-get-last dbstruct target runname))) (if tlast (let ((tpatt (tasks:task-get-testpatt tlast))) (if (member tpatt '("0" 0)) ;; known bad historical value - remove in 2017 "%" tpatt)) "%"))) - (item-path (db:test-get-item-path (rmt:get-test-info-by-id run-id test-id))) + (item-path (db:test-get-item-path (db:get-test-info-by-id dbstruct run-id test-id))) (item-test-path (conc test-name "/" (if (equal? item-path "") "%" item-path)))) (iup:show (dashboard:popup-menu run-id test-id target runname test-name testpatt item-test-path test-info) ;; popup-menu #:x 'mouse @@ -2741,11 +2747,11 @@ (dashboard:runs-horizontal-slider runs-dat)))) controls )) (views-cfgdat (common:load-views-config)) (additional-tabnames '()) - (tab-start-num 5) ;; DON'T FORGET TO UPDATE THIS WHEN CHANGING THE STANDARD TABS BELOW + (tab-start-num 6) ;; DON'T FORGET TO UPDATE THIS WHEN CHANGING THE STANDARD TABS BELOW ;; (data (dboard:tabdat-init (make-d:data))) (additional-views ;; process views-dat (let ((tab-num tab-start-num) (result '())) (for-each @@ -2786,17 +2792,19 @@ (dashboard:runs-summary commondat onerun-dat tab-num: 2) ;; (dashboard:new-view db data new-view-dat tab-num: 3) (dashboard:run-controls commondat runcontrols-dat tab-num: 3) (dashboard:run-times commondat runtimes-dat tab-num: 4) ;; (dashboard:runs-summary commondat onerun-dat tab-num: 4) + (dashboard:areas-summary commondat areas-dat tab-num: 5) additional-views))) ;; (set! (iup:callback tabs tabchange-cb:) (lambda (a b c)(print "SWITCHED TO TAB: " a " " b " " c))) (iup:attribute-set! tabs "TABTITLE0" "Summary") (iup:attribute-set! tabs "TABTITLE1" "Runs") (iup:attribute-set! tabs "TABTITLE2" "Run Summary") (iup:attribute-set! tabs "TABTITLE3" "Run Control") (iup:attribute-set! tabs "TABTITLE4" "Run Times") + (iup:attribute-set! tabs "TABTITLE5" "Areas Summary") ;; (iup:attribute-set! tabs "TABTITLE3" "New View") ;; (iup:attribute-set! tabs "TABTITLE4" "Run Control") ;; set the tab names for user added tabs (for-each @@ -2811,10 +2819,11 @@ (dboard:common-set-tabdat! commondat 0 stats-dat) (dboard:common-set-tabdat! commondat 1 runs-dat) (dboard:common-set-tabdat! commondat 2 onerun-dat) (dboard:common-set-tabdat! commondat 3 runcontrols-dat) (dboard:common-set-tabdat! commondat 4 runtimes-dat) + (dboard:common-set-tabdat! commondat 5 areas-dat) (iup:vbox tabs ;; controls )))) @@ -2984,29 +2993,30 @@ ;; run times tab data updater ;; (define (dashboard:run-times-tab-run-data-updater commondat tabdat tab-num) (let* ((access-mode (dboard:tabdat-access-mode tabdat)) + (dbstruct (dboard:get-dbstruct commondat #f)) (last-runs-update (dboard:tabdat-last-runs-update tabdat)) - (runs-dat (rmt:get-runs-by-patt (dboard:tabdat-keys tabdat) "%" #f #f #f #f last-runs-update)) - (runs-header (vector-ref runs-dat 0)) ;; 0 is header, 1 is list of records - (runs-hash (let ((ht (make-hash-table))) - (for-each (lambda (run) - (hash-table-set! ht (db:get-value-by-header run runs-header "id") run)) - (vector-ref runs-dat 1)) - ht)) - (run-ids (sort (filter number? (hash-table-keys runs-hash)) - (lambda (a b) - (let* ((record-a (hash-table-ref runs-hash a)) - (record-b (hash-table-ref runs-hash b)) - (time-a (db:get-value-by-header record-a runs-header "event_time")) - (time-b (db:get-value-by-header record-b runs-header "event_time"))) - (< time-a time-b))))) - (tb (dboard:tabdat-runs-tree tabdat)) - (num-runs (length (hash-table-keys runs-hash))) + (runs-dat (db:get-runs-by-patt dbstruct (dboard:tabdat-keys tabdat) "%" #f #f #f #f last-runs-update)) + (runs-header (vector-ref runs-dat 0)) ;; 0 is header, 1 is list of records + (runs-hash (let ((ht (make-hash-table))) + (for-each (lambda (run) + (hash-table-set! ht (db:get-value-by-header run runs-header "id") run)) + (vector-ref runs-dat 1)) + ht)) + (run-ids (sort (filter number? (hash-table-keys runs-hash)) + (lambda (a b) + (let* ((record-a (hash-table-ref runs-hash a)) + (record-b (hash-table-ref runs-hash b)) + (time-a (db:get-value-by-header record-a runs-header "event_time")) + (time-b (db:get-value-by-header record-b runs-header "event_time"))) + (< time-a time-b))))) + (tb (dboard:tabdat-runs-tree tabdat)) + (num-runs (length (hash-table-keys runs-hash))) (update-start-time (current-seconds)) - (inc-mode #f)) + (inc-mode #f)) (dboard:tabdat-last-runs-update-set! tabdat (- (current-seconds) 2)) ;; fill in the tree (if (and tb (not inc-mode)) (for-each @@ -3057,11 +3067,12 @@ (vg:drawing-cache-set! dwg '()) (dboard:tabdat-allruns-by-id-set! tabdat (make-hash-table)) ;; (dboard:tabdat-allruns-set! tabdat '()) (dboard:tabdat-max-row-set! tabdat 0) (dboard:tabdat-last-filter-str-set! tabdat filtrstr))) - (update-rundat tabdat + (update-rundat commondat + tabdat runpatt ;; (hash-table-ref/default (dboard:tabdat-searchpatts tabdat) "runname" "%") (dboard:tabdat-numruns tabdat) testpatt ;; (hash-table-ref/default (dboard:tabdat-searchpatts tabdat) "test-name" "%/%") ;; (hash-table-ref/default (dboard:tabdat-searchpatts tabdat) "item-name" "%") @@ -3526,12 +3537,13 @@ ;; ;; (define (tabdat-values tabdat) ;; runs update-rundat using the various filters from the gui ;; -(define (dashboard:do-update-rundat tabdat) +(define (dashboard:do-update-rundat commondat tabdat) (dboard:update-rundat + commondat tabdat (hash-table-ref/default (dboard:tabdat-searchpatts tabdat) "runname" "%") (dboard:tabdat-numruns tabdat) (hash-table-ref/default (dboard:tabdat-searchpatts tabdat) "test-name" "%/%") ;; generate key patterns from the target stored in tabdat @@ -3555,11 +3567,11 @@ (dbkeys (dboard:tabdat-dbkeys tabdat))) ;;(print "RA => calling runs-tab-updater with commondat " commondat " tab-num " tab-num) ;;(tabdat-values tabdat) ;;RA added ;; (pp (dboard:tabdat->alist tabdat)) ;; (if (dashboard:database-changed? commondat tabdat context-key: 'runs-rundat) - (dashboard:do-update-rundat tabdat) + (dashboard:do-update-rundat commondat tabdat) ;;(debug:print-info 13 *default-log-port* "dashboard:runs-tab-updater") ;;(inspect tabdat) (let ((uidat (dboard:commondat-uidat commondat))) ;;(print "RA => Calling update-buttons with tabdat : " tabdat " uidat " uidat) @@ -3570,67 +3582,67 @@ ;;====================================================================== ;; The heavy lifting starts here ;;====================================================================== (define (main) - (let ((mtdb-path (conc *toppath* "/megatest.db"))) ;; - (if (and (common:file-exists? mtdb-path) - (file-write-access? mtdb-path)) - (if (not (args:get-arg "-skip-version-check")) - (common:exit-on-version-changed))) - (let* ((commondat (dboard:commondat-make))) - ;; Move this stuff to db.scm? I'm not sure that is the right thing to do... - (cond - ((args:get-arg "-test") ;; run-id,test-id + ;; (let* ((areas (make-hash-table))) ;; mtdb-path (conc *toppath* "/megatest.db"))) ;; + ;; (if (and (common:file-exists? mtdb-path) + ;; (file-write-access? mtdb-path)) + ;; (if (not (args:get-arg "-skip-version-check")) + ;; (common:exit-on-version-changed))) + (let* ((commondat (make-dboard:commondat))) + ;; Move this stuff to db.scm? I'm not sure that is the right thing to do... + (cond + ((args:get-arg "-test") ;; run-id,test-id (let* ((dat (let ((d (map string->number (string-split (args:get-arg "-test") ",")))) - (if (> (length d) 1) - d - (list #f #f)))) - (run-id (car dat)) - (test-id (cadr dat))) - (if (and (number? run-id) - (number? test-id) + (if (> (length d) 1) + d + (list #f #f)))) + (run-id (car dat)) + (test-id (cadr dat))) + (if (and (number? run-id) + (number? test-id) (>= test-id 0)) - (dashboard-tests:examine-test run-id test-id) - (begin - (debug:print 3 *default-log-port* "INFO: tried to open test with invalid run-id,test-id. " (args:get-arg "-test")) - (exit 1))))) - ;; ((args:get-arg "-guimonitor") - ;; (gui-monitor (dboard:tabdat-dblocal tabdat))) - (else - (dboard:commondat-uidat-set! commondat (make-dashboard-buttons commondat)) - (dboard:commondat-curr-tab-num-set! commondat 0) - (dboard:commondat-add-updater - commondat - (lambda () - (dashboard:runs-tab-updater commondat 1)) - tab-num: 1) - (iup:callback-set! *tim* - "ACTION_CB" - (lambda (time-obj) - (let ((update-is-running #f)) - (mutex-lock! (dboard:commondat-update-mutex commondat)) - (set! update-is-running (dboard:commondat-updating commondat)) - (if (not update-is-running) - (dboard:commondat-updating-set! commondat #t)) - (mutex-unlock! (dboard:commondat-update-mutex commondat)) - (if (not update-is-running) ;; we know that the update was not running and we now have a lock on doing an update - (begin - (dboard:common-run-curr-updaters commondat) ;; (dashboard:run-update commondat) - (mutex-lock! (dboard:commondat-update-mutex commondat)) - (dboard:commondat-updating-set! commondat #f) - (mutex-unlock! (dboard:commondat-update-mutex commondat))) - )) - 1)))) - - (let ((th1 (make-thread (lambda () - (thread-sleep! 1) - (dboard:common-run-curr-updaters commondat 0) ;; force update of summary tab - ) "update buttons once")) - (th2 (make-thread iup:main-loop "Main loop"))) - (thread-start! th2) - (thread-join! th2))))) + (dashboard-tests:examine-test run-id test-id) + (begin + (debug:print 3 *default-log-port* "INFO: tried to open test with invalid run-id,test-id. " (args:get-arg "-test")) + (exit 1))))) + ;; ((args:get-arg "-guimonitor") + ;; (gui-monitor (dboard:tabdat-dblocal tabdat))) + (else + (dboard:commondat-uidat-set! commondat (make-dashboard-buttons commondat)) + (dboard:commondat-curr-tab-num-set! commondat 0) + (dboard:commondat-add-updater + commondat + (lambda () + (dashboard:runs-tab-updater commondat 1)) + tab-num: 1) + (iup:callback-set! *tim* + "ACTION_CB" + (lambda (time-obj) + (let ((update-is-running #f)) + (mutex-lock! (dboard:commondat-update-mutex commondat)) + (set! update-is-running (dboard:commondat-updating commondat)) + (if (not update-is-running) + (dboard:commondat-updating-set! commondat #t)) + (mutex-unlock! (dboard:commondat-update-mutex commondat)) + (if (not update-is-running) ;; we know that the update was not running and we now have a lock on doing an update + (begin + (dboard:common-run-curr-updaters commondat) ;; (dashboard:run-update commondat) + (mutex-lock! (dboard:commondat-update-mutex commondat)) + (dboard:commondat-updating-set! commondat #f) + (mutex-unlock! (dboard:commondat-update-mutex commondat))) + )) + 1)))) + + (let ((th1 (make-thread (lambda () + (thread-sleep! 1) + (dboard:common-run-curr-updaters commondat 0) ;; force update of summary tab + ) "update buttons once")) + (th2 (make-thread iup:main-loop "Main loop"))) + (thread-start! th2) + (thread-join! th2)))) ;; ease debugging by loading ~/.dashboardrc (let ((debugcontrolf (conc (get-environment-variable "HOME") "/.dashboardrc"))) (if (common:file-exists? debugcontrolf) (load debugcontrolf))) Index: db.scm ================================================================== --- db.scm +++ db.scm @@ -49,10 +49,15 @@ (mtdb #f) (refndb #f) (homehost #f) ;; not used yet (on-homehost #f) ;; not used yet (read-only #f) + (configdat #f) + (keys #f) + (area-path #f) + (area-name #f) + (tmpdb-path #f) ) ;; goal is to converge on one struct for an area but for now it is too confusing ;; record for keeping state,status and count for doing roll-ups in ;; iterated tests @@ -59,10 +64,65 @@ ;; (defstruct dbr:counts (state #f) (status #f) (count 0)) + +;;====================================================================== +;; DASHBOARD DIRECT INTERFACE +;;====================================================================== + +;; return dbstruct with: +;; read-only - flag +;; tmpdb - local to this machine, all reads to this +;; mtdb - full db from mtrah +;; no-sync-db - +;; on-homehost - enable reading from other users /tmp db if files are readable +;; +;; areas is hash of area_names => dbstruct, the dashboard-open-db will register the dbstruct in that hash +;; +;; NOTE: This returns the tmpdb path/handle pair. +;; NOTE: This does do a sync (the db:open-db proc only does an initial sync if called with do-sync: #t +;; NOTE: Longer term consider replacing db:open-db with this +;; +;; NOTE: loose ends!! +;; db:open-db -> not properly using tmpdb path +;; common:get-db-tmp-area -> using *toppath* and common:get-testsuite-area +;; +(define (db:dashboard-open-dbstruct areas area-name area-path) + ;; 0. check for already existing dbstruct in areas hash, return it if found + ;; 1. do minimal read of megatest.config, store configdat, keys in dbstruct + ;; 2. get homehost + ;; 3. create /tmp db area (if needed) + ;; 4. sync data to /tmp db (or update if exists) + ;; 5. return dbstruct + (if (hash-table-exists? areas area-name) + (hash-table-ref areas area-name) + (if (common:file-exists? (conc area-path "/megatest.config") quiet-mode: #t) + (let* ((homehost (common:minimal-get-homehost area-path)) + (on-hh (common:on-host? homehost)) + (mtconfig (common:simple-setup area-path)) ;; returns ( configdat toppath configfile configf-name ) + (dbstruct (make-dbr:dbstruct + area-path: area-path + homehost: homehost + configdat: (car mtconfig))) + (tmpdb (db:open-db dbstruct area-path: area-path do-sync: #t))) + (hash-table-set! areas area-name dbstruct) + tmpdb) + (begin + (debug:print-info 0 *default-log-port* "attempt to open megatest.db in " area-path " but no megatest.config found.") + #f)))) + +;; sync all the areas listed in area-paths +;; +(define (db:dashboard-sync-dbs areas area-paths) + #f) + +;; close all area db's +;; +(define (db:dashboard-close-dbs areas) + #f) ;;====================================================================== ;; SQLITE3 HELPERS ;;====================================================================== @@ -87,20 +147,17 @@ (print-call-chain (current-error-port)) default))) (apply sqlite3:first-result db stmt params))) ;; Get/open a database -;; if run-id => get run specific db -;; if #f => get main db -;; if db already open - return inmem -;; if db not open, open inmem, rundb and sync then return inmem -;; inuse gets set automatically for rundb's +;; +;; should always return ( dbh . path-to-db ) ;; (define (db:get-db dbstruct) ;; run-id) (if (stack? (dbr:dbstruct-dbstack dbstruct)) (if (stack-empty? (dbr:dbstruct-dbstack dbstruct)) - (let ((newdb (db:open-megatest-db path: (db:dbfile-path)))) + (let ((newdb (db:open-megatest-db path: (dbr:dbstruct-area-path dbstruct)))) ;; (db:dbfile-path)))) ;; (stack-push! (dbr:dbstruct-dbstack dbstruct) newdb) newdb) (stack-pop! (dbr:dbstruct-dbstack dbstruct))) (db:open-db dbstruct))) @@ -299,22 +356,26 @@ ;; ;;; (mutex-unlock! *rundb-mutex*) ;;; why did we need a mutex on opening db's? ;; (db:sync-tables db:sync-tests-only *megatest-db* db) ;; db)) ;; This routine creates the db if not already present. It is only called if the db is not already opened -;; -(define (db:open-db dbstruct #!key (areapath #f)(do-sync #t)) ;; TODO: actually use areapath +;; ALWAYS returns ( dbh . path-to-db ) +(define (db:open-db dbstruct #!key (area-path #f)(do-sync #t)) ;; TODO: actually use areapath (let ((tmpdb-stack (dbr:dbstruct-dbstack dbstruct))) ;; RA => Returns the first reference in dbstruct (if (stack? tmpdb-stack) (db:get-db tmpdb-stack) ;; get previously opened db (will create new db handle if all in the stack are already used - (let* ((dbpath (db:dbfile-path )) ;; path to tmp db area + (let* ((toppath (or area-path + (dbr:dbstruct-area-path dbstruct) + *toppath*)) + (dbpath (or (dbr:dbstruct-tmpdb-path dbstruct) + (db:dbfile-path dbstruct))) ;; path to tmp db area (dbexists (common:file-exists? dbpath)) (tmpdbfname (conc dbpath "/megatest.db")) (dbfexists (common:file-exists? tmpdbfname)) ;; (conc dbpath "/megatest.db"))) - (mtdbexists (common:file-exists? (conc *toppath* "/megatest.db"))) + (mtdbexists (common:file-exists? (conc toppath "/megatest.db"))) - (mtdb (db:open-megatest-db)) + (mtdb (db:open-megatest-db path: area-path)) (mtdbpath (db:dbdat-get-path mtdb)) (tmpdb (db:open-megatest-db path: dbpath)) ;; lock-create-open dbpath db:initialize-main-db)) (refndb (db:open-megatest-db path: dbpath name: "megatest_ref.db")) (write-access (file-write-access? mtdbpath)) (mtdbmodtime (if mtdbexists (common:lazy-sqlite-db-modification-time mtdbpath) #f)) @@ -1868,11 +1929,11 @@ ;;====================================================================== ;; no-sync.db - small bits of data to be shared between servers ;;====================================================================== (define (db:open-no-sync-db) - (let* ((dbpath (db:dbfile-path)) + (let* ((dbpath (db:dbfile-path #f)) (dbname (conc dbpath "/no-sync.db")) (db-exists (common:file-exists? dbname)) (db (sqlite3:open-database dbname))) (sqlite3:set-busy-handler! db (make-busy-timeout 136000)) (if (not db-exists) @@ -1948,20 +2009,21 @@ ;; why get the keys from the db? why not get from the *configdat* ;; using keys:config-get-fields? (define (db:get-keys dbstruct) - (if *db-keys* *db-keys* + (if (dbr:dbstruct-keys dbstruct) + (dbr:dbstruct-keys dbstruct) (let ((res '())) (db:with-db dbstruct #f #f (lambda (db) (sqlite3:for-each-row (lambda (key) (set! res (cons key res))) db "SELECT fieldname FROM keys ORDER BY id DESC;"))) - (set! *db-keys* res) + (dbr:dbstruct-keys-set! dbstruct res) res))) ;; look up values in a header/data structure (define (db:get-value-by-header row header field) (if (or (null? header) (not row)) @@ -2141,11 +2203,11 @@ (vector header res))) ;; TODO: Switch this to use max(update_time) from each run db? Then if using a server there is no disk traffic (using inmem db) ;; (define (db:get-changed-run-ids since-time) - (let* ((dbdir (db:dbfile-path)) ;; (configf:lookup *configdat* "setup" "dbdir")) + (let* ((dbdir (db:dbfile-path #f)) ;; (configf:lookup *configdat* "setup" "dbdir")) (alldbs (glob (conc dbdir "/[0-9]*.db"))) (changed (filter (lambda (dbfile) (> (file-modification-time dbfile) since-time)) alldbs))) (delete-duplicates Index: dcommon.scm ================================================================== --- dcommon.scm +++ dcommon.scm @@ -18,11 +18,12 @@ (declare (unit dcommon)) (declare (uses megatest-version)) (declare (uses gutils)) -(declare (uses db)) +;; (declare (uses db)) +(declare (uses mrmt)) ;; (declare (uses synchash)) (include "common_records.scm") (include "db_records.scm") (include "key_records.scm") @@ -430,11 +431,11 @@ (list-ref (list-ref item 2) 1)))) res) res)))) (define (dcommon:examine-xterm run-id test-id) - (let* ((testdat (rmt:get-test-info-by-id run-id test-id))) + (let* ((testdat (mrmt:get-test-info-by-id run-id test-id))) (if (not testdat) (begin (debug:print 2 "ERROR: No test data found for test " test-id ", exiting") (exit 1)) (let* @@ -547,11 +548,11 @@ (define (dcommon:run-stats commondat tabdat #!key (tab-num #f)) (let* ((stats-matrix (iup:matrix expand: "YES")) (changed #f) (stats-updater (lambda () (if (dashboard:database-changed? commondat tabdat context-key: 'run-stats) - (let* ((run-stats (rmt:get-run-stats)) + (let* ((run-stats (mrmt:get-run-stats)) (indices (common:sparse-list-generate-index run-stats)) ;; proc: set-cell)) (row-indices (car indices)) (col-indices (cadr indices)) (max-row (if (null? row-indices) 1 (common:max (map cadr row-indices)))) (max-col (if (null? col-indices) 1 @@ -1093,11 +1094,11 @@ (dashboard:update-run-command tabdat)))) "command-runname-selector lb action")))) (refresh-runs-list (lambda () (if (dashboard:database-changed? commondat tabdat context-key: 'runname-selector-runs-list) (let* (;; (target (dboard:tabdat-target-string tabdat)) - (runs-for-targ (rmt:get-runs-by-patt (dboard:tabdat-keys tabdat) "%" #f #f #f #f 0)) + (runs-for-targ (mrmt:get-runs-by-patt (dboard:tabdat-keys tabdat) "%" #f #f #f #f 0)) (runs-header (vector-ref runs-for-targ 0)) (runs-dat (vector-ref runs-for-targ 1)) (run-names (cons default-run-name (map (lambda (x) (db:get-value-by-header x runs-header "runname")) Index: megatest.config ================================================================== --- megatest.config +++ megatest.config @@ -1,17 +1,18 @@ ## commented out due to a bug in v1.6501 in mtutil -## [fields] -## a text -## b text -## c text +[fields] +a text +b text +c text [setup] pktsdirs /tmp/pkts /some/other/source [areas] -# path-to-area map-target-script(future, optional) +# path=path-to-area;targtrans=script_to_transform_target +local path=. fullrun path=tests/fullrun # targtrans is name of scheme proc stored in .mtutil.scm, which lives in PWD where mtutil is run # ext-tests path=ext-tests; targtrans=prefix-contour; ext path=ext-tests ADDED mrmt.scm Index: mrmt.scm ================================================================== --- /dev/null +++ mrmt.scm @@ -0,0 +1,902 @@ +;;====================================================================== +;; Copyright 2006-2017, Matthew Welland. +;; +;; This program is made available under the GNU GPL version 2.0 or +;; greater. See the accompanying file COPYING for details. +;; +;; This program is distributed WITHOUT ANY WARRANTY; without even the +;; implied warranty of MERCHANTABILITY or FITNESS FOR A PARTICULAR +;; PURPOSE. +;;====================================================================== + +(use format typed-records) ;; RADT => purpose of json format?? + +(declare (unit mrmt)) +(declare (uses api)) +;; (declare (uses tdb)) +(declare (uses http-transport)) +;;(declare (uses nmsg-transport)) +(include "common_records.scm") + +;; +;; THESE ARE ALL CALLED ON THE CLIENT SIDE!!! +;; + +;; generate entries for ~/.megatestrc with the following +;; +;; grep define ../rmt.scm | grep mrmt: |perl -pi -e 's/\(define\s+\((\S+)\W.*$/\1/'|sort -u + +;;====================================================================== +;; S U P P O R T F U N C T I O N S +;;====================================================================== + +;; if a server is either running or in the process of starting call client:setup +;; else return #f to let the calling proc know that there is no server available +;; +(define (mrmt:get-connection-info areapath #!key (area-dat #f)) ;; TODO: push areapath down. + (let* ((runremote (or area-dat *runremote*)) + (cinfo (if (remote? runremote) + (remote-conndat runremote) + #f))) + (if cinfo + cinfo + (if (server:check-if-running areapath) + (client:setup areapath) + #f)))) + +(define *send-receive-mutex* (make-mutex)) ;; should have separate mutex per run-id + +;; RA => e.g. usage (mrmt:send-receive 'get-var #f (list varname)) +;; +(define (mrmt:send-receive cmd rid params #!key (attemptnum 1)(area-dat #f)) ;; start attemptnum at 1 so the modulo below works as expected + + ;;DOT digraph megatest_state_status { + ;;DOT ranksep=0; + ;;DOT // rankdir=LR; + ;;DOT node [shape="box"]; + ;;DOT "mrmt:send-receive" -> MUTEXLOCK; + ;;DOT { edge [style=invis];"case 1" -> "case 2" -> "case 3" -> "case 4" -> "case 5" -> "case 6" -> "case 7" -> "case 8" -> "case 9" -> "case 10" -> "case 11"; } + ;; do all the prep locked under the rmt-mutex + (mutex-lock! *rmt-mutex*) + + ;; 1. check if server is started IFF cmd is a write OR if we are not on the homehost, store in runremote + ;; 2. check the age of the connections. refresh the connection if it is older than timeout-20 seconds. + ;; 3. do the query, if on homehost use local access + ;; + (let* ((start-time (current-seconds)) ;; snapshot time so all use cases get same value + (areapath *toppath*);; TODO - resolve from dbstruct to be compatible with multiple areas + (runremote (or area-dat + *runremote*)) + (readonly-mode (if (and runremote + (remote-ro-mode-checked runremote)) + (remote-ro-mode runremote) + (let* ((dbfile (conc *toppath* "/megatest.db")) + (ro-mode (not (file-write-access? dbfile)))) ;; TODO: use dbstruct or runremote to figure this out in future + (if runremote + (begin + (remote-ro-mode-set! runremote ro-mode) + (remote-ro-mode-checked-set! runremote #t) + ro-mode) + ro-mode))))) + + ;; DOT INIT_RUNREMOTE; // leaving off - doesn't really add to the clarity + ;; DOT MUTEXLOCK -> INIT_RUNREMOTE [label="no remote?"]; + ;; DOT INIT_RUNREMOTE -> MUTEXLOCK; + ;; ensure we have a record for our connection for given area + (if (not runremote) ;; can remove this one. should never get here. + (begin + (set! *runremote* (make-remote)) + (set! runremote *runremote*))) ;; new runremote will come from this on next iteration + + ;; DOT SET_HOMEHOST; // leaving off - doesn't really add to the clarity + ;; DOT MUTEXLOCK -> SET_HOMEHOST [label="no homehost?"]; + ;; DOT SET_HOMEHOST -> MUTEXLOCK; + ;; ensure we have a homehost record + (if (not (pair? (remote-hh-dat runremote))) ;; not on homehost + (thread-sleep! 0.1) ;; since we shouldn't get here, delay a little + (remote-hh-dat-set! runremote (common:get-homehost))) + + ;;(print "BB> readonly-mode is "readonly-mode" dbfile is "dbfile) + (cond + ;;DOT EXIT; + ;;DOT MUTEXLOCK -> EXIT [label="> 15 attempts"]; {rank=same "case 1" "EXIT" } + ;; give up if more than 15 attempts + ((> attemptnum 15) + (debug:print 0 *default-log-port* "ERROR: 15 tries to start/connect to server. Giving up.") + (exit 1)) + + ;;DOT CASE2 [label="local\nreadonly\nquery"]; + ;;DOT MUTEXLOCK -> CASE2; {rank=same "case 2" CASE2} + ;;DOT CASE2 -> "mrmt:open-qry-close-locally"; + ;; readonly mode, read request- handle it - case 2 + ((and readonly-mode + (member cmd api:read-only-queries)) + (mutex-unlock! *rmt-mutex*) + (debug:print-info 12 *default-log-port* "mrmt:send-receive, case 2") + (mrmt:open-qry-close-locally cmd 0 params) + ) + + ;;DOT CASE3 [label="write in\nread-only mode"]; + ;;DOT MUTEXLOCK -> CASE3 [label="readonly\nmode?"]; {rank=same "case 3" CASE3} + ;;DOT CASE3 -> "#f"; + ;; readonly mode, write request. Do nothing, return #f + (readonly-mode + (mutex-unlock! *rmt-mutex*) + (debug:print-info 12 *default-log-port* "mrmt:send-receive, case 3") + (debug:print 0 *default-log-port* "WARNING: write transaction requested on a readonly area. cmd="cmd" params="params) + #f) + + ;; This block was for pre-emptively resetting the connection if there had been no communication for some time. + ;; I don't think it adds any value. If the server is not there, just fail and start a new connection. + ;; also, the expire-time calculation might not be correct. We want, time-since-last-server-access > (server:get-timeout) + ;; + ;;DOT CASE4 [label="reset\nconnection"]; + ;;DOT MUTEXLOCK -> CASE4 [label="have connection,\nlast_access > expire_time"]; {rank=same "case 4" CASE4} + ;;DOT CASE4 -> "mrmt:send-receive"; + ;; reset the connection if it has been unused too long + ((and runremote + (remote-conndat runremote) + (> (current-seconds) ;; if it has been more than server-timeout seconds since last contact, close this connection and start a new on + (+ (http-transport:server-dat-get-last-access (remote-conndat runremote)) + (remote-server-timeout runremote)))) + (debug:print-info 0 *default-log-port* "Connection to " (remote-server-url runremote) " expired due to no accesses, forcing new connection.") + (http-transport:close-connections area-dat: runremote) + (remote-conndat-set! runremote #f) ;; invalidate the connection, thus forcing a new connection. + (mutex-unlock! *rmt-mutex*) + (mrmt:send-receive cmd rid params attemptnum: attemptnum)) + + ;;DOT CASE5 [label="local\nread"]; + ;;DOT MUTEXLOCK -> CASE5 [label="server not required,\non homehost,\nread-only query"]; {rank=same "case 5" CASE5}; + ;;DOT CASE5 -> "mrmt:open-qry-close-locally"; + ;; on homehost and this is a read + ((and (not (remote-force-server runremote)) ;; honor forced use of server, i.e. server NOT required + (cdr (remote-hh-dat runremote)) ;; on homehost + (member cmd api:read-only-queries)) ;; this is a read + (mutex-unlock! *rmt-mutex*) + (debug:print-info 12 *default-log-port* "mrmt:send-receive, case 5") + (mrmt:open-qry-close-locally cmd 0 params)) + + ;;DOT CASE6 [label="init\nremote"]; + ;;DOT MUTEXLOCK -> CASE6 [label="on homehost,\nwrite query,\nhave server,\ncan't reach it"]; {rank=same "case 6" CASE6}; + ;;DOT CASE6 -> "mrmt:send-receive"; + ;; on homehost and this is a write, we already have a server, but server has died + ((and (cdr (remote-hh-dat runremote)) ;; on homehost + (not (member cmd api:read-only-queries)) ;; this is a write + (remote-server-url runremote) ;; have a server + (not (server:ping (remote-server-url runremote)))) ;; server has died. NOTE: this is not a cheap call! Need better approach. + (set! *runremote* (make-remote)) + (remote-force-server-set! runremote (common:force-server?)) + (mutex-unlock! *rmt-mutex*) + (debug:print-info 12 *default-log-port* "mrmt:send-receive, case 6") + (mrmt:send-receive cmd rid params attemptnum: attemptnum)) + + ;;DOT CASE7 [label="homehost\nwrite"]; + ;;DOT MUTEXLOCK -> CASE7 [label="server not required,\non homehost,\na write,\nhave a server"]; {rank=same "case 7" CASE7}; + ;;DOT CASE7 -> "mrmt:open-qry-close-locally"; + ;; on homehost and this is a write, we already have a server + ((and (not (remote-force-server runremote)) ;; honor forced use of server, i.e. server NOT required + (cdr (remote-hh-dat runremote)) ;; on homehost + (not (member cmd api:read-only-queries)) ;; this is a write + (remote-server-url runremote)) ;; have a server + (mutex-unlock! *rmt-mutex*) + (debug:print-info 12 *default-log-port* "mrmt:send-receive, case 4.1") + (mrmt:open-qry-close-locally cmd 0 params)) + + ;;DOT CASE8 [label="force\nserver"]; + ;;DOT MUTEXLOCK -> CASE8 [label="server not required,\nhave homehost info,\nno connection yet,\nnot a read-only query"]; {rank=same "case 8" CASE8}; + ;;DOT CASE8 -> "mrmt:open-qry-close-locally"; + ;; on homehost, no server contact made and this is a write, passively start a server + ((and (not (remote-force-server runremote)) ;; honor forced use of server, i.e. server NOT required + (cdr (remote-hh-dat runremote)) ;; have homehost + (not (remote-server-url runremote)) ;; no connection yet + (not (member cmd api:read-only-queries))) ;; not a read-only query + (debug:print-info 12 *default-log-port* "mrmt:send-receive, case 8") + (let ((server-url (server:check-if-running *toppath*))) ;; (server:read-dotserver->url *toppath*))) ;; (server:check-if-running *toppath*))) ;; Do NOT want to run server:check-if-running - very expensive to do for every write call + (if server-url + (remote-server-url-set! runremote server-url) ;; the string can be consumed by the client setup if needed + (if (common:force-server?) + (server:start-and-wait *toppath*) + (server:kind-run *toppath*)))) + (remote-force-server-set! runremote (common:force-server?)) + (mutex-unlock! *rmt-mutex*) + (debug:print-info 12 *default-log-port* "mrmt:send-receive, case 8.1") + (mrmt:open-qry-close-locally cmd 0 params)) + + ;;DOT CASE9 [label="force server\nnot on homehost"]; + ;;DOT MUTEXLOCK -> CASE9 [label="no connection\nand either require server\nor not on homehost"]; {rank=same "case 9" CASE9}; + ;;DOT CASE9 -> "start\nserver" -> "mrmt:send-receive"; + ((or (and (remote-force-server runremote) ;; we are forcing a server and don't yet have a connection to one + (not (remote-conndat runremote))) + (and (not (cdr (remote-hh-dat runremote))) ;; not on a homehost + (not (remote-conndat runremote)))) ;; and no connection + (debug:print-info 12 *default-log-port* "mrmt:send-receive, case 9, hh-dat: " (remote-hh-dat runremote) " conndat: " (remote-conndat runremote)) + (mutex-unlock! *rmt-mutex*) + (if (not (server:check-if-running *toppath*)) ;; who knows, maybe one has started up? + (server:start-and-wait *toppath*)) + (remote-conndat-set! runremote (mrmt:get-connection-info *toppath*)) ;; calls client:setup which calls client:setup-http + (mrmt:send-receive cmd rid params attemptnum: attemptnum)) ;; TODO: add back-off timeout as + + ;;DOT CASE10 [label="on homehost"]; + ;;DOT MUTEXLOCK -> CASE10 [label="server not required,\non homehost"]; {rank=same "case 10" CASE10}; + ;;DOT CASE10 -> "mrmt:open-qry-close-locally"; + ;; all set up if get this far, dispatch the query + ((and (not (remote-force-server runremote)) + (cdr (remote-hh-dat runremote))) ;; we are on homehost + (mutex-unlock! *rmt-mutex*) + (debug:print-info 12 *default-log-port* "mrmt:send-receive, case 10") + (mrmt:open-qry-close-locally cmd (if rid rid 0) params)) + + ;;DOT CASE11 [label="send_receive"]; + ;;DOT MUTEXLOCK -> CASE11 [label="else"]; {rank=same "case 11" CASE11}; + ;;DOT CASE11 -> "mrmt:send-receive" [label="call failed"]; + ;;DOT CASE11 -> "RESULT" [label="call succeeded"]; + ;; not on homehost, do server query + (else + ;; (mutex-unlock! *rmt-mutex*) + (debug:print-info 12 *default-log-port* "mrmt:send-receive, case 9") + ;; (mutex-lock! *rmt-mutex*) + (let* ((conninfo (remote-conndat runremote)) + (dat (case (remote-transport runremote) + ((http) (condition-case ;; handling here has caused a lot of problems. However it is needed to deal with attemtped communication to servers that have gone away + (http-transport:client-api-send-receive 0 conninfo cmd params) + ((commfail)(vector #f "communications fail")) + ((exn)(vector #f "other fail" (print-call-chain))))) + (else + (debug:print 0 *default-log-port* "ERROR: transport " (remote-transport runremote) " not supported") + (exit)))) + (success (if (vector? dat) (vector-ref dat 0) #f)) + (res (if (vector? dat) (vector-ref dat 1) #f))) + (if (and (vector? conninfo) (< 5 (vector-length conninfo))) + (http-transport:server-dat-update-last-access conninfo) ;; refresh access time + (begin + (debug:print 0 *default-log-port* "INFO: Should not get here! conninfo=" conninfo) + (set! conninfo #f) + (remote-conndat-set! *runremote* #f) + (http-transport:close-connections area-dat: runremote))) + ;; (mutex-unlock! *rmt-mutex*) + (debug:print-info 13 *default-log-port* "mrmt:send-receive, case 9. conninfo=" conninfo " dat=" dat " runremote = " runremote) + (mutex-unlock! *rmt-mutex*) + (if success ;; success only tells us that the transport was successful, have to examine the data to see if there was a detected issue at the other end + (if (and (vector? res) + (eq? (vector-length res) 2) + (eq? (vector-ref res 1) 'overloaded)) ;; since we are looking at the data to carry the error we'll use a fairly obtuse combo to minimise the chances of some sort of collision. + ;; this is the case where the returned data is bad or the server is overloaded and we want + ;; to ease off the queries + (let ((wait-delay (+ attemptnum (* attemptnum 10)))) + (debug:print 0 *default-log-port* "WARNING: server is overloaded. Delaying " wait-delay " seconds and trying call again.") + (mutex-lock! *rmt-mutex*) + (http-transport:close-connections area-dat: runremote) + (set! *runremote* #f) ;; force starting over + (mutex-unlock! *rmt-mutex*) + (thread-sleep! wait-delay) + (mrmt:send-receive cmd rid params attemptnum: (+ attemptnum 1))) + res) ;; All good, return res + (begin + (debug:print 0 *default-log-port* "WARNING: communication failed. Trying again, try num: " attemptnum) + (mutex-lock! *rmt-mutex*) + (remote-conndat-set! runremote #f) + (http-transport:close-connections area-dat: runremote) + (remote-server-url-set! runremote #f) + (mutex-unlock! *rmt-mutex*) + (debug:print-info 12 *default-log-port* "mrmt:send-receive, case 9.1") + ;; (if (not (server:check-if-running *toppath*)) + ;; (server:start-and-wait *toppath*)) + (mrmt:send-receive cmd rid params attemptnum: (+ attemptnum 1))))))))) + + ;;DOT } + +;; (define (mrmt:update-db-stats run-id rawcmd params duration) +;; (mutex-lock! *db-stats-mutex*) +;; (handle-exceptions +;; exn +;; (begin +;; (debug:print 0 *default-log-port* "WARNING: stats collection failed in update-db-stats") +;; (debug:print 0 *default-log-port* " message: " ((condition-property-accessor 'exn 'message) exn)) +;; (print "exn=" (condition->list exn)) +;; #f) ;; if this fails we don't care, it is just stats +;; (let* ((cmd (conc "run-id=" run-id " " (if (eq? rawcmd 'general-call) (car params) rawcmd))) +;; (stat-vec (hash-table-ref/default *db-stats* cmd #f))) +;; (if (not (vector? stat-vec)) +;; (let ((newvec (vector 0 0))) +;; (hash-table-set! *db-stats* cmd newvec) +;; (set! stat-vec newvec))) +;; (vector-set! stat-vec 0 (+ (vector-ref stat-vec 0) 1)) +;; (vector-set! stat-vec 1 (+ (vector-ref stat-vec 1) duration)))) +;; (mutex-unlock! *db-stats-mutex*)) + +(define (mrmt:print-db-stats) + (let ((fmtstr "~40a~7-d~9-d~20,2-f")) ;; "~20,2-f" + (debug:print 18 *default-log-port* "DB Stats\n========") + (debug:print 18 *default-log-port* (format #f "~40a~8a~10a~10a" "Cmd" "Count" "TotTime" "Avg")) + (for-each (lambda (cmd) + (let ((cmd-dat (hash-table-ref *db-stats* cmd))) + (debug:print 18 *default-log-port* (format #f fmtstr cmd (vector-ref cmd-dat 0) (vector-ref cmd-dat 1) (/ (vector-ref cmd-dat 1)(vector-ref cmd-dat 0)))))) + (sort (hash-table-keys *db-stats*) + (lambda (a b) + (> (vector-ref (hash-table-ref *db-stats* a) 0) + (vector-ref (hash-table-ref *db-stats* b) 0))))))) + +(define (mrmt:get-max-query-average run-id) + (mutex-lock! *db-stats-mutex*) + (let* ((runkey (conc "run-id=" run-id " ")) + (cmds (filter (lambda (x) + (substring-index runkey x)) + (hash-table-keys *db-stats*))) + (res (if (null? cmds) + (cons 'none 0) + (let loop ((cmd (car cmds)) + (tal (cdr cmds)) + (max-cmd (car cmds)) + (res 0)) + (let* ((cmd-dat (hash-table-ref *db-stats* cmd)) + (tot (vector-ref cmd-dat 0)) + (curravg (/ (vector-ref cmd-dat 1) (vector-ref cmd-dat 0))) ;; count is never zero by construction + (currmax (max res curravg)) + (newmax-cmd (if (> curravg res) cmd max-cmd))) + (if (null? tal) + (if (> tot 10) + (cons newmax-cmd currmax) + (cons 'none 0)) + (loop (car tal)(cdr tal) newmax-cmd currmax))))))) + (mutex-unlock! *db-stats-mutex*) + res)) + +(define (mrmt:open-qry-close-locally cmd run-id params #!key (remretries 5)) + (let* ((qry-is-write (not (member cmd api:read-only-queries))) + (db-file-path (db:dbfile-path #f)) ;; 0)) + (dbstruct-local (db:setup #t)) ;; make-dbr:dbstruct path: dbdir local: #t))) + (read-only (not (file-write-access? db-file-path))) + (start (current-milliseconds)) + (resdat (if (not (and read-only qry-is-write)) + (let ((v (api:execute-requests dbstruct-local (vector (symbol->string cmd) params)))) + (handle-exceptions ;; there has been a long history of receiving strange errors from values returned by the client when things go wrong.. + exn ;; This is an attempt to detect that situation and recover gracefully + (begin + (debug:print0 *default-log-port* "ERROR: bad data from server " v " message: " ((condition-property-accessor 'exn 'message) exn)) + (vector #t '())) ;; should always get a vector but if something goes wrong return a dummy + (if (and (vector? v) + (> (vector-length v) 1)) + (let ((newvec (vector (vector-ref v 0)(vector-ref v 1)))) + newvec) ;; by copying the vector while inside the error handler we should force the detection of a corrupted record + (vector #t '())))) ;; we could also check that the returned types are valid + (vector #t '()))) + (success (vector-ref resdat 0)) + (res (vector-ref resdat 1)) + (duration (- (current-milliseconds) start))) + (if (and read-only qry-is-write) + (debug:print 0 *default-log-port* "ERROR: attempt to write to read-only database ignored. cmd=" cmd)) + (if (not success) + (if (> remretries 0) + (begin + (debug:print-error 0 *default-log-port* "local query failed. Trying again.") + (thread-sleep! (/ (random 5000) 1000)) ;; some random delay + (mrmt:open-qry-close-locally cmd run-id params remretries: (- remretries 1))) + (begin + (debug:print-error 0 *default-log-port* "too many retries in mrmt:open-qry-close-locally, giving up") + #f)) + (begin + ;; (mrmt:update-db-stats run-id cmd params duration) + ;; mark this run as dirty if this was a write, the watchdog is responsible for syncing it + (if qry-is-write + (let ((start-time (current-seconds))) + (mutex-lock! *db-multi-sync-mutex*) +/ (set! *db-last-access* start-time) ;; THIS IS PROBABLY USELESS? (we are on a client) + (mutex-unlock! *db-multi-sync-mutex*))))) + res)) + +(define (mrmt:send-receive-no-auto-client-setup connection-info cmd run-id params) + (let* ((run-id (if run-id run-id 0)) + (res (handle-exceptions + exn + #f + (http-transport:client-api-send-receive run-id connection-info cmd params)))) + (if (and res (vector-ref res 0)) + (vector-ref res 1) ;;; YES!! THIS IS CORRECT!! CHANGE IT HERE, THEN CHANGE mrmt:send-receive ALSO!!! + #f))) + +;; ;; Wrap json library for strings (why the ports crap in the first place?) +;; (define (mrmt:dat->json-str dat) +;; (with-output-to-string +;; (lambda () +;; (json-write dat)))) +;; +;; (define (mrmt:json-str->dat json-str) +;; (with-input-from-string json-str +;; (lambda () +;; (json-read)))) + +;;====================================================================== +;; +;; A C T U A L A P I C A L L S +;; +;;====================================================================== + +;;====================================================================== +;; S E R V E R +;;====================================================================== + +(define (mrmt:kill-server run-id) + (mrmt:send-receive 'kill-server run-id (list run-id))) + +(define (mrmt:start-server run-id) + (mrmt:send-receive 'start-server 0 (list run-id))) + +;;====================================================================== +;; M I S C +;;====================================================================== + +(define (mrmt:login run-id) + (mrmt:send-receive 'login run-id (list *toppath* megatest-version *my-client-signature*))) + +;; This login does no retries under the hood - it acts a bit like a ping. +;; Deprecated for nmsg-transport. +;; +(define (mrmt:login-no-auto-client-setup connection-info) + (case *transport-type* ;; run-id of 0 is just a placeholder + ((http)(mrmt:send-receive-no-auto-client-setup connection-info 'login 0 (list *toppath* megatest-version *my-client-signature*))) + ;;((nmsg)(nmsg-transport:client-api-send-receive run-id connection-info 'login (list *toppath* megatest-version run-id *my-client-signature*))) + )) + +;; hand off a call to one of the db:queries statements +;; added run-id to make looking up the correct db possible +;; +(define (mrmt:general-call stmtname run-id . params) + (mrmt:send-receive 'general-call run-id (append (list stmtname run-id) params))) + + +;; given a hostname, return a pair of cpu load and update time representing latest intelligence from tests running on that host +(define (mrmt:get-latest-host-load hostname) + (mrmt:send-receive 'get-latest-host-load 0 (list hostname))) + +;; (define (mrmt:sync-inmem->db run-id) +;; (mrmt:send-receive 'sync-inmem->db run-id '())) + +(define (mrmt:sdb-qry qry val run-id) + ;; add caching if qry is 'getid or 'getstr + (mrmt:send-receive 'sdb-qry run-id (list qry val))) + +;; NOT COMPLETED +(define (mrmt:runtests user run-id testpatt params) + (mrmt:send-receive 'runtests run-id testpatt)) + +(define (mrmt:get-changed-record-ids since-time) + (mrmt:send-receive 'get-changed-record-ids #f (list since-time)) ) + +;;====================================================================== +;; T E S T M E T A +;;====================================================================== + +(define (mrmt:get-tests-tags) + (mrmt:send-receive 'get-tests-tags #f '())) + +;;====================================================================== +;; K E Y S +;;====================================================================== + +;; These require run-id because the values come from the run! +;; +(define (mrmt:get-key-val-pairs run-id) + (mrmt:send-receive 'get-key-val-pairs run-id (list run-id))) + +(define (mrmt:get-keys) + ;; (if *db-keys* *db-keys* + (let ((res (mrmt:send-receive 'get-keys #f '()))) + ;; (set! *db-keys* res) + res)) ;; ) + +(define (mrmt:get-keys-write) ;; dummy query to force server start + (let ((res (mrmt:send-receive 'get-keys-write #f '()))) + ;; (set! *db-keys* res) + res)) + +;; we don't reuse run-id's (except possibly *after* a db cleanup) so it is safe +;; to cache the resuls in a hash +;; +(define (mrmt:get-key-vals run-id) + (or (hash-table-ref/default *keyvals* run-id #f) + (let ((res (mrmt:send-receive 'get-key-vals #f (list run-id)))) + (hash-table-set! *keyvals* run-id res) + res))) + +(define (mrmt:get-targets) + (mrmt:send-receive 'get-targets #f '())) + +(define (mrmt:get-target run-id) + (mrmt:send-receive 'get-target run-id (list run-id))) + +;;====================================================================== +;; T E S T S +;;====================================================================== + +;; Just some syntatic sugar +(define (mrmt:register-test run-id test-name item-path) + (mrmt:general-call 'register-test run-id run-id test-name item-path)) + +(define (mrmt:get-test-id run-id testname item-path) + (mrmt:send-receive 'get-test-id run-id (list run-id testname item-path))) + +;; run-id is NOT used +;; +(define (mrmt:get-test-info-by-id run-id test-id) + (if (number? test-id) + (mrmt:send-receive 'get-test-info-by-id run-id (list run-id test-id)) + (begin + (debug:print 0 *default-log-port* "WARNING: Bad data handed to mrmt:get-test-info-by-id run-id=" run-id ", test-id=" test-id) + (print-call-chain (current-error-port)) + #f))) + +(define (mrmt:test-get-rundir-from-test-id run-id test-id) + (mrmt:send-receive 'test-get-rundir-from-test-id run-id (list run-id test-id))) + +(define (mrmt:open-test-db-by-test-id run-id test-id #!key (work-area #f)) + (let* ((test-path (if (string? work-area) + work-area + (mrmt:test-get-rundir-from-test-id run-id test-id)))) + (debug:print 3 *default-log-port* "TEST PATH: " test-path) + (open-test-db test-path))) + +;; WARNING: This currently bypasses the transaction wrapped writes system +(define (mrmt:test-set-state-status-by-id run-id test-id newstate newstatus newcomment) + (mrmt:send-receive 'test-set-state-status-by-id run-id (list run-id test-id newstate newstatus newcomment))) + +(define (mrmt:set-tests-state-status run-id testnames currstate currstatus newstate newstatus) + (mrmt:send-receive 'set-tests-state-status run-id (list run-id testnames currstate currstatus newstate newstatus))) + +(define (mrmt:get-tests-for-run run-id testpatt states statuses offset limit not-in sort-by sort-order qryvals last-update mode) + ;; (if (number? run-id) + (mrmt:send-receive 'get-tests-for-run run-id (list run-id testpatt states statuses offset limit not-in sort-by sort-order qryvals last-update mode))) + ;; (begin + ;; (debug:print-error 0 *default-log-port* "mrmt:get-tests-for-run called with bad run-id=" run-id) + ;; (print-call-chain (current-error-port)) + ;; '()))) + +;; get stuff via synchash +(define (mrmt:synchash-get run-id proc synckey keynum params) + (mrmt:send-receive 'synchash-get run-id (list run-id proc synckey keynum params))) + +;; IDEA: Threadify these - they spend a lot of time waiting ... +;; +(define (mrmt:get-tests-for-runs-mindata run-ids testpatt states status not-in) + (let ((multi-run-mutex (make-mutex)) + (run-id-list (if run-ids + run-ids + (mrmt:get-all-run-ids))) + (result '())) + (if (null? run-id-list) + '() + (let loop ((hed (car run-id-list)) + (tal (cdr run-id-list)) + (threads '())) + (if (> (length threads) 5) + (loop hed tal (filter (lambda (th)(not (member (thread-state th) '(terminated dead)))) threads)) + (let* ((newthread (make-thread + (lambda () + (let ((res (mrmt:send-receive 'get-tests-for-run-mindata hed (list hed testpatt states status not-in)))) + (if (list? res) + (begin + (mutex-lock! multi-run-mutex) + (set! result (append result res)) + (mutex-unlock! multi-run-mutex)) + (debug:print-error 0 *default-log-port* "get-tests-for-run-mindata failed for run-id " hed ", testpatt " testpatt ", states " states ", status " status ", not-in " not-in)))) + (conc "multi-run-thread for run-id " hed))) + (newthreads (cons newthread threads))) + (thread-start! newthread) + (thread-sleep! 0.05) ;; give that thread some time to start + (if (null? tal) + newthreads + (loop (car tal)(cdr tal) newthreads)))))) + result)) + +;; ;; IDEA: Threadify these - they spend a lot of time waiting ... +;; ;; +;; (define (mrmt:get-tests-for-runs-mindata run-ids testpatt states status not-in) +;; (let ((run-id-list (if run-ids +;; run-ids +;; (mrmt:get-all-run-ids)))) +;; (apply append (map (lambda (run-id) +;; (mrmt:send-receive 'get-tests-for-run-mindata run-id (list run-ids testpatt states status not-in))) +;; run-id-list)))) + +(define (mrmt:delete-test-records run-id test-id) + (mrmt:send-receive 'delete-test-records run-id (list run-id test-id))) + +;; This is not needed as test steps are deleted on test delete call +;; +;; (define (mrmt:delete-test-step-records run-id test-id) +;; (mrmt:send-receive 'delete-test-step-records run-id (list run-id test-id))) + +(define (mrmt:test-set-state-status run-id test-id state status msg) + (mrmt:send-receive 'test-set-state-status run-id (list run-id test-id state status msg))) + +(define (mrmt:test-toplevel-num-items run-id test-name) + (mrmt:send-receive 'test-toplevel-num-items run-id (list run-id test-name))) + +;; (define (mrmt:get-previous-test-run-record run-id test-name item-path) +;; (mrmt:send-receive 'get-previous-test-run-record run-id (list run-id test-name item-path))) + +(define (mrmt:get-matching-previous-test-run-records run-id test-name item-path) + (mrmt:send-receive 'get-matching-previous-test-run-records run-id (list run-id test-name item-path))) + +(define (mrmt:test-get-logfile-info run-id test-name) + (mrmt:send-receive 'test-get-logfile-info run-id (list run-id test-name))) + +(define (mrmt:test-get-records-for-index-file run-id test-name) + (mrmt:send-receive 'test-get-records-for-index-file run-id (list run-id test-name))) + +(define (mrmt:get-testinfo-state-status run-id test-id) + (mrmt:send-receive 'get-testinfo-state-status run-id (list run-id test-id))) + +(define (mrmt:test-set-log! run-id test-id logf) + (if (string? logf)(mrmt:general-call 'test-set-log run-id logf test-id))) + +(define (mrmt:test-set-top-process-pid run-id test-id pid) + (mrmt:send-receive 'test-set-top-process-pid run-id (list run-id test-id pid))) + +(define (mrmt:test-get-top-process-pid run-id test-id) + (mrmt:send-receive 'test-get-top-process-pid run-id (list run-id test-id))) + +(define (mrmt:get-run-ids-matching-target keynames target res runname testpatt statepatt statuspatt) + (mrmt:send-receive 'get-run-ids-matching-target #f (list keynames target res runname testpatt statepatt statuspatt))) + +;; NOTE: This will open and access ALL run databases. +;; +(define (mrmt:test-get-paths-matching-keynames-target-new keynames target res testpatt statepatt statuspatt runname) + (let ((run-ids (mrmt:get-run-ids-matching-target keynames target res runname testpatt statepatt statuspatt))) + (apply append + (map (lambda (run-id) + (mrmt:send-receive 'test-get-paths-matching-keynames-target-new run-id (list run-id keynames target res testpatt statepatt statuspatt runname))) + run-ids)))) + +;; (define (mrmt:get-run-ids-matching keynames target res) +;; (mrmt:send-receive #f 'get-run-ids-matching (list keynames target res))) + +(define (mrmt:get-prereqs-not-met run-id waitons ref-test-name ref-item-path #!key (mode '(normal))(itemmaps #f)) + (mrmt:send-receive 'get-prereqs-not-met run-id (list run-id waitons ref-test-name ref-item-path mode itemmaps))) + +(define (mrmt:get-count-tests-running-for-run-id run-id) + (mrmt:send-receive 'get-count-tests-running-for-run-id run-id (list run-id))) + +;; Statistical queries + +(define (mrmt:get-count-tests-running run-id) + (mrmt:send-receive 'get-count-tests-running run-id (list run-id))) + +(define (mrmt:get-count-tests-running-for-testname run-id testname) + (mrmt:send-receive 'get-count-tests-running-for-testname run-id (list run-id testname))) + +(define (mrmt:get-count-tests-running-in-jobgroup run-id jobgroup) + (mrmt:send-receive 'get-count-tests-running-in-jobgroup run-id (list run-id jobgroup))) + +;; state and status are extra hints not usually used in the calculation +;; +(define (mrmt:set-state-status-and-roll-up-items run-id test-name item-path state status comment) + (mrmt:send-receive 'set-state-status-and-roll-up-items run-id (list run-id test-name item-path state status comment))) + +(define (mrmt:update-pass-fail-counts run-id test-name) + (mrmt:general-call 'update-pass-fail-counts run-id test-name test-name test-name)) + +(define (mrmt:top-test-set-per-pf-counts run-id test-name) + (mrmt:send-receive 'top-test-set-per-pf-counts run-id (list run-id test-name))) + +(define (mrmt:get-raw-run-stats run-id) + (mrmt:send-receive 'get-raw-run-stats run-id (list run-id))) + +;;====================================================================== +;; R U N S +;;====================================================================== + +(define (mrmt:get-run-info run-id) + (mrmt:send-receive 'get-run-info run-id (list run-id))) + +(define (mrmt:get-num-runs runpatt) + (mrmt:send-receive 'get-num-runs #f (list runpatt))) + +;; Use the special run-id == #f scenario here since there is no run yet +(define (mrmt:register-run keyvals runname state status user contour) + (mrmt:send-receive 'register-run #f (list keyvals runname state status user contour))) + +(define (mrmt:get-run-name-from-id run-id) + (mrmt:send-receive 'get-run-name-from-id run-id (list run-id))) + +(define (mrmt:delete-run run-id) + (mrmt:send-receive 'delete-run run-id (list run-id))) + +(define (mrmt:update-run-stats run-id stats) + (mrmt:send-receive 'update-run-stats #f (list run-id stats))) + +(define (mrmt:delete-old-deleted-test-records) + (mrmt:send-receive 'delete-old-deleted-test-records #f '())) + +(define (mrmt:get-runs runpatt count offset keypatts) + (mrmt:send-receive 'get-runs #f (list runpatt count offset keypatts))) + +(define (mrmt:get-all-run-ids) + (mrmt:send-receive 'get-all-run-ids #f '())) + +(define (mrmt:get-prev-run-ids run-id) + (mrmt:send-receive 'get-prev-run-ids #f (list run-id))) + +(define (mrmt:lock/unlock-run run-id lock unlock user) + (mrmt:send-receive 'lock/unlock-run #f (list run-id lock unlock user))) + +;; set/get status +(define (mrmt:get-run-status run-id) + (mrmt:send-receive 'get-run-status #f (list run-id))) + +(define (mrmt:set-run-status run-id run-status #!key (msg #f)) + (mrmt:send-receive 'set-run-status #f (list run-id run-status msg))) + +(define (mrmt:update-run-event_time run-id) + (mrmt:send-receive 'update-run-event_time #f (list run-id))) + +(define (mrmt:get-runs-by-patt keys runnamepatt targpatt offset limit fields last-runs-update) ;; fields of #f uses default + (mrmt:send-receive 'get-runs-by-patt #f (list keys runnamepatt targpatt offset limit fields last-runs-update))) + +(define (mrmt:find-and-mark-incomplete run-id ovr-deadtime) + ;; (if (mrmt:send-receive 'have-incompletes? run-id (list run-id ovr-deadtime)) + (mrmt:send-receive 'mark-incomplete run-id (list run-id ovr-deadtime))) ;; ) + +(define (mrmt:get-main-run-stats run-id) + (mrmt:send-receive 'get-main-run-stats #f (list run-id))) + +(define (mrmt:get-var varname) + (mrmt:send-receive 'get-var #f (list varname))) + +(define (mrmt:del-var varname) + (mrmt:send-receive 'del-var #f (list varname))) + +(define (mrmt:set-var varname value) + (mrmt:send-receive 'set-var #f (list varname value))) + +;;====================================================================== +;; M U L T I R U N Q U E R I E S +;;====================================================================== + +;; Need to move this to multi-run section and make associated changes +(define (mrmt:find-and-mark-incomplete-all-runs #!key (ovr-deadtime #f)) + (let ((run-ids (mrmt:get-all-run-ids))) + (for-each (lambda (run-id) + (mrmt:find-and-mark-incomplete run-id ovr-deadtime)) + run-ids))) + +;; get the previous record for when this test was run where all keys match but runname +;; returns #f if no such test found, returns a single test record if found +;; +;; Run this at the client end since we have to connect to multiple run-id dbs +;; +(define (mrmt:get-previous-test-run-record run-id test-name item-path) + (let* ((keyvals (mrmt:get-key-val-pairs run-id)) + (keys (mrmt:get-keys)) + (selstr (string-intersperse keys ",")) + (qrystr (string-intersperse (map (lambda (x)(conc x "=?")) keys) " AND "))) + (if (not keyvals) + #f + (let ((prev-run-ids (mrmt:get-prev-run-ids run-id))) + ;; for each run starting with the most recent look to see if there is a matching test + ;; if found then return that matching test record + (debug:print 4 *default-log-port* "selstr: " selstr ", qrystr: " qrystr ", keyvals: " keyvals ", previous run ids found: " prev-run-ids) + (if (null? prev-run-ids) #f + (let loop ((hed (car prev-run-ids)) + (tal (cdr prev-run-ids))) + (let ((results (mrmt:get-tests-for-run hed (conc test-name "/" item-path) '() '() ;; run-id testpatt states statuses + #f #f #f ;; offset limit not-in hide/not-hide + #f #f #f #f 'normal))) ;; sort-by sort-order qryvals last-update mode + (debug:print 4 *default-log-port* "Got tests for run-id " run-id ", test-name " test-name ", item-path " item-path ": " results) + (if (and (null? results) + (not (null? tal))) + (loop (car tal)(cdr tal)) + (if (null? results) #f + (car results)))))))))) + +(define (mrmt:get-run-stats) + (mrmt:send-receive 'get-run-stats #f '())) + +;;====================================================================== +;; S T E P S +;;====================================================================== + +;; Getting steps is more complicated. +;; +;; If given work area +;; 1. Find the testdat.db file +;; 2. Open the testdat.db file and do the query +;; If not given the work area +;; 1. Do a remote call to get the test path +;; 2. Continue as above +;; +;;(define (mrmt:get-steps-for-test run-id test-id) +;; (mrmt:send-receive 'get-steps-data run-id (list test-id))) + +(define (mrmt:teststep-set-status! run-id test-id teststep-name state-in status-in comment logfile) + (let* ((state (items:check-valid-items "state" state-in)) + (status (items:check-valid-items "status" status-in))) + (if (or (not state)(not status)) + (debug:print 3 *default-log-port* "WARNING: Invalid " (if status "status" "state") + " value \"" (if status state-in status-in) "\", update your validvalues section in megatest.config")) + (mrmt:send-receive 'teststep-set-status! run-id (list run-id test-id teststep-name state-in status-in comment logfile)))) + +(define (mrmt:get-steps-for-test run-id test-id) + (mrmt:send-receive 'get-steps-for-test run-id (list run-id test-id))) + +;;====================================================================== +;; T E S T D A T A +;;====================================================================== + +(define (mrmt:read-test-data run-id test-id categorypatt #!key (work-area #f)) + (mrmt:send-receive 'read-test-data run-id (list run-id test-id categorypatt))) +(define (mrmt:read-test-data* run-id test-id categorypatt varpatt #!key (work-area #f)) + (mrmt:send-receive 'read-test-data* run-id (list run-id test-id categorypatt varpatt))) + +;; (let ((tdb (mrmt:open-test-db-by-test-id run-id test-id work-area: work-area))) +;; (if tdb +;; (tdb:read-test-data tdb test-id categorypatt) +;; '()))) + +(define (mrmt:testmeta-add-record testname) + (mrmt:send-receive 'testmeta-add-record #f (list testname))) + +(define (mrmt:testmeta-get-record testname) + (mrmt:send-receive 'testmeta-get-record #f (list testname))) + +(define (mrmt:testmeta-update-field test-name fld val) + (mrmt:send-receive 'testmeta-update-field #f (list test-name fld val))) + +(define (mrmt:test-data-rollup run-id test-id status) + (mrmt:send-receive 'test-data-rollup run-id (list run-id test-id status))) + +(define (mrmt:csv->test-data run-id test-id csvdata) + (mrmt:send-receive 'csv->test-data run-id (list run-id test-id csvdata))) + +;;====================================================================== +;; T A S K S +;;====================================================================== + +(define (mrmt:tasks-find-task-queue-records target run-name test-patt state-patt action-patt) + (mrmt:send-receive 'find-task-queue-records #f (list target run-name test-patt state-patt action-patt))) + +(define (mrmt:tasks-add action owner target runname testpatt params) + (mrmt:send-receive 'tasks-add #f (list action owner target runname testpatt params))) + +(define (mrmt:tasks-set-state-given-param-key param-key new-state) + (mrmt:send-receive 'tasks-set-state-given-param-key #f (list param-key new-state))) + +(define (mrmt:tasks-get-last target runname) + (mrmt:send-receive 'tasks-get-last #f (list target runname))) + +;;====================================================================== +;; N O S Y N C D B +;;====================================================================== + +(define (mrmt:no-sync-set var val) + (mrmt:send-receive 'no-sync-set #f `(,var ,val))) + +(define (mrmt:no-sync-get/default var default) + (mrmt:send-receive 'no-sync-get/default #f `(,var ,default))) + +(define (mrmt:no-sync-del! var) + (mrmt:send-receive 'no-sync-del! #f `(,var))) + +(define (mrmt:no-sync-get-lock keyname) + (mrmt:send-receive 'no-sync-get-lock #f `(,keyname))) + +;;====================================================================== +;; A R C H I V E S +;;====================================================================== + +(define (mrmt:archive-get-allocations testname itempath dneeded) + (mrmt:send-receive 'archive-get-allocations #f (list testname itempath dneeded))) + +(define (mrmt:archive-register-block-name bdisk-id archive-path) + (mrmt:send-receive 'archive-register-block-name #f (list bdisk-id archive-path))) + +(define (mrmt:archive-allocate-testsuite/area-to-block block-id testsuite-name areakey) + (mrmt:send-receive 'archive-allocate-test-to-block #f (list block-id testsuite-name areakey))) + +(define (mrmt:archive-register-disk bdisk-name bdisk-path df) + (mrmt:send-receive 'archive-register-disk #f (list bdisk-name bdisk-path df))) + +(define (mrmt:test-set-archive-block-id run-id test-id archive-block-id) + (mrmt:send-receive 'test-set-archive-block-id run-id (list run-id test-id archive-block-id))) + +(define (mrmt:test-get-archive-block-info archive-block-id) + (mrmt:send-receive 'test-get-archive-block-info #f (list archive-block-id))) Index: mtut.scm ================================================================== --- mtut.scm +++ mtut.scm @@ -439,14 +439,15 @@ ;; (print "Alldat: " alldat ;; " args-data: " args-data) (add-z-card (apply construct-sdat alldat)))) +;; merge/consolidate with common:simple-setup (define (simple-setup start-dir-in) (let* ((start-dir (or start-dir-in ".")) (mtconfig (or (args:get-arg "-config") "megatest.config")) - (mtconfdat (find-and-read-config ;; NB// sets MT_RUN_AREA_HOME as side effect + (mtconfdat (find-and-read-config ;; NB// sets MT_RUN_AREA_HOME as side effect -> NOPE! Not if pathenvvar is #f mtconfig ;; environ-patt: "env-override" given-toppath: start-dir ;; pathenvvar: "MT_RUN_AREA_HOME" )) @@ -987,11 +988,12 @@ (let* ((install-home (common:get-install-area)) (schema-file (conc install-home "/share/db/mt-sqlite3.sql"))) (if (common:file-exists? schema-file) (system (conc "/bin/cat " schema-file))))) ((junk) - (rmt:get-keys)))))))) + (rmt:get-keys)))))) + )) ;; If HTTP_HOST is defined then we must be in the cgi environment ;; so run stml and exit ;; (if (get-environment-variable "HTTP_HOST") Index: rmt.scm ================================================================== --- rmt.scm +++ rmt.scm @@ -477,18 +477,18 @@ ;; (define (rmt:get-key-val-pairs run-id) (rmt:send-receive 'get-key-val-pairs run-id (list run-id))) (define (rmt:get-keys) - (if *db-keys* *db-keys* - (let ((res (rmt:send-receive 'get-keys #f '()))) - (set! *db-keys* res) - res))) + ;; (if *db-keys* *db-keys* + (let ((res (rmt:send-receive 'get-keys #f '()))) + ;; (set! *db-keys* res) + res)) ;; ) (define (rmt:get-keys-write) ;; dummy query to force server start (let ((res (rmt:send-receive 'get-keys-write #f '()))) - (set! *db-keys* res) + ;; (set! *db-keys* res) res)) ;; we don't reuse run-id's (except possibly *after* a db cleanup) so it is safe ;; to cache the resuls in a hash ;; Index: utils/plot-code.scm ================================================================== --- utils/plot-code.scm +++ utils/plot-code.scm @@ -5,21 +5,31 @@ ;; dot -Tpdf plot.dot > plot.pdf ;; first param is comma separated list of files to include in the map, use - to do all ;; second param is list of regexs for functions to include in the map ;; third param is list of files to scan -(use regex srfi-69 srfi-13) +(use regex srfi-69 srfi-13 srfi-1 data-structures posix) + +;; 1 2 remainder +;; plot-code file1.scm,file2.scm... fn-regex file1.scm file2.scm ... + +(define targs #f) + +(define args (argv)) +(if (< (length args) 2) ;; no args provided + (begin + (print "Usage: plot-code file1.scm,file2.scm... 'your.*regex' file3.scm file4.scm file5.scm ...") + (exit))) -(define targs #f) -(define files (cdr (cddddr (argv)))) +(define files (cdddr args)) -(let ((targdat (cadddr (argv)))) +(let ((targdat (cadr args))) (if (equal? targdat "-") (set! targs files) (set! targs (string-split targdat ",")))) -(define function-patt (car (cdr (cdddr (argv))))) +(define function-patt (caddr args)) (define function-rx (regexp function-patt)) (define filedat-defns (make-hash-table)) (define filedat-usages (make-hash-table)) (define defn-rx (regexp "^\\s*\\(define\\s+\\(([^\\s\\)]+).*"))