Index: common.scm ================================================================== --- common.scm +++ common.scm @@ -403,23 +403,18 @@ ;;====================================================================== ;; Move me elsewhere ... ;; RADT => Why do we meed the version check here, this is called only if version misma ;; (define (common:cleanup-db dbstruct #!key (full #f)) - (debug:print 0 *default-log-port* "WARNING: common:cleanup-db has NOT been reimplemented yet! Please fix!") - #;(apply db:multi-db-sync + (apply db:multi-db-sync dbstruct 'schema - ;; 'new2old 'killservers 'adj-target - ;; 'old2new 'new2old - ;; (if full - '(dejunk) - ;; '()) - ) + '(dejunk) + ) (if (common:api-changed?) (common:set-last-run-version))) (define (common:snapshot-file filepath #!key (subdir ".") ) (if (file-exists? filepath) Index: dashboard.scm ================================================================== --- dashboard.scm +++ dashboard.scm @@ -59,13 +59,12 @@ (include "vg_records.scm") (dbfile:db-init-proc db:initialize-main-db) (define help (conc - "Megatest Dashboard, documentation at http://www.kiatoa.com/fossils/megatest - version " megatest-version " - license GPL, Copyright (C) Matt Welland 2012-2017 + "Megatest Dashboard, documentation at http://www.kiatoa.com/fossils/megatest version " megatest-version + " license GPL, Copyright (C) Matt Welland 2012-2017 Usage: dashboard [options] -h : this help -test run-id,test-id : control test identified by testid -skip-version-check : skip the version check @@ -72,11 +71,12 @@ -use-db-cache : access database via cache Misc -rows R : set number of rows -cols C : set number of columns -")) +" +)) ;; -server host:port : connect to host:port instead of db access ;; -xterm run-id,test-id : Start a new xterm with specified run-id and test-id ;; -guimonitor : control panel for runs @@ -106,22 +106,24 @@ "-:p" ;; ignore the built in chicken profiling switch ) args:arg-hash 0)) +;; ################### Top level code ################### + ;; check for MT_* environment variables and exit if found (if (not (args:get-arg "-test")) (begin - (display "Checking for MT_ vars: ") (for-each (lambda (var) - (display " ")(display var) + ;; (display " ")(display var) (if (get-environment-variable var) (begin (print "ERROR: environment variable " var " is set in this terminal, this will cause you problems. Exiting now.") (exit 1)))) '("MT_RUN_AREA_HOME" "MT_MEGATEST" "MT_CMDINFO" "MT_TEST_RUN_DIR" "MT_LINKTREE" "MT_TESTSUITENAME")) - (print ". Done. All ok."))) + ) +) (if (not (null? remargs)) (begin (print "Unrecognised arguments: " (string-intersperse remargs " ")) (exit))) @@ -140,10 +142,11 @@ (debug:print-error 0 *default-log-port* "non-existant start dir " (args:get-arg "-start-dir") " specified, exiting.") (exit 1)))) ;; TODO: Move this inside (main) ;; +(print "launch:setup") (if (not (launch:setup)) (begin (print "Failed to find megatest.config, exiting") (exit 1))) @@ -155,11 +158,16 @@ (not (file-exists? "/etc/os-release"))) (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)))) + (debug:print 0 *default-log-port* "WARNING: You are starting the dashboard on a machine that is not the homehost:" (common:get-homehost)) + (debug:print 0 *default-log-port* "It will be slower." (common:get-homehost)) + )) + +;; ########################### end top level code ############################## + ;; 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")) @@ -3302,11 +3310,11 @@ (filtrstr (conc targpatt "/" runpatt "/" testpatt))) ;; (print "targpatt: " targpatt " runpatt: " runpatt " testpatt: " testpatt) (if (not (equal? (dboard:tabdat-last-filter-str tabdat) filtrstr)) (let ((dwg (dboard:tabdat-drawing tabdat))) - (print "reseting drawing") + (print "resetting drawing") (dboard:tabdat-layout-update-ok-set! tabdat #f) (vg:drawing-libs-set! dwg (make-hash-table)) (vg:drawing-insts-set! dwg (make-hash-table)) (vg:drawing-cache-set! dwg '()) (dboard:tabdat-allruns-by-id-set! tabdat (make-hash-table)) @@ -3816,10 +3824,11 @@ ;;====================================================================== ;; The heavy lifting starts here ;;====================================================================== (define (main) + (print "Starting dashboard 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))) @@ -3871,18 +3880,21 @@ (mutex-lock! (dboard:commondat-update-mutex commondat)) (dboard:commondat-updating-set! commondat #f) (mutex-unlock! (dboard:commondat-update-mutex commondat))) )) 1)))) - + (print "Starting updaters") (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"))) + (print "Starting main loop") (thread-start! th2) (thread-join! th2))))) + +;; ########################### top level code ######################## ;; 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 @@ -713,41 +713,61 @@ ;; (define (db:multi-db-sync dbstruct . options) (let* (;; (dbdat (db:open-db dbstruct #f dbfile:db-init-proc)) (data-synced 0) ;; count of changed records (tmp-area (common:get-db-tmp-area)) - (old2new (member 'old2new options)) + (old2new (member 'old2new options)) + (dejunk (member 'dejunk options)) + (killservers (member 'killservers options)) + (servers (server:get-list *toppath*)) (src-area (if old2new *toppath* tmp-area)) (dest-area (if old2new tmp-area *toppath*)) (dbfiles (if old2new (glob (conc *toppath* "/.megatest/*.db")) (glob (conc tmp-area "/.megatest/*.db")))) (keys (db:get-keys dbstruct)) (sync-durations (make-hash-table))) + + (if killservers + (begin + (for-each + (lambda (server) + (handle-exceptions + exn + (begin + (debug:print-info 0 *default-log-port* "Unable to get host and/or port from " server ", exn=" exn) + #f) + (match-let (((mod-time host port start-time server-id pid) server)) + (if (and host pid) + (tasks:kill-server host pid))))) + servers) + (delete-file* (common:get-sync-lock-filepath)) + ) + ) (for-each (lambda (srcfile) (debug:print-info 3 *default-log-port* "file: " srcfile) (let* ((fname (conc (pathname-file srcfile) ".db")) (basename (pathname-file srcfile)) (run-id (if (string= basename "main") #f (string->number basename))) (destfile (conc dest-area "/.megatest/" fname)) (dest-directory (conc dest-area "/.megatest/")) - (dummy (debug:print-info 0 *default-log-port* "destfile = " destfile)) + (dummy (debug:print-info 2 *default-log-port* "destfile = " destfile)) + (dummy2 (debug:print-info 2 *default-log-port* "dejunk = " dejunk)) (time1 (file-modification-time srcfile)) - (time2 (if (file-exists? destfile) (begin - (debug:print-info 0 *default-log-port* "destfile " destfile " exists") + (debug:print-info 2 *default-log-port* "destfile " destfile " exists") (file-modification-time destfile) ) (begin (debug:print-info 0 *default-log-port* "Sync - I do not see file " destfile) 0))) (changed (> time1 time2)) (do-cp (cond ((not (file-exists? destfile)) ;; shouldn't happen, but this might recover - (debug:print-info 0 *default-log-port* "File " destfile " not found. Copying "srcfile" to "destfile) + (debug:print-info 2 *default-log-port* "File " destfile " not found. Copying "srcfile" to "destfile) (system (conc "/bin/mkdir -p " dest-directory)) (system (conc "/bin/cp " srcfile " " destfile)) #t) (changed ;; (and changed ;; (> (- (current-seconds) time1) 3)) ;; if file is changed and three seconds have passed. @@ -754,26 +774,33 @@ #t) ((and changed *time-to-exit*) ;; last sync #t) (else #f)))) - (if do-cp + (if (or dejunk do-cp) (let* ( (start-time (current-milliseconds)) (subdb (or (dbfile:get-subdb dbstruct run-id) (dbfile:init-subdb dbstruct run-id dbfile:db-init-proc))) (mtdb (dbr:subdb-mtdbdat subdb)) (tmpdb (dbfile:open-db dbstruct run-id dbfile:db-init-proc)) ) (debug:print-info 0 *default-log-port* "delta syncing file: " srcfile ", time diff: " (- time1 time2) " seconds") + (if old2new - (db:sync-tables (db:sync-all-tables-list dbstruct (db:get-keys dbstruct)) #f mtdb tmpdb) - (db:sync-tables (db:sync-all-tables-list dbstruct (db:get-keys dbstruct)) #f tmpdb mtdb) + (begin + (if dejunk (db:clean-up run-id mtdb)) + (db:sync-tables (db:sync-all-tables-list dbstruct (db:get-keys dbstruct)) #f mtdb tmpdb) + ) + (begin + (if dejunk (db:clean-up run-id tmpdb)) + (db:sync-tables (db:sync-all-tables-list dbstruct (db:get-keys dbstruct)) #f tmpdb mtdb) + ) ) (hash-table-set! sync-durations (conc srcfile ".db") (- (current-milliseconds) start-time))) - (debug:print-info 0 *default-log-port* "skipping delta sync. " srcfile " is up to date") + (debug:print-info 2 *default-log-port* "skipping delta sync. " srcfile " is up to date") ) ) ) dbfiles ) @@ -1507,54 +1534,20 @@ ;; b. If test dir gone, delete the test record ;; 2. Look at run records ;; a. If have tests that are not deleted, set state='unknown' ;; b. .... ;; -(define (db:clean-up dbdat) - ;; (debug:print 0 *default-log-port* "WARNING: db clean up not fully ported to v1.60, cleanup action will be on megatest.db") - (let* ((keep-record-age ( - (current-seconds) (common:hms-string->seconds (or (configf:lookup *configdat* "setup" "delete-record-age") "30d")))) - (db (dbr:dbdat-dbh dbdat)) - (count-stmt (sqlite3:prepare db "SELECT (SELECT count(id) FROM tests)+(SELECT count(id) FROM runs);")) - (statements - (map (lambda (stmt) - (sqlite3:prepare db stmt)) - (list - ;; delete all tests that belong to runs that are 'deleted' - (conc "DELETE FROM tests WHERE run_id in (SELECT id FROM runs WHERE state='deleted') and last_update < " keep-record-age ";") - ;; delete all tests that are 'DELETED' - (conc "DELETE FROM tests WHERE state='DELETED' and last_update < " keep-record-age " ;") - ;; delete all tests that have no run - (conc "DELETE FROM tests WHERE run_id NOT IN (SELECT DISTINCT id FROM runs) and last_update < " keep-record-age "; ") - ;; delete all runs that are state='deleted' - (conc "DELETE FROM runs WHERE state='deleted' and last_update < " keep-record-age ";") - ;; delete empty runs - (conc "DELETE FROM runs WHERE id NOT IN (SELECT DISTINCT r.id FROM runs AS r INNER JOIN tests AS t ON t.run_id=r.id) and last_update < " keep-record-age ";") - ;; remove orphaned test_rundat entries - (conc "DELETE FROM test_rundat where test_id NOT IN (SELECT id FROM tests);") - ;; remove orphaned test_steps entries - (conc "DELETE FROM test_steps WHERE test_id NOT IN (SELECT id FROM tests);") - ;; remove orphaned test_dat entries - (conc "DELETE FROM test_data WHERE test_id NOT IN (SELECT id FROM tests);") - - )))) - ;; (db:delay-if-busy dbdat) - ;(debug:print-info 0 *default-log-port* statements) - (sqlite3:with-transaction - db - (lambda () - (sqlite3:for-each-row (lambda (tot) - (debug:print-info 0 *default-log-port* "Records count before clean: " tot)) - count-stmt) - (map sqlite3:execute statements) - (sqlite3:for-each-row (lambda (tot) - (debug:print-info 0 *default-log-port* "Records count after clean: " tot)) - count-stmt))) - (map sqlite3:finalize! statements) - (sqlite3:finalize! count-stmt) - ;; (db:find-and-mark-incomplete db) - ;; (db:delay-if-busy dbdat) - (sqlite3:execute db "VACUUM;"))) +(define (db:clean-up run-id dbdat) + (debug:print 2 *default-log-port* "db:clean-up") + + + (if run-id + (db:clean-up-rundb dbdat) + (db:clean-up-maindb dbdat) + ) +) + ;; Clean out old junk and vacuum the database ;; ;; Ultimately do something like this: ;; @@ -1984,11 +1977,11 @@ ;; 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")) - (alldbs (glob (conc dbdir "/[0-9]*.db"))) + (alldbs (glob (conc dbdir "/.megatest/[0-9]*.db"))) (changed (filter (lambda (dbfile) (> (file-modification-time dbfile) since-time)) alldbs))) (delete-duplicates (map (lambda (dbfile) @@ -4350,29 +4343,76 @@ ;;====================================================================== ;; To sync individual run ;;====================================================================== (define (db:get-run-record-ids dbstruct target run keynames test-patt) -(let ((backcons (lambda (lst item)(cons item lst)))) - (db:with-db - dbstruct #f #f - (lambda (dbdat db) - (let* ((keystr (string-intersperse - (map (lambda (key val) + (let* ((backcons (lambda (lst item)(cons item lst))) + (all_tests '()) + (all_test_steps '()) + (all_test_data '()) + (keystr (string-intersperse + (map (lambda (key val) (conc key " like '" val "'")) - keynames - (string-split target "/")) - " AND ")) + keynames + (string-split target "/")) + " AND ") + ) (run-qry (conc "SELECT id FROM runs WHERE " keystr " and runname='" run"'")) - (test-qry (conc "SELECT id FROM tests WHERE run_id in (" run-qry ") and testname like '" test-patt "'"))) - (print run-qry) - (print test-qry) - `((runs . ,(sqlite3:fold-row backcons '() db run-qry)) - (tests . ,(sqlite3:fold-row backcons '() db test-qry)) - (test_steps . ,(sqlite3:fold-row backcons '() db (conc "SELECT id FROM test_steps WHERE test_id in (" test-qry ")"))) - (test_data . ,(sqlite3:fold-row backcons '() db (conc "SELECT id FROM test_data WHERE test_id in (" test-qry ")" ))) - )))))) + (test-qry (conc "SELECT id FROM tests WHERE run_id in (" run-qry ") and testname like '" test-patt "'")) + (run_ids + (db:with-db dbstruct #f #f + (lambda (dbdat db) + (sqlite3:fold-row backcons '() db run-qry)) + ) + ) + ) + (for-each + (lambda (run_id) + (set! all_tests + (append + (map (lambda (x) (cons x run_id)) + (db:with-db dbstruct run_id #f + (lambda (dbdat db) + (sqlite3:fold-row backcons '() db (conc "SELECT id FROM tests WHERE run_id in (" run_id ") and testname like '" test-patt "'")) + ) + ) + ) all_tests + ) + ) + (set! all_test_steps + (append + (map (lambda (x) (cons x run_id)) + (db:with-db dbstruct run_id #f + (lambda (dbdat db) + (sqlite3:fold-row backcons '() db (conc "SELECT id FROM test_steps WHERE test_id in (" test-qry ")")) + ) + ) + ) all_test_steps + ) + ) + (set! all_test_data + (append + (map (lambda (x) (cons x run_id)) + (db:with-db dbstruct run_id #f + (lambda (dbdat db) + (sqlite3:fold-row backcons '() db (conc "SELECT id FROM test_data WHERE test_id in (" test-qry ")")) + ) + ) + ) all_test_data + ) + ) + ) + run_ids + ) + `((runs . ,run_ids) + (tests . ,all_tests) + (test_steps . ,all_test_steps) + (test_data . ,all_test_data) + ) + + ) +) ;;====================================================================== ;; Just for sync, procedures to make sync easy ;;====================================================================== @@ -4383,17 +4423,11 @@ ;; no transaction, allow the db to be accessed between the big queries (let* ((backcons (lambda (lst item)(cons item lst))) (all_tests '()) (all_test_steps '()) (all_test_data '()) - - (run_ids - (db:with-db dbstruct #f #f - (lambda (dbdat db) - (sqlite3:fold-row backcons '() db "SELECT id FROM runs WHERE last_update>=?" since-time)) - ) - ) + (run_ids (db:get-changed-run-ids since-time)) (run_stat_ids (db:with-db dbstruct #f #f (lambda (dbdat db) (sqlite3:fold-row backcons '() db "SELECT id FROM run_stats WHERE last_update>=?" since-time)) ) Index: dbfile.scm ================================================================== --- dbfile.scm +++ dbfile.scm @@ -240,20 +240,13 @@ (set! *dbfile:num-handles-in-use* (+ *dbfile:num-handles-in-use* 1)) (stack-pop! (dbr:subdb-dbstack subdb)))))) ;; return a previously opened db handle to the stack of available handles (define (dbfile:add-dbdat dbstruct run-id dbdat) - (let* ((subdb (dbfile:get-subdb dbstruct run-id)) - (age (- (current-seconds)(dbr:dbdat-birth-sec dbdat)))) - (if #f ;; (> age 300) ;; just testing - discard and close after 30 sec - (begin - ;; (map sqlite3:finalize! (hash-table-values (dbr:dbdat-stmt-cache dbdat))) - ;; (sqlite3:finalize! (dbr:dbdat-dbh dbdat)) - (dbfile:print-err "INFO: Discarded dbdat over 30 sec old ("age"s)")) - (begin - (set! *dbfile:num-handles-in-use* (- *dbfile:num-handles-in-use* 1)) - (stack-push! (dbr:subdb-dbstack subdb) dbdat))))) + (let* ((subdb (dbfile:get-subdb dbstruct run-id))) + (set! *dbfile:num-handles-in-use* (- *dbfile:num-handles-in-use* 1)) + (stack-push! (dbr:subdb-dbstack subdb) dbdat))) ;; set up a subdb ;; (define (dbfile:init-subdb dbstruct run-id init-proc) (let* ((dbname (dbfile:run-id->dbname run-id)) @@ -301,12 +294,12 @@ ;; this stuff is for initial debugging, please remove it when ;; this code stabilizes (define *dbopens* (make-hash-table)) (define (dbfile:inc-db-open dbfile) (let* ((curr-opens-count (+ (hash-table-ref/default *dbopens* dbfile 0) 1))) - (if (> curr-opens-count 1) ;; this should NOT be happening - (dbfile:print-err "INFO: db "dbfile" has been opened "curr-opens-count" times!")) + ;; (if (> curr-opens-count 1) ;; this should NOT be happening + ;; (dbfile:print-err "INFO: db "dbfile" has been opened "curr-opens-count" times!")) (hash-table-set! *dbopens* dbfile curr-opens-count) curr-opens-count)) ;; Open the classic megatest.db file (defaults to open in toppath) ;; @@ -1204,12 +1197,10 @@ #f)) (use-mutex (> *api-process-request-count* 25))) ;; was 25 (if (and use-mutex (common:low-noise-print 120 "over-50-parallel-api-requests")) (dbfile:print-err *api-process-request-count* " parallel api requests being processed in process " (current-process-id) ", throttling access")) - #;(if (common:low-noise-print 600 (conc "parallel-api-requests" *max-api-process-requests*)) - (dbfile:print-err "Parallel api request count: " *api-process-request-count* " max parallel requests: " *max-api-process-requests*)) (condition-case (begin (if use-mutex (mutex-lock! *db-with-db-mutex*)) (let ((res (apply proc dbdat db params))) (if use-mutex (mutex-unlock! *db-with-db-mutex*)) Index: megatest.scm ================================================================== --- megatest.scm +++ megatest.scm @@ -2476,11 +2476,10 @@ (db:setup #f) 'killservers 'dejunk 'adj-testids 'old2new - ;; 'new2old ) (set! *didsomething* #t))) (when (args:get-arg "-sync-brute-force") (launch:setup) Index: tasks.scm ================================================================== --- tasks.scm +++ tasks.scm @@ -886,14 +886,18 @@ (debug:print-info 1 *default-log-port* "Error: Could not get test step info for step id " test-step-id )))) ;; this is a wierd senario need to debug test-step-ids))) (define (tasks:sync-test-gen-data dbh cached-info test-data-ids smallest-last-update-time) (let ((test-ht (hash-table-ref cached-info 'tests)) - (data-ht (hash-table-ref cached-info 'data))) + (data-ht (hash-table-ref cached-info 'data)) + (run-id-in #f) + ) (for-each (lambda (test-data-id) - (let* ((test-data-info (rmt:get-data-info-by-id test-data-id)) + (set! run-id-in (cdr test-data-id)) + (set! test-data-id (car test-data-id)) + (let* ((test-data-info (rmt:get-data-info-by-id run-id-in test-data-id)) (data-id (db:test-data-get-id test-data-info)) (test-id (db:test-data-get-test_id test-data-info)) (category (db:test-data-get-category test-data-info)) (variable (db:test-data-get-variable test-data-info)) (value (db:test-data-get-value test-data-info)) Index: tests.scm ================================================================== --- tests.scm +++ tests.scm @@ -25,19 +25,21 @@ (declare (unit tests)) (declare (uses lock-queue)) (declare (uses db)) (declare (uses tdb)) (declare (uses common)) +(declare (uses commonmod)) ;; (declare (uses dcommon)) ;; needed for the steps processing (declare (uses items)) (declare (uses runconfig)) ;; (declare (uses sdb)) (declare (uses server)) ;;(declare (uses stml2)) (use sqlite3 srfi-1 posix regex regex-case srfi-69 dot-locking tcp directory-utils) (import (prefix sqlite3 sqlite3:)) +(import commonmod) (require-library stml) (include "common_records.scm") (include "key_records.scm") (include "db_records.scm")