Index: common.scm ================================================================== --- common.scm +++ common.scm @@ -133,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) @@ -635,27 +635,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 dbstruct) + (if (and dbstruct (dbr:dbstruct-tmpdb-path dbstruct)) ;; *db-cache-path* + (dbr:dbstruct-tmpdb-path) ;; *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) Index: dashboard-areas.scm ================================================================== --- dashboard-areas.scm +++ dashboard-areas.scm @@ -406,28 +406,41 @@ ;; (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-db areas (car area-dat)(cdr area-dat))) + areas))) + + (define (dboard:areas-update-tree tabdat runs-hash runs-header tb) - (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 (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)) + (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))) @@ -435,34 +448,35 @@ (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 - + ;;(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 run-id tabdat runs-hash) (let* ((run (hash-table-ref/default runs-hash run-id #f)) (key-vals (mrmt:get-key-vals run-id)) (testnamepatt (or (dboard:tabdat-test-patts tabdat) "%/%")) (tests-ht (dboard:get-tests-for-run-duplicate tabdat run-id run testnamepatt key-vals)) Index: dashboard.scm ================================================================== --- dashboard.scm +++ dashboard.scm @@ -148,12 +148,12 @@ (updaters (make-hash-table)) (updating #f) uidat ;; needs to move to tabdat at some time (hide-not-hide-tabs #f) (current-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 ==> area-path - (area-dbs #f) ;; use db:dashboard-open-db to add areas to the areas hash + (areas (make-hash-table)) ;; area-name ==> dbstruct + ;; (area-dbs #f) ;; use db:dashboard-open-db to add areas to the areas hash ) ;; 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)) @@ -342,13 +342,13 @@ (dboard:setup-tabdat 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")) + ;; (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. (if #f (dboard:tabdat-ro-set! tabdat (not (file-read-access? (dboard:tabdat-dbfpath tabdat)))) (print "FIXME on line 350")) Index: db.scm ================================================================== --- db.scm +++ db.scm @@ -52,10 +52,12 @@ (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 @@ -74,35 +76,40 @@ ;; 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 areas => dbstruct, the dashboard-open-db will register the dbstruct in that hash +;; 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 ;; -(define (db:dashboard-open-db areas area-path) + +;; 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-db 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-path) - (hash-table-ref areas area-path) + (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-path dbstruct) + (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)))) @@ -141,20 +148,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))) @@ -352,17 +356,20 @@ ;; ;;; (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 -;; +;; 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* ((toppath (or area-path (dbr:dbstruct-area-path dbstruct) *toppath*)) - (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"))) @@ -1922,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) @@ -2172,11 +2179,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: mrmt.scm ================================================================== --- mrmt.scm +++ mrmt.scm @@ -341,11 +341,11 @@ (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)) ;; 0)) + (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))))