Index: dashboard.scm
==================================================================
--- dashboard.scm
+++ dashboard.scm
@@ -26,10 +26,11 @@
(use canvas-draw)
(import canvas-draw-iup)
(use ducttape-lib)
(use sqlite3 srfi-1 posix regex regex-case srfi-69 typed-records sparse-vectors) ;; defstruct
(import (prefix sqlite3 sqlite3:))
+(import dbfile)
(declare (uses common))
(declare (uses margs))
(declare (uses keys))
(declare (uses items))
@@ -45,18 +46,21 @@
(declare (uses dashboard-context-menu))
(declare (uses vg))
(declare (uses subrun))
;; (declare (uses dashboard-main))
(declare (uses mt))
+(declare (uses dbfile))
(include "common_records.scm")
(include "db_records.scm")
(include "run_records.scm")
(include "task_records.scm")
(include "megatest-version.scm")
(include "megatest-fossil-hash.scm")
(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
Index: db.scm
==================================================================
--- db.scm
+++ db.scm
@@ -275,82 +275,10 @@
(exn (busy) (debug:print 0 *default-log-port* "ERROR: database " fname " is locked. Try copying to another location, remove original and copy back."))
(exn (permission)(debug:print 0 *default-log-port* "ERROR: database " fname " has some permissions problem."))
(exn () (debug:print 0 *default-log-port* "ERROR: Unknown error with database " fname " message: " ((condition-property-accessor 'exn 'message) exn))))
)))
-;; 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 run-id #!key (areapath #f)(do-sync #t))
- (let* ((subdb (dbfile:get-subdb dbstruct run-id))
- (tmpdb-stack (dbr:subdb-dbstack subdb)))
- (if (stack? tmpdb-stack)
- (db:get-subdb tmpdb-stack run-id) ;; get previously opened db (will create new db handle if all in the stack are already used
- (let* ((max-stale-tmp (configf:lookup-number *configdat* "server" "filling-db-max-stale-seconds" default: 10))
- (dbpath (db:dbfile-path)) ;; path to tmp db area
- (dbname (db:run-id->dbname run-id))
- (dbexists (common:file-exists? dbpath))
- (mtdbfname (conc *toppath* "/"dbname))
- (mtdbexists (common:file-exists? mtdbfname))
- (mtdbmodtime (if mtdbexists (common:lazy-sqlite-db-modification-time mtdbfname) #f))
- (mtdb (db:open-megatest-db mtdbfname))
- ;; the reference db for syncing
- (refdbfname (conc dbpath "/"dbname"_ref"))
- (refndb (db:open-megatest-db refdbfname))
- ;; (mtdbpath (dbr:dbdat-dbfile mtdb))
- ;; the tmpdb
- (tmpdbfname (conc dbpath"/"dbname)) ;; /tmp/<stuff>/.db/[main|1,2...].db
- (tmpdb (db:open-megatest-db tmpdbfname)) ;; lock-create-open dbpath db:initialize-main-db))
- (dbfexists (common:file-exists? tmpdbfname)) ;; (conc dbpath "/megatest.db")))
- (tmpdbmodtime (if dbfexists (common:lazy-sqlite-db-modification-time tmpdbfname) #f))
-
- (write-access (file-write-access? mtdbfname))
-
- ;; (mtdbmodtime (if mtdbexists
- ;; (common:lazy-sqlite-db-modification-time mtdbpath)
- ;; #f)) ; moving this before db:open-megatest-db is
- ;; called. if wal mode is on -WAL and -shm file get
- ;; created with causing the tmpdbmodtime timestamp
- ;; always greater than mtdbmodtime (tmpdbmodtime (if
- ;; dbfexists (common:lazy-sqlite-db-modification-time
- ;; tmpdbfname) #f)) if wal mode is on -WAL and -shm
- ;; file get created when db:open-megatest-db is
- ;; called. modtimedelta will always be < 10 so db in
- ;; tmp not get synced (tmpdbmodtime (if dbfexists
- ;; (db:get-last-update-time (car tmpdb)) #f)) (fmt
- ;; (file-modification-time tmpdbfname))
-
- (modtimedelta (and mtdbmodtime tmpdbmodtime (- mtdbmodtime tmpdbmodtime))))
-
- (when write-access
- (sqlite3:execute (dbr:dbdat-dbh mtdb) "drop trigger if exists update_tests_trigger")
- (sqlite3:execute (dbr:dbdat-dbh mtdb) "drop trigger if exists update_runs_trigger"))
-
- ;; (print "mtdbmodtime " mtdbmodtime " tmpdbmodtime " tmpdbmodtime " mtdbpath " mtdbpath " " (conc *toppath* "/megatest.db"))
- ;; (debug:print-info 13 *default-log-port* "db:open-db>> mtdbpath="mtdbpath" mtdbexists="mtdbexists" and write-access="write-access)
- (if (and dbexists (not write-access))
- (begin
- (set! *db-write-access* #f)
- (dbr:subdb-read-only-set! subdb #t)))
- (dbr:subdb-mtdb-set! subdb mtdb)
- (dbr:subdb-tmpdb-set! subdb tmpdb)
- (dbr:subdb-dbstack-set! subdb (make-stack)) ;; BB: why a stack? Why would the number of db's be indeterminate? Is this a legacy of 1.db 2.db .. ?
- (stack-push! (dbr:subdb-dbstack subdb) tmpdb) ;; olddb is already a (cons db path)
- (dbr:subdb-refndb-set! subdb refndb)
- (if (and (or (not dbfexists)
- (and modtimedelta
- (> modtimedelta max-stale-tmp))) ;; if db in tmp is over ten seconds older than the file in MTRA then do a sync back
- do-sync)
- (begin
- (debug:print 1 *default-log-port* "filling db " (dbr:dbdat-dbfile tmpdb) " with data \n from " (dbr:dbdat-dbfile mtdb) " mod time delta: " modtimedelta)
- (db:sync-tables (db:sync-all-tables-list subdb) #f mtdb refndb tmpdb)
- ;; touch tmp db to avoid wal mode wierdness
- (set! (file-modification-time tmpdbfname) (current-seconds))
- (debug:print-info 13 *default-log-port* "db:sync-all-tables-list done.")
- )
- (debug:print 4 *default-log-port* " db, " (dbr:dbdat-dbfile tmpdb) " already exists or fresh enough, not propogating data from\n " (dbr:dbdat-dbfile mtdb) " mod time delta: " modtimedelta) )
- ;; (db:multi-db-sync subdb 'old2new)) ;; migrate data from megatest.db automatically
- tmpdb))))
(define (db:get-last-update-time db)
(let ((last-update-time #f))
(sqlite3:for-each-row
@@ -683,15 +611,15 @@
(else
#f))))
(if do-cp
(let* ((start-time (current-milliseconds))
(fname (pathname-file file))
- (runid (if (string= fname "main") #f (string->number fname)))
+ (run-id (if (string= fname "main") #f (string->number fname)))
)
(debug:print-info 3 *default-log-port* "db:all-db-sync: fname: "
fname", delta: " (- time1 time2) " seconds")
- (db:lock-and-delta-sync no-sync-db dbstruct fname runid (db:get-keys dbstruct) db:initialize-main-db)
+ (db:lock-and-delta-sync no-sync-db dbstruct fname run-id (db:get-keys dbstruct) db:initialize-main-db)
(hash-table-set! sync-durations (conc fname".db")
(- (current-milliseconds) start-time)))
(debug:print-info 3 *default-log-port* "skipping sync. " file " is up to date")
)))
dbfiles
@@ -709,128 +637,70 @@
;; '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 dbstruct . options)
- (let* ((dbdat (db:open-db dbstruct #f))
+ (let* ((dbdat (db:open-db dbstruct #f db:initialize-main-db))
(data-synced 0) ;; count of changed records
(tmp-area (common:get-db-tmp-area))
- (dbfiles (glob (conc tmp-area"/.db/*.db")))
- (sync-durations (make-hash-table)))
- (for-each
- (lambda (file)
- (debug:print-info 0 *default-log-port* "file: " file)
- (let* ((fname (conc (pathname-file file) ".db"))
- (fulln (conc *toppath*"/.db/"fname))
- (time1 (if (file-exists? file)
- (file-modification-time file)
- (begin
- (debug:print-info 0 *default-log-port* "Sync - I do not see file "file)
- 1)))
- (time2 (if (file-exists? fulln)
- (file-modification-time fulln)
- (begin
- (debug:print-info 0 *default-log-port* "Sync - I do not see file "fulln)
+ (old2new (member 'old2new options))
+ (src-area (if old2new *toppath* tmp-area))
+ (dest-area (if old2new tmp-area *toppath*))
+ (dbfiles (glob (conc src-area"/.db/*.db")))
+ (keys (db:get-keys dbstruct))
+ (sync-durations (make-hash-table)))
+
+ (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 "/.db/" fname))
+ (time1 (file-modification-time srcfile))
+ (time2 (if (file-exists? destfile)
+ (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? fulln)) ;; shouldn't happen, but this might recover
- (debug:print-info 0 *default-log-port* "File "fulln" not found! Copying "fname" to "fulln)
+ ((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)
#t)
(changed ;; (and changed
;; (> (- (current-seconds) time1) 3)) ;; if file is changed and three seconds have passed.
#t)
((and changed *time-to-exit*) ;; last sync
#t)
(else
#f))))
- (if do-cp
- (let* ((start-time (current-milliseconds)))
- (debug:print-info 0 *default-log-port* "delta sync delta file: " fname", delta: " (- time1 time2) " seconds")
- (db:lock-and-delta-sync *no-sync-db* file fulln)
- (hash-table-set! sync-durations (conc fname".db") (- (current-milliseconds) start-time)))
- (debug:print-info 0 *default-log-port* "skipping delta sync. " file " is up to date")
- )
+ (if 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)
+ )
+
+
+ (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")
+ )
)
)
dbfiles
)
-
-
- (hash-table->alist sync-durations)
-
-
-
- (debug:print 0 *default-log-port* "db:multi-db-sync subdbs: " (hash-table-values (dbr:dbstruct-subdbs dbstruct)))
- (for-each
- (lambda (subdb)
- (let* ((mtdb (dbr:subdb-mtdbdat subdb))
- (tmpdbfile (dbr:subdb-tmpdbfile subdb))
- (main-tmpdb (dbfile:open-db dbstruct #f db:initialize-main-db))
- (allow-cleanup #t) ;; (if run-ids #f #t))
- (servers (server:get-list *toppath*)) ;; (tasks:get-all-servers (db:delay-if-busy tdbdat)))
- )
- (debug:print 0 *default-log-port* "db:multi-db-sync mtdb: " mtdb " tmpdbfile:" tmpdbfile )
- (for-each
- (lambda (option)
-
- (case option
- ;; kill servers
- ((killservers)
- (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)
-
- ;; /tmp/bjbarcla/megatest_localdb/fullrun/.nfs.pdx.disks.icf_env_disk001.bjbarcla.gwa.issues.mtdev.matt-bisect.megatest.ext-tests.runs.all.v1.65.1.6524.dev.bb-24-justrollup-f8.rollup.fullrun/megatest.db.lock
- (delete-file* (common:get-sync-lock-filepath)))
-
- ;; clear out junk records
- ;;
- ((dejunk)
- ;; (db:delay-if-busy mtdb) ;; ok to delay on mtdb
- (when (file-write-access? (dbr:dbdat-dbfile mtdb)) (db:clean-up mtdb))
- (db:clean-up main-tmpdb)
- )
- ;; sync from main dbs to /tmp ones.
- ;;
- ((old2new)
- (set! data-synced
- (+ (db:sync-tables (db:sync-all-tables-list dbstruct) #f mtdb main-tmpdb)
- data-synced)))
-
- ;; sync from /tmp dbs to main ones.
- ;;
- ((new2old)
- (set! data-synced
- (+ (db:sync-tables (db:sync-all-tables-list dbstruct) #f main-tmpdb mtdb)
- data-synced)))
-
- ((adj-target)
- (db:adj-target (dbr:dbdat-dbh mtdb))
- (db:adj-target (dbr:dbdat-dbh main-tmpdb))
- )
-
- ((schema)
- (db:patch-schema-maindb (dbr:dbdat-dbh mtdb))
- (db:patch-schema-maindb (dbr:dbdat-dbh main-tmpdb))
- (db:patch-schema-rundb (dbr:dbdat-dbh mtdb))
- (db:patch-schema-rundb (dbr:dbdat-dbh main-tmpdb))
- )
- )
- (dbfile:add-dbdat dbstruct #f main-tmpdb))
- options)))
- (hash-table-values (dbr:dbstruct-subdbs dbstruct)))
- (if dbdat (dbfile:add-dbdat dbstruct #f dbdat))
- data-synced)
+ data-synced
+ )
)
;; Sync all changed db's
;;
(define (db:tmp->megatest.db-sync dbstruct run-id last-update)
@@ -840,11 +710,11 @@
(lambda (subdb)
(let* ((dbname (db:run-id->dbname run-id))
(mtdb (dbr:subdb-mtdb subdb))
(tmpdb (db:get-subdb dbstruct run-id))
(refndb (dbr:subdb-refndb subdb))
- (newres (db:sync-tables (db:sync-all-tables-list dbstruct) last-update tmpdb refndb mtdb)))
+ (newres (db:sync-tables (db:sync-all-tables-list dbstruct (db:get-keys dbstruct)) last-update tmpdb refndb mtdb)))
;; (stack-push! (dbr:subdb-dbstack subdb) tmpdb)
(dbfile:add-dbdat dbstruct run-id tmpdb)
(set! res (cons newres res))))
subdbs)
res))
Index: dbfile.scm
==================================================================
--- dbfile.scm
+++ dbfile.scm
@@ -394,81 +394,10 @@
(dbfile:print-and-exit
"ERROR: Unknown error with database " fname " message: " ((condition-property-accessor 'exn 'message) exn))))
)))
-;; This routine creates the db if not already present. It is only called if the db is not already opened
-;;
-#;(define (db:init-dbstruct dbstruct run-id init-proc #!key (do-sync #t))
- (let* ((subdb (dbfile:get-subdb dbstruct run-id))
- (tmpdb-stack (dbr:subdb-dbstack subdb))
- (max-stale-tmp (dbr:dbstruct-max-stale-secs dbstruct));; (configf:lookup-number *configdat* "server" "filling-db-max-stale-seconds" default: 10))
- (dbpath (dbr:dbstruct-tmppath dbstruct)) ;; (db:dbfile-path)) ;; path to tmp db area
- (dbname (dbfile:run-id->dbname run-id))
- (dbexists (file-exists? dbpath))
- (areapath (dbr:dbstruct-areapath dbstruct))
- (mtdbfname (conc areapath "/"dbname))
- (mtdbexists (file-exists? mtdbfname))
- (mtdbmodtime (if mtdbexists (dbfile:lazy-sqlite-db-modification-time mtdbfname) #f))
- (mtdb (db:open-sqlite-db mtdbfname init-proc))
- ;; the reference db for syncing
- (refdbfname (conc dbpath "/"dbname"_ref"))
- (refndb (db:open-megatest-db refdbfname))
- ;; (mtdbpath (dbr:dbdat-dbfile mtdb))
- ;; the tmpdb
- (tmpdbfname (conc dbpath"/"dbname)) ;; /tmp/<stuff>/.db/[main|1,2...].db
- (tmpdb (db:open-megatest-db tmpdbfname)) ;; lock-create-open dbpath db:initialize-main-db))
- (dbfexists (common:file-exists? tmpdbfname)) ;; (conc dbpath "/megatest.db")))
- (tmpdbmodtime (if dbfexists (common:lazy-sqlite-db-modification-time tmpdbfname) #f))
-
- (write-access (file-write-access? mtdbfname))
-
- ;; (mtdbmodtime (if mtdbexists
- ;; (common:lazy-sqlite-db-modification-time mtdbpath)
- ;; #f)) ; moving this before db:open-megatest-db is
- ;; called. if wal mode is on -WAL and -shm file get
- ;; created with causing the tmpdbmodtime timestamp
- ;; always greater than mtdbmodtime (tmpdbmodtime (if
- ;; dbfexists (common:lazy-sqlite-db-modification-time
- ;; tmpdbfname) #f)) if wal mode is on -WAL and -shm
- ;; file get created when db:open-megatest-db is
- ;; called. modtimedelta will always be < 10 so db in
- ;; tmp not get synced (tmpdbmodtime (if dbfexists
- ;; (db:get-last-update-time (car tmpdb)) #f)) (fmt
- ;; (file-modification-time tmpdbfname))
-
- (modtimedelta (and mtdbmodtime tmpdbmodtime (- mtdbmodtime tmpdbmodtime))))
-
- (when write-access
- (sqlite3:execute (dbr:dbdat-dbh mtdb) "drop trigger if exists update_tests_trigger")
- (sqlite3:execute (dbr:dbdat-dbh mtdb) "drop trigger if exists update_runs_trigger"))
-
- ;; (print "mtdbmodtime " mtdbmodtime " tmpdbmodtime " tmpdbmodtime " mtdbpath " mtdbpath " " (conc *toppath* "/megatest.db"))
- ;; (debug:print-info 13 *default-log-port* "db:open-db>> mtdbpath="mtdbpath" mtdbexists="mtdbexists" and write-access="write-access)
- (if (and dbexists (not write-access))
- (begin
- (set! *db-write-access* #f)
- (dbr:subdb-read-only-set! subdb #t)))
- (dbr:subdb-mtdb-set! subdb mtdb)
- (dbr:subdb-tmpdb-set! subdb tmpdb)
- (dbr:subdb-dbstack-set! subdb (make-stack)) ;; BB: why a stack? Why would the number of db's be indeterminate? Is this a legacy of 1.db 2.db .. ?
- (stack-push! (dbr:subdb-dbstack subdb) tmpdb) ;; olddb is already a (cons db path)
- (dbr:subdb-refndb-set! subdb refndb)
- (if (and (or (not dbfexists)
- (and modtimedelta
- (> modtimedelta max-stale-tmp))) ;; if db in tmp is over ten seconds older than the file in MTRA then do a sync back
- do-sync)
- (begin
- (dbfile:print-err "filling db " (dbr:dbdat-dbfile tmpdb) " with data \n from " (dbr:dbdat-dbfile mtdb) " mod time delta: " modtimedelta)
- (db:sync-tables (db:sync-all-tables-list subdb) #f mtdb refndb tmpdb)
- ;; touch tmp db to avoid wal mode wierdness
- (set! (file-modification-time tmpdbfname) (current-seconds))
- (dbfile:print-err "INFO: db:sync-all-tables-list done.")
- )
- (dbfile:print-err " db, " (dbr:dbdat-dbfile tmpdb) " already exists or fresh enough, not propogating data from\n " (dbr:dbdat-dbfile mtdb) " mod time delta: " modtimedelta) )
- ;; (db:multi-db-sync subdb 'old2new)) ;; migrate data from megatest.db automatically
- tmpdb))
;;======================================================================
;; no-sync.db - small bits of data to be shared between servers
;;======================================================================
@@ -878,11 +807,11 @@
(lambda (bad-dbdat)
(dbfile:print-err "db:sync-tables called with todb not a read-only database " bad-dbdat))
readonly-slave-dbs)
readonly-slave-dbs))) -6)
(else
- (dbfile:print-err "db:sync-tables: args are good")
+ ;; (dbfile:print-err "db:sync-tables: args are good")
(let ((stmts (make-hash-table)) ;; table-field => stmt
(all-stmts '()) ;; ( ( stmt1 value1 ) ( stml2 value2 ))
(numrecs (make-hash-table))
(start-time (current-milliseconds))
@@ -994,12 +923,12 @@
(db:is-trigger-dropped db tablename)
#f))
(stmth (sqlite3:prepare db full-ins))
(changed-rows 0))
;; (db:delay-if-busy targdb) ;; NO WAITING
- (if (member "last_update" field-names)
- (dbfile:print-err "is-trigger-dropped: " is-trigger-dropped))
+ ;; (if (member "last_update" field-names)
+ ;; (dbfile:print-err "is-trigger-dropped: " is-trigger-dropped))
(for-each
(lambda (fromdat-lst)
(sqlite3:with-transaction
db