Index: dashboard.scm ================================================================== --- dashboard.scm +++ dashboard.scm @@ -95,11 +95,11 @@ ;; (set! *runremote* (string-split (args:get-arg "-host" ":"))) ;; (client:launch)) ;; (if (not (args:get-arg "-use-server")) ;; (set! *transport-type* 'fs) ;; force fs access ;; (client:launch))) - (client:launch)) +;; (client:launch)) ;; HACK ALERT: this is a hack, please fix. (define *read-only* (not (file-read-access? (conc *toppath* "/megatest.db")))) ;; (client:setup *db*) Index: db.scm ================================================================== --- db.scm +++ db.scm @@ -570,11 +570,20 @@ comment TEXT DEFAULT '', status TEXT DEFAULT 'n/a', type TEXT DEFAULT '', CONSTRAINT test_data_constraint UNIQUE (test_id,category,variable));") (sqlite3:execute db "CREATE TABLE IF NOT EXISTS test_rundat ( + id INTEGER PRIMARY KEY, test_id INTEGER, + update_time TIMESTAMP, + cpuload INTEGER DEFAULT -1, + diskfree INTEGER DEFAULT -1, + diskusage INTGER DEFAULT -1, + run_duration INTEGER DEFAULT 0);") + db) + +;;====================================================================== ;; L O G G I N G D B ;;====================================================================== (define (open-logging-db) ;; (conc *toppath* "/megatest.db") (car *configinfo*))) (let* ((dbpath (conc (if *toppath* (conc *toppath* "/") "") "logging.db")) ;; fname) @@ -1297,12 +1306,12 @@ ;; ;; db ;; ;; qry ;; ;; ) ;; ;; res)) -(define (db:delete-test-records db test-id) -(define (db:delete-test-step-records dbstruct run-id test-id) +(define (db:delete-test-records dbstruct run-id test-id) +;; (define (db:delete-test-step-records dbstruct run-id test-id) (let ((db (db:get-db dbstruct run-id))) (db:general-call db 'delete-test-step-records (list test-id)) (db:general-call db 'delete-test-data-records (list test-id)) (sqlite3:execute db "UPDATE tests SET state='DELETED',status='n/a',comment='' WHERE id=?;" test-id)) @@ -1365,12 +1374,12 @@ "SELECT count(id) FROM tests WHERE state in ('RUNNING','LAUNCHED','REMOTEHOSTSTART');") res)) ;; NEW BEHAVIOR: Look only at single run with run-id ;; -(define (db:get-running-stats dbstruct run-id) -(define (db:get-count-tests-running-for-run-id db run-id) +;; (define (db:get-running-stats dbstruct run-id) +(define (db:get-count-tests-running-for-run-id dbstruct run-id) (let ((res 0)) (sqlite3:for-each-row (lambda (count) (set! res count)) db @@ -1420,47 +1429,45 @@ testname item-path) res)) (define db:test-record-qry-selector "id,run_id,testname,state,status,event_time,host,cpuload,diskfree,uname,rundir_id,item_path,run_duration,final_logf,comment,realdir_id") -(define (db:get-all-tests-info-by-run-id db run-id) - (let ((res '())) ;; NOTE: Use db:test-get* to access records -;; ;; NOTE: This needs rundir_id decoding? Decide, decode here or where used? For the moment decode where used. +(define (db:get-all-tests-info-by-run-id dbstruct run-id) + (let ((res '())) + (sqlite3:for-each-row (lambda (id run-id testname state status event-time host cpuload diskfree uname rundir item-path run_duration final_logf comment) ;; 0 1 2 3 4 5 6 7 8 9 10 11 12 13 14 (set! res (cons (vector id run-id testname state status event-time host cpuload diskfree uname rundir item-path run_duration final_logf comment) res))) - db - "SELECT id,run_id,testname,state,status,event_time,host,cpuload,diskfree,uname,rundir,item_path,run_duration,final_logf,comment FROM tests WHERE run_id=?;" + (db:get-db dbstruct run-id) + (conc "SELECT " db:test-record-qry-selector " FROM tests WHERE run_id=?;") run-id) res)) -;; Get test data using test_id -;; + ;; Get test data using test_id (define (db:get-test-info-by-id dbstruct run-id test-id) (let ((res #f)) (sqlite3:for-each-row - (lambda (id run-id testname state status event-time host cpuload diskfree uname rundir item-path run_duration final_logf comment pass_count fail_count) + (lambda (id run-id testname state status event-time host cpuload diskfree uname rundir-id item-path run_duration final_logf comment realdir-id) ;; 0 1 2 3 4 5 6 7 8 9 10 11 12 13 14 - (set! res (vector id run-id testname state status event-time host cpuload diskfree uname rundir item-path run_duration final_logf comment pass_count fail_count))) + (set! res (vector id run-id testname state status event-time host cpuload diskfree uname rundir-id item-path run_duration final_logf comment realdir-id))) (db:get-db dbstruct run-id) - "SELECT id,run_id,testname,state,status,event_time,host,cpuload,diskfree,uname,rundir,item_path,run_duration,final_logf,comment,pass_count,fail_count FROM tests WHERE id=?;" + (conc "SELECT " db:test-record-qry-selector " FROM tests WHERE id=?;") test-id) res)) ;; Use db:test-get* to access -;; ;; Get test data using test_ids. NB// Only works within a single run!! ;; (define (db:get-test-info-by-ids dbstruct run-id test-ids) (let ((res '())) (sqlite3:for-each-row - (lambda (id run-id testname state status event-time host cpuload diskfree uname rundir item-path run_duration final_logf comment pass_count fail_count) + (lambda (id run-id testname state status event-time host cpuload diskfree uname rundir-id item-path run_duration final_logf comment realdir-id) ;; 0 1 2 3 4 5 6 7 8 9 10 11 12 13 14 - (set! res (cons (vector id run-id testname state status event-time host cpuload diskfree uname rundir item-path run_duration final_logf comment pass_count fail_count) + (set! res (cons (vector id run-id testname state status event-time host cpuload diskfree uname rundir-id item-path run_duration final_logf comment realdir-id) res))) (db:get-db dbstruct run-id) (conc "SELECT " db:test-record-qry-selector " FROM tests WHERE id in (" (string-intersperse (map conc test-ids) ",") ");")) res)) @@ -1646,15 +1653,11 @@ (set! res (cons p res))) db qrystr) res)) -(define (db:test-get-paths-matching-keynames-target-new dbstruct keynames target res - testpatt - statepatt - statuspatt - runname) +(define (db:test-get-paths-matching-keynames-target-new dbstruct keynames target res testpatt statepatt statuspatt runname) (let* ((row-ids '()) (keystr (string-intersperse (map (lambda (key val) (conc key " like '" val "'")) keynames @@ -1661,13 +1664,11 @@ (string-split target "/")) " AND ")) (testqry (tests:match->sqlqry testpatt)) (runsqry (sqlite3:prepare (db:get-db dbstruct #f)(conc "SELECT id FROM runs WHERE " keystr " AND runname LIKE '" runname "';"))) (tstsqry (conc "SELECT rundir_id FROM tests WHERE " testqry " AND state LIKE '" statepatt "' AND status LIKE '" statuspatt "' ORDER BY event_time ASC;"))) - (tqry (conc "SELECT rundir FROM tests WHERE run_id=? AND " testqry " AND state LIKE '" statepatt "' AND status LIKE '" statuspatt "' ORDER BY event_time ASC;")) - (tstsqry (sqlite3:prepare db tqry))) - (debug:print 8 "db:test-get-paths-matching-keynames-target-new\n rqry=" rqry "\n tqry=" tqry) + (debug:print 8 "db:test-get-paths-matching-keynames-target-new\n runsqry=" runsqry "\n tstqry=" tstqry) (sqlite3:for-each-row (lambda (rid) (set! row-ids (cons rid row-ids))) runsqry) (sqlite3:finalize! runsqry) @@ -1676,36 +1677,12 @@ (lambda (p) (set! res (cons p res))) (db:get-db dbstruct rid) tstsqry)) row-ids) - ;; (sqlite3:finalize! tstsqry) res)) -;; NEVER FINISHED? ;; look through tests from matching runs for a file -;; NEVER FINISHED? (define (db:test-get-first-path-matching dbstruct keynames target fname) -;; NEVER FINISHED? ;; [refpaths] is the section where references to other megatest databases are stored -;; NEVER FINISHED? ;; -;; NEVER FINISHED? ;; NEED TO REVISIT THIS!!! BUGGISHNESS -;; NEVER FINISHED? ;; -;; NEVER FINISHED? (let ((mt-paths (configf:get-section "refpaths")) -;; NEVER FINISHED? (res (db:test-get-paths-matching dbstruct keynames target fname))) -;; NEVER FINISHED? (let loop ((pathdat (if (null? paths) #f (car mt-paths))) -;; NEVER FINISHED? (tal (if (null? paths) '()(cdr mt-paths)))) -;; NEVER FINISHED? (if (not (null? res)) -;; NEVER FINISHED? (car res) ;; return first found -;; NEVER FINISHED? (if path -;; NEVER FINISHED? (let* ((db (open-db path: (cadr pathdat))) -;; NEVER FINISHED? (newres (db:test-get-paths-matching db keynames target fname))) -;; NEVER FINISHED? (debug:print-info 4 "Trying " (car pathdat) " at " (cadr pathdat)) -;; NEVER FINISHED? (sqlite3:finalize! db) -;; NEVER FINISHED? (if (not (null? newres)) -;; NEVER FINISHED? (car newres) -;; NEVER FINISHED? (if (null? tal) -;; NEVER FINISHED? #f -;; NEVER FINISHED? (loop (car tal)(cdr tal)))))))))) - ;;====================================================================== ;; QUEUE UP META, TEST STATUS AND STEPS REMOTE ACCESS ;;====================================================================== ;; NOTE: Can remove the regex and base64 encoding for zmq @@ -1732,86 +1709,32 @@ (lambda ()(deserialize))) (vector #f #f #f))) ;; crude reply for when things go awry ((zmq)(with-input-from-string msg (lambda ()(deserialize)))) (else msg))) -(define (db:test-set-status-state db test-id status state msg) - (if (member state '("LAUNCHED" "REMOTEHOSTSTART")) - (db:general-call db 'set-test-start-time (list test-id))) - (if msg - (db:general-call db 'state-status-msg (list state status msg test-id)) - (db:general-call db 'state-status (list state status test-id)))) +(define (db:test-set-status-state dbstruct run-id test-id status state msg) + (let ((db (db:get-db dbstruct rid))) + (if (member state '("LAUNCHED" "REMOTEHOSTSTART")) + (db:general-call db 'set-test-start-time (list test-id))) + (if msg + (db:general-call db 'state-status-msg (list state status msg test-id)) + (db:general-call db 'state-status (list state status test-id))))) (define (db:roll-up-pass-fail-counts db run-id test-name item-path status) (if (and (not (equal? item-path "")) (member status '("PASS" "WARN" "FAIL" "WAIVED" "RUNNING" "CHECK" "SKIP"))) - (handle-exceptions - exn - (begin - (debug:print 0 "Problem with call to cdb:remote-run, database may be locked and read-only, waiting and trying again ...") - (thread-sleep! 10) - (apply cdb:remote-run proc db params)) -;; ;; get the sender info -;; ;; this should match (client:get-signature) -;; ;; we will need to process "all" messages here some day -;; (receive-message* sub-socket) -;; ;; now get the actual message -;; (let ((myres (db:string->obj (receive-message* sub-socket)))) -;; (if (equal? query-sig (vector-ref myres 1)) -;; (set! res (vector-ref myres 2)) -;; (loop))))))) -;; ;; (timeout (lambda () -;; ;; (let loop ((n numretries)) -;; ;; (thread-sleep! 15) -;; ;; (if (not res) -;; ;; (if (> numretries 0) -;; ;; (begin -;; ;; (debug:print 2 "WARNING: no reply to query " params ", trying resend") -;; ;; (debug:print-info 11 "re-sending message") -;; ;; (send-message push-socket zdat) -;; ;; (debug:print-info 11 "message re-sent") -;; ;; (loop (- n 1))) -;; ;; ;; (apply cdb:client-call *runremote* qtype immediate (- numretries 1) params)) -;; ;; (begin -;; ;; (debug:print 0 "ERROR: cdb:client-call timed out " params ", exiting.") -;; ;; (exit 5)))))))) -;; (debug:print-info 11 "Starting threads") -;; (let ((th1 (make-thread send-receive "send receive")) -;; ;; (th2 (make-thread timeout "timeout")) -;; ) -;; (thread-start! th1) -;; ;; (thread-start! th2) -;; (thread-join! th1) -;; (debug:print-info 11 "cdb:client-call returning res=" res) -;; res)))))) -;; NOT NEEDED FOR NOW -;; NOT NEEDED FOR NOW (define (cdb:login serverdat keyval signature) -;; NOT NEEDED FOR NOW (cdb:client-call serverdat 'login #t *default-numtries* keyval megatest-version signature)) -;; NOT NEEDED FOR NOW -;; NOT NEEDED FOR NOW (define (cdb:logout serverdat keyval signature) -;; NOT NEEDED FOR NOW (cdb:client-call serverdat 'logout #t *default-numtries* keyval signature)) -;; NOT NEEDED FOR NOW -;; NOT NEEDED FOR NOW (define (cdb:num-clients serverdat) -;; NOT NEEDED FOR NOW (cdb:client-call serverdat 'numclients #t *default-numtries*)) -;; NOT NEEDED FOR NOW -;; (cdb:client-call serverdat 'set-test-start-time #t *default-numtries* test-id)) + (let ((db (db:get-db dbstruct rid))) + (handle-exceptions + exn + (begin + (debug:print 0 "Problem with call to cdb:remote-run, database may be locked and read-only, waiting and trying again ...") + (thread-sleep! 10) + (apply cdb:remote-run proc db params)) + (apply cdb:remote-run proc db params))))) (define (db:tests-register-test dbstruct run-id test-name item-path) (sqlite3:execute (db:get-db dbstruct run-id) 'register-test run-id test-name item-path)) - (apply cdb:client-call *runremote* 'immediate #f *default-numtries* open-run-close proc #f params)) - (begin - (db:general-call db 'update-pass-fail-counts (list run-id test-name run-id test-name run-id test-name)) - (if (equal? status "RUNNING") - (db:general-call db 'top-test-set-running (list run-id test-name)) - (db:general-call db 'top-test-set-per-pf-counts (list run-id test-name run-id test-name run-id test-name))) - #f) - #f)) -;; -;; ;; db should be db open proc or #f -;; (define (cdb:remote-run proc db . params) -;; (apply cdb:client-call *runremote* 'immediate #f *default-numtries* open-run-close proc #f params)) -;; (define (db:test-get-logfile-info dbstruct run-id test-name) (let ((res #f)) (sqlite3:for-each-row (lambda (path-id final_logf-id) @@ -2084,12 +2007,11 @@ ;; ;; Note: mode 'normal means that tests must be COMPLETED and ok (i.e. PASS, WARN, CHECK, SKIP or WAIVED) ;; mode 'toplevel means that tests must be COMPLETED only ;; mode 'itemmatch or 'itemwait means that tests items must be COMPLETED and (PASS|WARN|WAIVED|CHECK) [[ NB// NOT IMPLEMENTED YET ]] ;; -(define (db:get-prereqs-not-met dbstruct run-id waitons ref-item-path #!mode -(define (db:get-prereqs-not-met db run-id waitons ref-item-path mode) +(define (db:get-prereqs-not-met dbstruct run-id waitons ref-item-path mode) (if (or (not waitons) (null? waitons)) '() (let* ((unmet-pre-reqs '()) (result '())) Index: mt.scm ================================================================== --- mt.scm +++ mt.scm @@ -40,11 +40,10 @@ ;; ;; Use: (db-get-value-by-header (db:get-header runinfo)(db:get-row runinfo)) ;; to extract info from the structure returned ;; (define (mt:get-runs-by-patt dbstruct keys runnamepatt targpatt) - (let loop ((runsdat (db:get-runs-by-patt dbstruct keys runnamepatt targpatt 0 500)) (let loop ((runsdat (rmt:get-runs-by-patt keys runnamepatt targpatt 0 500)) (res '()) (offset 0) (limit 500)) ;; (print "runsdat: " runsdat) @@ -53,36 +52,33 @@ (full-list (append res runslst)) (have-more (eq? (length runslst) limit))) ;; (debug:print 0 "header: " header " runslst: " runslst " have-more: " have-more) (if have-more (let ((new-offset (+ offset limit)) - (next-batch (db:get-runs-by-patt dbstruct keys runnamepatt targpatt offset limit))) (next-batch (rmt:get-runs-by-patt keys runnamepatt targpatt offset limit))) (debug:print-info 4 "More than " limit " runs, have " (length full-list) " runs so far.") (debug:print-info 0 "next-batch: " next-batch) (loop next-batch full-list new-offset limit)) - (vector header full-list))))) + (vector header full-list))))) ;;====================================================================== ;; T E S T S ;;====================================================================== -(define (mt:get-tests-for-run dbstruct run-id testpatt states status #!key (not-in #t) (sort-by 'event_time) (sort-order "ASC") (qryvals #f)) - (let loop ((testsdat (db:get-tests-for-run dbstruct run-id testpatt states status 0 500 not-in sort-by sort-order qryvals: qryvals)) +(define (mt:get-tests-for-run run-id testpatt states status #!key (not-in #t) (sort-by 'event_time) (sort-order "ASC") (qryvals #f)) (let loop ((testsdat (rmt:get-tests-for-run run-id testpatt states status 0 500 not-in sort-by sort-order qryvals)) (res '()) (offset 0) (limit 500)) (let* ((full-list (append res testsdat)) (have-more (eq? (length testsdat) limit))) (if have-more (let ((new-offset (+ offset limit))) (debug:print-info 4 "More than " limit " tests, have " (length full-list) " tests so far.") - (loop (db:get-tests-for-run dbstruct run-id testpatt states status new-offset limit not-in sort-by sort-order qryvals: qryvals) (loop (rmt:get-tests-for-run run-id testpatt states status new-offset limit not-in sort-by sort-order qryvals) full-list new-offset limit)) full-list)))) @@ -103,11 +99,10 @@ newres)))) (define (mt:get-run-stats dbstruct run-id) ;; Get run stats from local access, move this ... but where? (db:get-run-stats dbstruct run-id)) - (db:get-run-stats #f)) (define (mt:discard-blocked-tests run-id failed-test tests test-records) (if (null? tests) tests (begin @@ -162,22 +157,22 @@ ;;====================================================================== ;; S T A T E A N D S T A T U S F O R T E S T S ;;====================================================================== ;; ;; speed up for common cases with a little logic -;; (define (mt:test-set-state-status-by-id dbstruct run-id test-id newstate newstatus newcomment) -;; (cond -;; ((and newstate newstatus newcomment) +(define (mt:test-set-state-status-by-id dbstruct run-id test-id newstate newstatus newcomment) + (cond + ((and newstate newstatus newcomment) (rmt:general-call 'state-status-msg newstate newstatus newcomment test-id)) -;; ((and newstate newstatus) + ((and newstate newstatus) (rmt:general-call 'state-status newstate newstatus test-id)) -;; (else - (if newstate (rmt:general-call 'set-test-state newstate test-id)) - (if newstatus (rmt:general-call 'set-test-status newstatus test-id)) - (if newcomment (rmt:general-call 'set-test-comment newcomment test-id)))) -;; (mt:process-triggers test-id newstate newstatus) -;; #t) + (else + (if newstate (rmt:general-call 'set-test-state newstate test-id)) + (if newstatus (rmt:general-call 'set-test-status newstatus test-id)) + (if newcomment (rmt:general-call 'set-test-comment newcomment test-id)))) + (mt:process-triggers test-id newstate newstatus) + #t) (define (mt:lazy-get-test-info-by-id test-id) (let* ((tdat (hash-table-ref/default *test-info* test-id #f))) (if (and tdat (< (current-seconds)(+ (vector-ref tdat 0) 10))) Index: tests.scm ================================================================== --- tests.scm +++ tests.scm @@ -292,13 +292,10 @@ (let ((cmt (if waived waived comment))) (rmt:general-call 'set-test-comment cmt test-id))))) (define (tests:test-set-toplog! run-id test-name logf) (rmt:general-call 'tests:test-set-toplog logf run-id test-name)) - (db:get-query 'tests:test-set-toplog) - (db:save-string dbstruct logf) - test-name)) (define (tests:summarize-items run-id test-id test-name force) ;; if not force then only update the record if one of these is true: ;; 1. logf is "log/final.log ;; 2. logf is same as outputfilename @@ -614,20 +611,19 @@ (if minutes (rmt:general-call 'update-run-duration minutes test-id)) (if (and uname hostname) (rmt:general-call 'update-uname-host uname hostname test-id))) -(define (tests:set-full-meta-info test-id run-id minutes work-area) - (let* ((num-records 0) (define (tests:set-full-meta-info dbstruct test-id run-id minutes work-area) + (let* ((num-records 0) (cpuload (get-cpu-load)) (diskfree (get-df (current-directory))) (uname (get-uname "-srvpio")) (hostname (get-host-name))) (tdb:update-testdat-meta-info test-id work-area cpuload diskfree minutes) (tests:update-central-meta-info dbstruct run-id test-id cpuload diskfree minutes uname hostname))) - + (define (tests:set-partial-meta-info test-id run-id minutes work-area) (let* ((cpuload (get-cpu-load)) (diskfree (get-df (current-directory)))) (tdb:update-testdat-meta-info test-id work-area cpuload diskfree minutes)))