Index: api.scm ================================================================== --- api.scm +++ api.scm @@ -17,10 +17,11 @@ ;; allow these queries through without starting a server ;; (define api:read-only-queries '(get-key-val-pairs get-keys + get-key-vals test-toplevel-num-items get-test-info-by-id test-get-rundir-from-test-id get-count-tests-running-for-testname get-count-tests-running @@ -34,11 +35,14 @@ test-get-paths-matching-keynames-target-new get-prereqs-not-met get-count-tests-running-for-run-id get-run-info get-run-status - register-run + get-run-stats + get-targets + get-target + ;; register-run get-tests-for-run get-test-id get-tests-for-runs-mindata get-run-name-from-id get-runs @@ -49,10 +53,11 @@ get-runs-by-patt get-steps-data get-steps-for-test read-test-data login + tasks-get-last testmeta-get-record have-incompletes? synchash-get )) Index: common.scm ================================================================== --- common.scm +++ common.scm @@ -7,11 +7,11 @@ ;; This program is distributed WITHOUT ANY WARRANTY; without even the ;; implied warranty of MERCHANTABILITY or FITNESS FOR A PARTICULAR ;; PURPOSE. ;;====================================================================== -(use srfi-1 posix regex-case base64 format dot-locking csv-xml z3 sql-de-lite hostinfo typed-records) +(use srfi-1 posix regex-case base64 format dot-locking csv-xml z3 sql-de-lite hostinfo md5 message-digest typed-records) (require-extension regex posix) (require-extension (srfi 18) extras tcp rpc) (import (prefix sqlite3 sqlite3:)) @@ -198,11 +198,12 @@ ;; 'new2old 'killservers 'dejunk ;; 'adj-testids ;; 'old2new - 'new2old) + 'new2old + 'schema) (if (common:version-changed?) (common:set-last-run-version))) ;; Force a megatest cleanup-db if version is changed and skip-version-check not specified ;; @@ -404,10 +405,13 @@ (common:get-testsuite-name) "/" (string-translate *toppath* "/" ".")) #t))) (set! *db-cache-path* dbpath) dbpath))) +(define (common:get-area-path-signature) + (message-digest-string (md5-primitive) *toppath*)) + ;;====================================================================== ;; E X I T H A N D L I N G ;;====================================================================== (define (common:legacy-sync-recommended) @@ -417,15 +421,78 @@ (args:get-arg "-run") (args:get-arg "-server") ;; (args:get-arg "-set-run-status") (args:get-arg "-remove-runs") ;; (args:get-arg "-get-run-status") + (args:get-arg "-use-db-cache") ;; feels like a bad idea ... )) (define (common:legacy-sync-required) (configf:lookup *configdat* "setup" "megatest-db")) +;; run-ids +;; if #f use *db-local-sync* : or 'local-sync-flags +;; if #t use timestamps : or 'timestamps +(define (common:sync-to-megatest.db run-ids) + (let ((start-time (current-seconds)) + (run-ids-to-process (if (list? run-ids) + run-ids + (if (or (eq? run-ids 'timestamps)(eq? run-ids #t)) + (db:get-changed-run-ids (let* ((mtdb-fpath (conc *toppath* "/megatest.db")) + (mtdb-exists (file-exists? mtdb-fpath))) + (if mtdb-exists + (file-modification-time mtdb-fpath) + 0))) + (hash-table-keys *db-local-sync*))))) + (debug:print-info 4 *default-log-port* "Processing run-ids: " run-ids-to-process) + (for-each + (lambda (run-id) + (mutex-lock! *db-multi-sync-mutex*) + (if (or run-ids ;; if we were provided with run-ids, proceed + (hash-table-ref/default *db-local-sync* run-id #f)) + ;; (if (> (- start-time last-write) 5) ;; every five seconds + (begin ;; let ((sync-time (- (current-seconds) start-time))) + (db:multi-db-sync (list run-id) 'new2old) + (let ((sync-time (- (current-seconds) start-time))) + (debug:print-info 3 *default-log-port* "Sync of newdb to olddb for run-id " run-id " completed in " sync-time " seconds") + (if (common:low-noise-print 30 "sync new to old") + (debug:print-info 0 *default-log-port* "Sync of newdb to olddb for run-id " run-id " completed in " sync-time " seconds"))) + (hash-table-delete! *db-local-sync* run-id))) + (mutex-unlock! *db-multi-sync-mutex*)) + run-ids-to-process))) + +(define (common:watchdog) + (thread-sleep! 0.05) ;; delay for startup + (let ((legacy-sync (common:legacy-sync-required)) + (debug-mode (debug:debug-mode 1)) + (last-time (current-seconds))) + (if (or (common:legacy-sync-recommended) + legacy-sync) + (let loop () + ;; sync for filesystem local db writes + ;; + (let ((start-time (current-seconds))) + (common:sync-to-megatest.db 'local-sync-flags) + (if (and debug-mode + (> (- start-time last-time) 60)) + (begin + (set! last-time start-time) + (debug:print-info 4 *default-log-port* "timestamp -> " (seconds->time-string (current-seconds)) ", time since start -> " (seconds->hr-min-sec (- (current-seconds) *time-zero*)))))) + + ;; keep going unless time to exit + ;; + (if (not *time-to-exit*) + (let delay-loop ((count 0)) + (if (and (not *time-to-exit*) + (< count 4)) ;; was 11, changing to 4. + (begin + (thread-sleep! 1) + (delay-loop (+ count 1)))) + (loop))) + (if (common:low-noise-print 30) + (debug:print-info 0 *default-log-port* "Exiting watchdog timer, *time-to-exit* = " *time-to-exit*)))))) + (define (std-exit-procedure) (let ((no-hurry (if *time-to-exit* ;; hurry up #f (begin (set! *time-to-exit* #t) @@ -563,10 +630,31 @@ (pathname-directory (pathname-directory (pathname-directory exe-path)))) #f))) +;; return first path that can be created or already exists and is writable +;; +(define (common:get-create-writeable-dir dirs) + (if (null? dirs) + #f + (let loop ((hed (car dirs)) + (tal (cdr dirs))) + (let ((res (or (and (directory? hed) + (file-write-access? hed) + hed) + (handle-exceptions + exn + #f + (create-directory hed #t))))) + (if (and (string? res) + (directory? res)) + res + (if (null? tal) + #f + (loop (car tal)(cdr tal)))))))) + ;;====================================================================== ;; T A R G E T S , S T A T E , S T A T U S , ;; R U N N A M E A N D T E S T P A T T ;;====================================================================== Index: dashboard-tests.scm ================================================================== --- dashboard-tests.scm +++ dashboard-tests.scm @@ -17,12 +17,12 @@ (require-library iup) (import (prefix iup iup:)) (use canvas-draw) -(use sqlite3 srfi-1 posix regex regex-case srfi-69) -(import (prefix sqlite3 sqlite3:)) +(use srfi-1 posix regex regex-case srfi-69) +(use (prefix sqlite3 sqlite3:)) (declare (unit dashboard-tests)) (declare (uses common)) (declare (uses db)) (declare (uses gutils)) Index: dashboard.scm ================================================================== --- dashboard.scm +++ dashboard.scm @@ -53,10 +53,11 @@ 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 ")) @@ -81,11 +82,11 @@ "-use-server" "-guimonitor" "-main" "-v" "-q" - "-use-local" + "-use-db-cache" "-skip-version-check" "-repl" ) args:arg-hash 0)) @@ -104,10 +105,19 @@ ;; (if (not (launch:setup)) (begin (print "Failed to find megatest.config, exiting") (exit 1))) + +;; create a watch dog to move changes from lt/.db/*.db to megatest.db +;; +(if (file-write-access? (conc *toppath* "/megatest.db")) + (thread-start! (make-thread common:watchdog "Watchdog thread")) + (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)))) ;; data common to all tabs goes here ;; (defstruct dboard:commondat ((curr-tab-num 0) : number) @@ -248,10 +258,11 @@ ((status-ignore-hash (make-hash-table)) : hash-table) ;; hash of STATUS => #t/#f (target #f) (test-patts #f) ;; db info to file the .db files for the area + (access-mode (db:get-access-mode)) ;; use cached db or not (dbdir #f) (dbfpath #f) (dbkeys #f) ((last-db-update (make-hash-table)) : hash-table) ;; last db file timestamp (monitor-db-path #f) ;; where to find monitor.db @@ -261,11 +272,11 @@ ((num-tests 10) : number) ;; total number of tests to show (used in the old runs display) ;; runs tree ((path-run-ids (make-hash-table)) : hash-table) ;; path (target / runname) => id (runs-tree #f) - ((runs-tree-ht (make-hash-table)) : hash-table) ;; track which targests added to tree (merge functionality with path-run-ids?) + ((runs-tree-ht (make-hash-table)) : hash-table) ;; track which targets added to tree (merge functionality with path-run-ids?) ;; tab data ((view-changed #t) : boolean) ((xadj 0) : number) ;; x slider number (if using canvas) ((yadj 0) : number) ;; y slider number (if using canvas) @@ -304,11 +315,11 @@ (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-keys-set! tabdat (db:dispatch-query (db:get-access-mode) rmt:get-keys db:get-keys)) (dboard:tabdat-dbkeys-set! tabdat (append (dboard:tabdat-keys tabdat) (list "runname"))) (dboard:tabdat-tot-runs-set! tabdat (rmt:get-num-runs "%")) ) ;; RADT => Matrix defstruct addition @@ -479,11 +490,12 @@ ;; 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* ((num-to-get + (let* ((access-mode (dboard:tabdat-access-mode tabdat)) + (num-to-get (let ((num-tests-from-config (configf:lookup *configdat* "setup" "num-tests-to-get"))) (if num-tests-from-config (begin (BB> "override num-tests 100 -> "num-tests-from-config) (string->number num-tests-from-config)) @@ -516,21 +528,22 @@ (db-pth (conc db-dir "/" run-id ".db"))) (dboard:rundat-db-path-set! run-dat db-pth) db-pth))) (tmptests (if (or do-not-use-db-file-timestamps (>= (common:lazy-modification-time db-path) last-update)) - (rmt:get-tests-for-run run-id testnamepatt states statuses ;; run-id testpatt states statuses - (dboard:rundat-run-data-offset run-dat) - num-to-get - (dboard:tabdat-hide-not-hide tabdat) ;; no-in - sort-by ;; sort-by - sort-order ;; sort-order - #f ;; 'shortlist ;; qrytype - (if (dboard:tabdat-filters-changed tabdat) - 0 - last-update) ;; last-update - *dashboard-mode*) ;; use dashboard mode + (db:dispatch-query access-mode rmt:get-tests-for-run db:get-tests-for-run + run-id testnamepatt states statuses ;; run-id testpatt states statuses + (dboard:rundat-run-data-offset run-dat) + num-to-get + (dboard:tabdat-hide-not-hide tabdat) ;; no-in + sort-by ;; sort-by + sort-order ;; sort-order + #f ;; 'shortlist ;; qrytype + (if (dboard:tabdat-filters-changed tabdat) + 0 + last-update) ;; last-update + *dashboard-mode*) ;; use dashboard mode '())) (use-new (dboard:tabdat-hide-not-hide tabdat)) (tests-ht (if (dboard:tabdat-filters-changed tabdat) (let ((ht (make-hash-table))) (dboard:rundat-tests-set! run-dat ht) @@ -592,15 +605,18 @@ ;; ;; create a virtual table of all the tests ;; keypatts: ( (KEY1 "abc%def")(KEY2 "%") ) ;; (define (update-rundat tabdat runnamepatt numruns testnamepatt keypatts) - (let* ((keys (rmt:get-keys)) + (let* ((access-mode (dboard:tabdat-access-mode tabdat)) + (keys (db:dispatch-query access-mode rmt:get-keys db:get-keys)) (last-runs-update (dboard:tabdat-last-runs-update tabdat)) - (allruns (rmt:get-runs runnamepatt numruns (dboard:tabdat-start-run-offset tabdat) keypatts)) + (allruns (db:dispatch-query access-mode rmt:get-runs db: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-tree (db:dispatch-query access-mode rmt:get-runs-by-patt db:get-runs-by-patt + 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))) @@ -1476,11 +1492,13 @@ (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* ((tdat (if run-id (rmt:get-tests-for-run run-id + (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 @@ -1507,20 +1525,22 @@ (if (and res (> (length res) 1)) (cadr res) #f))) (define (dboard:update-tree tabdat runs-hash runs-header tb) - (let* ((run-ids (sort (filter number? (hash-table-keys runs-hash)) + (let* ((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 (rmt:get-runs-by-patt (dboard:tabdat-keys tabdat) "%" #f #f #f #f last-runs-update))) + (runs-dat (db:dispatch-query access-mode rmt:get-runs-by-patt db:get-runs-by-patt + (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))) @@ -1585,12 +1605,14 @@ hide-clean: hide-clean) #f))) (define (dashboard:get-runs-hash tabdat) - (let* ((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)) + (let* ((access-mode (dboard:tabdat-access-mode tabdat)) + (last-runs-update 0);;(dboard:tabdat-last-runs-update tabdat)) + (runs-dat (db:dispatch-query access-mode rmt:get-runs-by-patt db: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 (let ((ht (make-hash-table))) (for-each (lambda (run) @@ -1602,11 +1624,13 @@ (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-dat (db:dispatch-query (dboard:tabdat-access-mode tabdat) + rmt:get-runs-by-patt db: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))) @@ -2577,18 +2601,19 @@ ;; Force creation of the db in case it isn't already there. (tasks:open-db) (define (dashboard:get-youngest-run-db-mod-time tabdat) - (handle-exceptions - exn - (begin - (debug:print 0 *default-log-port* "WARNING: error in accessing databases in get-youngest-run-db-mod-time: " ((condition-property-accessor 'exn 'message) exn)) - (current-seconds)) ;; something went wrong - just print an error and return current-seconds - (common:max (map (lambda (filen) - (file-modification-time filen)) - (glob (conc (dboard:tabdat-dbdir tabdat) "/*.db*")))))) + (let ((dbpath (dboard:tabdat-dbdir tabdat))) + (handle-exceptions + exn + (begin + (debug:print 0 *default-log-port* "WARNING: error in accessing databases in get-youngest-run-db-mod-time: " ((condition-property-accessor 'exn 'message) exn)) + (current-seconds)) ;; something went wrong - just print an error and return current-seconds + (common:max (map (lambda (filen) + (file-modification-time filen)) + (glob (conc (dboard:tabdat-dbdir tabdat) "/*.db*"))))))) (define (dashboard:monitor-changed? commondat tabdat) (let* ((run-update-time (current-seconds)) (monitor-db-path (dboard:tabdat-monitor-db-path tabdat)) (monitor-modtime (if (and monitor-db-path (file-exists? monitor-db-path)) @@ -2712,12 +2737,15 @@ (db:test-get-event_time (hash-table-ref testsdat (car b)))))))))) ;; run times tab data updater ;; (define (dashboard:run-times-tab-run-data-updater commondat tabdat tab-num) - (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)) + (let* ((access-mode (dboard:tabdat-access-mode tabdat)) + (last-runs-update (dboard:tabdat-last-runs-update tabdat)) + (runs-dat (db:dispatch-query access-mode + rmt:get-runs-by-patt db: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)) Index: db.scm ================================================================== --- db.scm +++ db.scm @@ -182,11 +182,11 @@ ;; open an sql database inside a file lock ;; returns: db existed-prior-to-opening ;; RA => Returns a db handler; sets the lock if opened in writable mode ;; (define (db:lock-create-open fname initproc) - (let* ((parent-dir (pathname-directory fname)) + (let* ((parent-dir (or (pathname-directory fname)(current-directory))) ;; no parent? go local (dir-writable (file-write-access? parent-dir)) (file-exists (file-exists? fname)) (file-write (if file-exists (file-write-access? fname) dir-writable ))) @@ -284,12 +284,14 @@ (set! *dbstruct-db* dbstruct) dbstruct))) ;; Open the classic megatest.db file (defaults to open in toppath) ;; -(define (db:open-megatest-db #!key (dbdir #f)) - (let* ((dbpath (conc (or dbdir *toppath*) "/megatest.db")) +;; NOTE: returns a dbdat not a dbstruct! +;; +(define (db:open-megatest-db #!key (path #f)) + (let* ((dbpath (or path (conc *toppath* "/megatest.db"))) (dbexists (file-exists? dbpath)) (db (db:lock-create-open dbpath (lambda (db) (db:initialize-main-db db) (db:initialize-run-id-db db)))) @@ -545,11 +547,15 @@ #t)))))) ;; tbls is ( ("tablename" ( "field1" [#f|proc1] ) ( "field2" [#f|proc2] ) .... ) ) ;; db's are dbdat's ;; -(define (db:sync-tables tbls fromdb todb . slave-dbs) +;; if last-update specified ("field-name" . time-in-seconds) +;; then sync only records where field-name >= time-in-seconds +;; IFF field-name exists +;; +(define (db:sync-tables tbls last-update fromdb todb . slave-dbs) (mutex-lock! *db-sync-mutex*) (handle-exceptions exn (begin (mutex-unlock! *db-sync-mutex*) @@ -593,15 +599,26 @@ (tot-count 0)) (for-each ;; table (lambda (tabledat) (let* ((tablename (car tabledat)) (fields (cdr tabledat)) + (use-last-update (if last-update + (if (pair? last-update) + (member (car last-update) ;; last-update field name + (map car fields)) + (begin + (debug:print 0 *default-log-port* "ERROR: parameter last-update for db:sync-tables must be a pair, received: " last-update) ;; found in fields + #f)) + #f)) (num-fields (length fields)) (field->num (make-hash-table)) (num->field (apply vector (map car fields))) (full-sel (conc "SELECT " (string-intersperse (map car fields) ",") - " FROM " tablename ";")) + " FROM " tablename (if use-last-update ;; apply last-update criteria + (conc " " (car last-update) ">=" (cdr last-update)) + "") + ";")) (full-ins (conc "INSERT OR REPLACE INTO " tablename " ( " (string-intersperse (map car fields) ",") " ) " " VALUES ( " (string-intersperse (make-list num-fields "?") ",") " );")) (fromdat '()) (fromdats '()) (totrecords 0) @@ -674,11 +691,12 @@ fromdats) (sqlite3:finalize! stmth))) (append (list todb) slave-dbs)))) tbls) (let* ((runtime (- (current-milliseconds) start-time)) - (should-print (common:low-noise-print 120 "db sync" (> runtime 500)))) ;; low and high sync times treated as separate. + (should-print (or (debug:debug-mode 12) + (common:low-noise-print 120 "db sync" (> runtime 500))))) ;; low and high sync times treated as separate. (if should-print (debug:print 3 *default-log-port* "INFO: db sync, total run time " runtime " ms")) (for-each (lambda (dat) (let ((tblname (car dat)) (count (cdr dat))) @@ -750,19 +768,85 @@ FOR EACH ROW BEGIN UPDATE run_stats SET last_update=(strftime('%s','now')) WHERE id=old.id; END;")) + +(define *global-db-store* (make-hash-table)) + +(define (db:get-access-mode) + (if (args:get-arg "-use-db-cache") 'cached 'rmt)) + +;; Add db direct +;; +(define (db:dispatch-query access-mode rmt-cmd db-cmd . params) + (if (eq? access-mode 'cached) + (apply db:call-with-cached-db db-cmd params) + (apply rmt-cmd params))) + +;; return the target db handle so it can be used +;; +(define (db:cache-for-read-only source target #!key (use-last-update #f)) + (if (and (hash-table-ref/default *global-db-store* target #f) + (>= (file-modification-time target)(file-modification-time source))) + (hash-table-ref *global-db-store* target) + (let* ((toppath (launch:setup)) + (targ-db-last-mod (if (file-exists? target) + (file-modification-time target) + 0)) + (cache-db (or (hash-table-ref/default *global-db-store* target #f) + (db:open-megatest-db path: target))) + (source-db (db:open-megatest-db path: source)) + (curr-time (current-seconds)) + (res '()) + (last-update (if use-last-update (cons "last_update" targ-db-last-mod) #f))) + (db:sync-tables (db:sync-main-list source-db) last-update source-db cache-db) + (db:sync-tables db:sync-tests-only last-update source-db cache-db) + (hash-table-set! *global-db-store* target cache-db) + cache-db))) + +;; call a proc with a cached db +;; +(define (db:call-with-cached-db proc . params) + ;; first cache the db in /tmp + (let* ((cname-part (conc "megatest_cache/" (common:get-testsuite-name))) + (fname (conc (common:get-area-path-signature) ".db")) + (cache-dir (common:get-create-writeable-dir + (list (conc "/tmp/" (current-user-name) "/" cname-part) + (conc "/tmp/" (current-user-name) "-" cname-part) + (conc "/tmp/" (current-user-name) "_" cname-part)))) + (megatest-db (conc *toppath* "/megatest.db"))) + ;; (debug:print-info 0 *default-log-port* "Using cache dir " cache-dir) + (if (not cache-dir) + (begin + (debug:print 0 *default-log-port* "ERROR: Failed to find an area to write the cache db") + (exit 1)) + (let* ((th1 (make-thread + (lambda () + (if (and (file-exists? megatest-db) + (file-write-access? megatest-db)) + (begin + (common:sync-to-megatest.db 'timestamps) ;; internally mutexes on *db-local-sync* + (debug:print-info 2 *default-log-port* "Done syncing to megatest.db")))) + "call-with-cached-db sync-to-megatest.db")) + (cache-db (db:cache-for-read-only + megatest-db + (conc cache-dir "/" fname) + use-last-update: #t))) + (thread-start! th1) + (apply proc cache-db params) + )))) ;; options: ;; ;; 'killservers - kills all servers ;; 'dejunk - removes junk records ;; 'adj-testids - move test-ids into correct ranges ;; 'old2new - sync megatest.db records to .db/{main,1,2 ...}.db ;; 'new2old - sync .db/{main,1,2,3 ...}.db to megatest.db ;; 'closeall - close all opened dbs +;; 'schema - attempt to apply schema changes ;; ;; run-ids: '(1 2 3 ...) or #f (for all) ;; (define (db:multi-db-sync run-ids . options) (if (not (launch:setup)) @@ -835,11 +919,11 @@ ;; (lambda (run-id) ;; (thread-start! ;; (make-thread ;; (lambda () ;; (let* ((fromdb (if toppath (make-dbr:dbstruct path: toppath local: #t) #f)) - ;; (frundb (db:dbdat-get-db (db:get-db fromdb run-id)))) +;; (if (member 'schema options) ;; (if (eq? run-id 0) ;; (let ((maindb (db:dbdat-get-db (db:get-db fromdb #f)))) ;; (db:patch-schema-maindb run-id maindb)) ;; (db:patch-schema-rundb run-id frundb))) ;; (set! count (+ count 1)) @@ -859,15 +943,15 @@ ;; (lambda () ;; (let* ((fromdb (if toppath (make-dbr:dbstruct path: toppath local: #t) #f)) ;; (frundb (db:dbdat-get-db (db:get-db fromdb run-id)))) ;; (if (eq? run-id 0) ;; (let ((maindb (db:dbdat-get-db (db:get-db fromdb #f)))) - ;; (db:sync-tables (db:sync-main-list dbstruct) (db:get-db fromdb #f) mtdb) +;; (db:sync-tables (db:sync-main-list dbstruct) #f (db:get-db fromdb #f) mtdb) ;; (set! dead-runs (db:clean-up-maindb (db:get-db fromdb #f)))) ;; (begin ;; ;; NB// must sync first to ensure deleted tests get marked as such in megatest.db - ;; (db:sync-tables db:sync-tests-only (db:get-db fromdb run-id) mtdb) +;; (db:sync-tables db:sync-tests-only #f (db:get-db fromdb run-id) mtdb) ;; (db:clean-up-rundb (db:get-db fromdb run-id))))) ;; (set! count (+ count 1)) ;; (debug:print 0 *default-log-port* "Finished clean up of " ;; (if (eq? run-id 0) ;; " main.db " (conc run-id ".db")) ", " count " of " total))))) Index: megatest.scm ================================================================== --- megatest.scm +++ megatest.scm @@ -141,10 +141,11 @@ -start-dir path : switch to this directory before running megatest -rebuild-db : bring the database schema up to date -cleanup-db : remove any orphan records, vacuum the db -import-megatest.db : migrate a database from v1.55 series to v1.60 series -sync-to-megatest.db : migrate data back to megatest.db + -use-db-cache : use cached access to db to reduce load -update-meta : update the tests metadata for all tests -setvars VAR1=val1,VAR2=val2 : Add environment variables to a run NB// these are overwritten by values set in config files. -server -|hostname : start the server (reduces contention on megatest.db), use - to automatically figure out hostname @@ -259,12 +260,14 @@ "-archive" "-since" "-fields" "-recover-test" ;; run-id,test-id - used internally to recover a test stuck in RUNNING state "-sort" - ) - (list "-h" "-help" "--help" + "-target-db" + "-source-db" + ) + (list "-h" "-help" "--help" "-manual" "-version" "-force" "-xterm" "-showkeys" @@ -277,11 +280,12 @@ "-daemonize" "-preclean" "-rerun-clean" "-rerun-all" "-clean-cache" - + "-cache-db" + "-use-db-cache" ;; misc "-repl" "-lock" "-unlock" "-list-servers" @@ -351,31 +355,12 @@ (last-time (current-seconds))) (if (common:legacy-sync-recommended) (let loop () ;; sync for filesystem local db writes ;; - (let ((start-time (current-seconds)) - (servers-started (make-hash-table))) - (for-each - (lambda (run-id) - (mutex-lock! *db-multi-sync-mutex*) - (if (and legacy-sync - (hash-table-ref/default *db-local-sync* run-id #f)) - ;; (if (> (- start-time last-write) 5) ;; every five seconds - (begin ;; let ((sync-time (- (current-seconds) start-time))) - (db:multi-db-sync (list run-id) 'new2old) - (let ((sync-time (- (current-seconds) start-time))) - (debug:print-info 3 *default-log-port* "Sync of newdb to olddb for run-id " run-id " completed in " sync-time " seconds") - (if (common:low-noise-print 30 "sync new to old") - (debug:print-info 0 *default-log-port* "Sync of newdb to olddb for run-id " run-id " completed in " sync-time " seconds"))) - ;; (if (> sync-time 10) ;; took more than ten seconds, start a server for this run - ;; (begin - ;; (debug:print-info 0 *default-log-port* "Sync is taking a long time, start up a server to assist for run " run-id) - ;; (server:kind-run run-id))))) - (hash-table-delete! *db-local-sync* run-id))) - (mutex-unlock! *db-multi-sync-mutex*)) - (hash-table-keys *db-local-sync*)) + (let ((start-time (current-seconds))) + (if legacy-sync (common:sync-to-megatest.db #f)) (if (and debug-mode (> (- start-time last-time) 60)) (begin (set! last-time start-time) (debug:print-info 4 *default-log-port* "timestamp -> " (seconds->time-string (current-seconds)) ", time since start -> " (seconds->hr-min-sec (- (current-seconds) *time-zero*)))))) @@ -480,10 +465,18 @@ (on-exit std-exit-procedure) ;;====================================================================== ;; Misc general calls ;;====================================================================== + +(if (and (args:get-arg "-cache-db") + (args:get-arg "-source-db")) + (let* ((temp-dir (or (args:get-arg "-target-db") (create-directory (conc "/tmp/" (getenv "USER") "/" (string-translate (current-directory) "/" "_"))))) + (target-db (conc temp-dir "/cached.db")) + (source-db (args:get-arg "-source-db"))) + (db:cache-for-read-only source-db target-db) + (set! *didsomething* #t))) ;; handle a clean-cache request as early as possible ;; (if (args:get-arg "-clean-cache") (begin @@ -1038,11 +1031,11 @@ (define (get-value-by-fieldname datavec test-field-index fieldname) (let ((indx (hash-table-ref/default test-field-index fieldname #f))) (if indx (if (>= indx (vector-length datavec)) - #f ;; index to high, should raise an error I suppose + #f ;; index too high, should raise an error I suppose (vector-ref datavec indx)) #f))) ;; NOTE: list-runs and list-db-targets operate on local db!!! ;; @@ -1051,18 +1044,21 @@ (if (or (args:get-arg "-list-runs") (args:get-arg "-list-db-targets")) (if (launch:setup) (let* (;; (dbstruct (make-dbr:dbstruct path: *toppath* local: (args:get-arg "-local"))) (runpatt (args:get-arg "-list-runs")) + (access-mode (db:get-access-mode)) (testpatt (common:args-get-testpatt #f)) ;; (if (args:get-arg "-testpatt") ;; (args:get-arg "-testpatt") ;; "%")) (keys (rmt:get-keys)) ;; (db:get-keys dbstruct)) - ;; (runsda t (db:get-runs dbstruct runpatt #f #f '())) - (runsdat (rmt:get-runs-by-patt keys (or runpatt "%") (common:args-get-target) ;; (db:get-runs-by-patt dbstruct keys (or runpatt "%") (common:args-get-target) - #f #f '("id" "runname" "state" "status" "owner" "event_time" "comment") 0)) + ;; (runsdat (db:get-runs dbstruct runpatt #f #f '())) + ;; (runsdat (rmt:get-runs-by-patt keys (or runpatt "%") (common:args-get-target) ;; (db:get-runs-by-patt dbstruct keys (or runpatt "%") (common:args-get-target) + ;; #f #f '("id" "runname" "state" "status" "owner" "event_time" "comment") 0)) + (runsdat (db:dispatch-query access-mode rmt:get-runs-by-patt db:get-runs-by-patt keys (or runpatt "%") + (common:args-get-target) #f #f '("id" "runname" "state" "status" "owner" "event_time" "comment") 0)) (runstmp (db:get-rows runsdat)) (header (db:get-header runsdat)) ;; this is "-since" support. This looks at last mod times of .db files ;; and collects those modified since the -since time. (runs (if (and (not (null? runstmp)) @@ -1128,11 +1124,11 @@ (let* ((run-id (db:get-value-by-header run header "id")) (runname (db:get-value-by-header run header "runname")) (states (string-split (or (args:get-arg "-state") "") ",")) (statuses (string-split (or (args:get-arg "-status") "") ",")) (tests (if tests-spec - (rmt:get-tests-for-run run-id testpatt states statuses #f #f #f 'testname 'asc ;; (db:get-tests-for-run dbstruct run-id testpatt '() '() #f #f #f 'testname 'asc + (db:dispatch-query access-mode rmt:get-tests-for-run db:get-tests-for-run run-id testpatt states statuses #f #f #f 'testname 'asc ;; (db:get-tests-for-run dbstruct run-id testpatt '() '() #f #f #f 'testname 'asc ;; use qryvals if test-spec provided (if tests-spec (string-intersperse adj-tests-spec ",") ;; db:test-record-fields #f) @@ -1253,11 +1249,11 @@ ;; "\n rundir: " (get-value-by-fieldname test test-field-index "") ;; (sdb:qry 'getstr ;; (filedb:get-path *fdb* ;; (db:test-get-rundir test) ;; ) ) ;; Each test ;; DO NOT remote run - (let ((steps (rmt:get-steps-for-test run-id (db:test-get-id test)))) ;; (db:get-steps-for-test dbstruct run-id (db:test-get-id test)))) + (let ((steps (db:dispatch-query access-mode rmt:get-steps-for-test db:get-steps-for-test run-id (db:test-get-id test)))) ;; (db:get-steps-for-test dbstruct run-id (db:test-get-id test)))) (for-each (lambda (step) (format #t " Step: ~20a State: ~10a Status: ~10a Time ~22a\n" (tdb:step-get-stepname step) Index: rmt.scm ================================================================== --- rmt.scm +++ rmt.scm @@ -215,18 +215,27 @@ (loop (car tal)(cdr tal) newmax-cmd currmax))))))) (mutex-unlock! *db-stats-mutex*) res)) (define (rmt:open-qry-close-locally cmd run-id params #!key (remretries 5)) - (let* ((dbstruct-local (db:open-local-db-handle)) + (let* ((qry-is-write (not (member cmd api:read-only-queries))) (db-file-path (db:dbfile-path)) ;; 0)) - ;; (read-only (not (file-read-access? db-file-path))) + (dbstruct-local (if *dbstruct-db* + *dbstruct-db* + (let* ((db (make-dbr:dbstruct path: dbdir local: #t))) + (set! *dbstruct-db* db) + db))) + (read-only (not (file-write-access? dbdir))) (start (current-milliseconds)) - (resdat (api:execute-requests dbstruct-local (vector (symbol->string cmd) params))) + (resdat (if (not (and read-only qry-is-write)) + (api:execute-requests dbstruct-local (vector (symbol->string cmd) params)) + (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 @@ -235,18 +244,16 @@ (debug:print-error 0 *default-log-port* "too many retries in rmt:open-qry-close-locally, giving up") #f)) (begin ;; (rmt:update-db-stats run-id cmd params duration) ;; mark this run as dirty if this was a write - (if (not (member cmd api:read-only-queries)) + (if qry-is-write (let ((start-time (current-seconds))) (mutex-lock! *db-multi-sync-mutex*) - ;; (if (not (hash-table-ref/default *db-local-sync* run-id #f)) - ;; just set it every time. Is a write more expensive than a read and does it matter? (hash-table-set! *db-local-sync* (or run-id 0) start-time) ;; the oldest "write" - (mutex-unlock! *db-multi-sync-mutex*))) - res)))) + (mutex-unlock! *db-multi-sync-mutex*))))) + res)) (define (rmt:send-receive-no-auto-client-setup connection-info cmd run-id params) (let* ((run-id (if run-id run-id 0)) ;; (jparams (db:obj->string params)) ;; (rmt:dat->json-str params)) (res (handle-exceptions Index: tests/fullrun/megatest.config ================================================================== --- tests/fullrun/megatest.config +++ tests/fullrun/megatest.config @@ -44,10 +44,14 @@ # Set launchwait to no to use the more agressive code that does not wait for the launch to complete before proceeding # this may save a few milliseconds on launching tests # launchwait no waivercommentpatt ^WW\d+ [a-z].* incomplete-timeout 1 + +# wait 25 seconds between launching every process +# +launch-delay 25 # wait for runs to completely complete. yes, anything else is no run-wait yes # If set to "default" the old code is used. Otherwise defaults to 200 or uses