;;======================================================================
;; Copyright 2006-2016, Matthew Welland.
;;
;; This file is part of Megatest.
;;
;; Megatest is free software: you can redistribute it and/or modify
;; it under the terms of the GNU General Public License as published by
;; the Free Software Foundation, either version 3 of the License, or
;; (at your option) any later version.
;;
;; Megatest is distributed in the hope that it will be useful,
;; but WITHOUT ANY WARRANTY; without even the implied warranty of
;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
;; GNU General Public License for more details.
;;
;; You should have received a copy of the GNU General Public License
;; along with Megatest. If not, see <http://www.gnu.org/licenses/>.
;;
;;======================================================================
;;======================================================================
;; Database access
;;======================================================================
;; dbstruct vector containing all the relevant dbs like main.db, megatest.db, run.db etc
(declare (unit db))
(declare (uses common))
(declare (uses debugprint))
(declare (uses dbmod))
(declare (uses dbfile))
(declare (uses keys))
(declare (uses ods))
(declare (uses mt))
(declare (uses commonmod))
(declare (uses mtargs))
(declare (uses rmtmod))
(import commonmod
(prefix mtargs args:))
(use (srfi 18)
extras
;; tcp
stack
(prefix sqlite3 sqlite3:)
srfi-1
posix
regex
regex-case
srfi-69
csv-xml
s11n
md5
message-digest
(prefix base64 base64:)
format
dot-locking
z3
typed-records
matchable
files)
(include "common_records.scm")
(include "db_records.scm")
(include "key_records.scm")
(include "run_records.scm")
(define *number-of-writes* 0)
(define *number-non-write-queries* 0)
(import debugprint)
(import dbfile)
(import dbmod)
(import rmtmod)
;; record for keeping state,status and count for doing roll-ups in
;; iterated tests
;;
(defstruct dbr:counts
(state #f)
(status #f)
(count 0))
;; (define (db:with-db dbstruct run-id r/w proc . params)
;; (case (rmt:transport-mode)
;; ((http)(dbfile:with-db dbstruct run-id r/w proc params))
;; ((tcp) (dbmod:with-db dbstruct run-id r/w proc params))
;; ((nfs) (dbmod:with-db dbstruct run-id r/w proc params))
;; (else (assert #f "FATAL: db:with-db called with non-existant transport mode"))))
;;======================================================================
;; hash of hashs
;;======================================================================
(define (db:hoh-set! dat key1 key2 val)
(let* ((subhash (hash-table-ref/default dat key1 #f)))
(if subhash
(hash-table-set! subhash key2 val)
(begin
(hash-table-set! dat key1 (make-hash-table))
(db:hoh-set! dat key1 key2 val)))))
(define (db:hoh-get dat key1 key2)
(let* ((subhash (hash-table-ref/default dat key1 #f)))
(and subhash
(hash-table-ref/default subhash key2 #f))))
;;======================================================================
;; SQLITE3 HELPERS
;;======================================================================
(define (db:general-sqlite-error-dump exn stmt . params)
(let ((err-status ((condition-property-accessor 'sqlite3 'status #f) exn))) ;; RADT ... how does this work?
;; check for (exn sqlite3) ((condition-property-accessor 'exn 'message) exn)
;; (print "err-status: " err-status)
(debug:print-error 0 *default-log-port* " query " stmt " failed, params: " params ", error: " ((condition-property-accessor 'exn 'message) exn))
(print-call-chain (current-error-port))))
;; convert to -inline
;;
(define (db:first-result-default db stmt default . params)
(handle-exceptions
exn
(let ((err-status ((condition-property-accessor 'sqlite3 'status #f) exn)))
;; check for (exn sqlite3) ((condition-property-accessor 'exn 'message) exn)
(if (eq? err-status 'done)
default
(begin
(debug:print-error 0 *default-log-port* " query " stmt " failed, params: " params ", error: " ((condition-property-accessor 'exn 'message) exn) ", exn=" exn)
(print-call-chain (current-error-port))
default)))
(apply sqlite3:first-result db stmt params)))
(define (db:setup)
(assert *toppath* "FATAL: db:setup called before launch:setup has been run.")
(let* ((tmpdir (common:make-tmpdir-name *toppath* "")))
(if (not *dbstruct-dbs*)
(dbfile:setup (conc *toppath* "/.mtdb") tmpdir)
*dbstruct-dbs*)))
;; moved from dbfile
;;
;; ADD run-id SUPPORT
;;
(define (db:create-all-triggers dbstruct)
(db:with-db
dbstruct #f #t
(lambda (dbdat db)
(db:create-triggers db))))
(define (db:create-triggers db)
(for-each (lambda (key)
(sqlite3:execute db (cadr key)))
db:trigger-list))
(define (db:drop-all-triggers dbstruct)
(db:with-db
dbstruct #f #t
(lambda (dbdat db)
(db:drop-triggers db))))
(define (db:have-incompletes? dbstruct run-id ovr-deadtime)
(let* ((incompleted '())
(oldlaunched '())
(toplevels '())
;; (deadtime-str (configf:lookup *configdat* "setup" "deadtime"))
(deadtime (or ovr-deadtime 72000))) ;; twenty hours
(db:with-db
dbstruct run-id #f
(lambda (dbdat db)
;; in RUNNING or REMOTEHOSTSTART for more than 10 minutes
;;
;; HOWEVER: this code in run:test seems to work fine
;; (> (- (current-seconds)(+ (db:test-get-event_time testdat)
;; (db:test-get-run_duration testdat)))
;; 600)
;; (db:delay-if-busy dbdat)
(sqlite3:for-each-row
(lambda (test-id run-dir uname testname item-path)
(if (and (equal? uname "n/a")
(equal? item-path "")) ;; this is a toplevel test
;; what to do with toplevel? call rollup?
(begin
(set! toplevels (cons (list test-id run-dir uname testname item-path run-id) toplevels)))
;; (print-info "Found old toplevel test in RUNNING state, test-id=" test-id))
(set! incompleted (cons (list test-id run-dir uname testname item-path run-id) incompleted))))
(db:get-cache-stmth dbdat db
"SELECT id,rundir,uname,testname,item_path FROM tests WHERE run_id=? AND (strftime('%s','now') - event_time) > (run_duration + ?) AND state IN ('RUNNING','REMOTEHOSTSTART');")
run-id deadtime)
;; in LAUNCHED for more than one day. Could be long due to job queues TODO/BUG: Need override for this in config
;;
;; (db:delay-if-busy dbdat)
(sqlite3:for-each-row
(lambda (test-id run-dir uname testname item-path)
(if (and (equal? uname "n/a")
(equal? item-path "")) ;; this is a toplevel test
;; what to do with toplevel? call rollup?
(set! toplevels (cons (list test-id run-dir uname testname item-path run-id) toplevels))
(set! oldlaunched (cons (list test-id run-dir uname testname item-path run-id) oldlaunched))))
(db:get-cache-stmth dbdat db
"SELECT id,rundir,uname,testname,item_path FROM tests WHERE run_id=? AND (strftime('%s','now') - event_time) > 86400 AND state IN ('LAUNCHED');")
run-id)
;; (print-info "Found " (length oldlaunched) " old LAUNCHED items, " (length toplevels) " old LAUNCHED toplevel tests and " (length incompleted) " tests marked RUNNING but apparently dead.")
(if (and (null? incompleted)
(null? oldlaunched)
(null? toplevels))
#f
#t)))))
;; looks up subdb and returns it, if not found then set up
;; and then return it.
;;
#;(define (db:get-db dbstruct run-id)
(let* ((res (dbfile:get-subdb dbstruct run-id)))
(if res
res
(let* ((newsubdb (make-dbr:subdb)))
(dbfile:set-subdb dbstruct run-id newsubdb)
(db:open-db dbstruct run-id areapath: (dbr:dbstruct-areapath dbstruct) do-sync: #t)
newsubdb))))
;; Get/open a database
;; if run-id => get run specific db
;; if #f => get main db
;; if run-id is a string treat it as a filename
;; if db already open - return cachedb
;; if db not open, open cachedb, rundb and sync then return cachedb
;; inuse gets set automatically for rundb's
;;
;; (define db:get-db db:get-subdb)
;; (define (db:get-db subdb #;dbstruct run-id) ;; RENAME TO db:get-dbh
;; ;; (let* ((subdb (dbfile:get-subdb dbstruct run-id)))
;; (if (stack? (dbr:subdb-dbstack subdb))
;; (if (stack-empty? (dbr:subdb-dbstack subdb))
;; (let* ((dbname (db:run-id->dbname run-id))
;; (newdb (db:open-megatest-db path: (db:dbfile-path)
;; name: dbname)))
;; ;; NOTE: pushing on the stack only happens AFTER the handle has been used
;; ;; (stack-push! (dbr:dbstruct-dbstack dbstruct) newdb)
;; newdb)
;; (stack-pop! (dbr:subdb-dbstack subdb)))
;; (db:open-db subdb run-id))) ;; )
#;(define (db:get-db dbstruct run-id)
(let* ((subdb (dbfile:get-subdb dbstruct run-id))
(dbdat (dbfile:get-dbdat dbstruct run-id)))
(if (dbr:dbdat? dbdat)
dbdat
(dbfile:open-db *dbstruct-dbs* #f db:initialize-main-db)
)
)
)
(define-inline (db:generic-error-printout exn . message)
(print-call-chain (current-error-port))
(apply debug:print-error 0 *default-log-port* message)
(debug:print-error 0 *default-log-port* " params: " params
", error: " ((condition-property-accessor 'exn 'message) exn)
", arguments: " ((condition-property-accessor 'exn 'arguments) exn)
", location: " ((condition-property-accessor 'exn 'location) exn)
))
(define (db:set-sync db)
(let ((syncprag (configf:lookup *configdat* "setup" "sychronous")))
(sqlite3:execute db (conc "PRAGMA synchronous = " (or syncprag 0) ";"))))
(define (db:get-last-update-time db)
(let ((last-update-time #f))
(sqlite3:for-each-row
(lambda (lup)
(set! last-update-time lup))
db
"select max(lup) from ( select max(last_update) as lup from tests union select max(last_update) as lup from runs);")
last-update-time))
;; Open the classic megatest.db file (defaults to open in toppath)
;;
;; NOTE: returns a dbdat not a dbstruct!
;;
(define (db:open-megatest-db dbpath)
(let* ((dbexists (file-exists? dbpath))
(db (db:lock-create-open dbpath
(lambda (db)
(db:initialize-main-db db))))
(write-access (file-write-access? dbpath)))
(debug:print-info 13 *default-log-port* "db:open-megatest-db "dbpath)
(if (and dbexists (not write-access))
(set! *db-write-access* #f))
;; (cons db dbpath)))
(make-dbr:dbdat dbfile: dbpath dbh: db read-only: (not write-access))))
;; use bunch of Unix commands to try to break the lock and recreate the db
;;
(define (db:move-and-recreate-db dbdat)
(let* ((dbpath (dbr:dbdat-dbfile dbdat))
(dbdir (pathname-directory dbpath))
(fname (pathname-strip-directory dbpath))
(fnamejnl (conc fname "-journal"))
(tmpname (conc fname "." (current-process-id)))
(tmpjnl (conc fnamejnl "." (current-process-id))))
(debug:print-error 0 *default-log-port* "" fname " appears corrupted. Making backup \"old/" fname "\"")
(system (conc "cd " dbdir ";mkdir -p old;cat " fname " > old/" tmpname))
(system (conc "rm -f " dbpath))
(if (common:file-exists? fnamejnl)
(begin
(debug:print-error 0 *default-log-port* "" fnamejnl " found, moving it to old dir as " tmpjnl)
(system (conc "cd " dbdir ";mkdir -p old;cat " fnamejnl " > old/" tmpjnl))
(system (conc "rm -f " dbdir "/" fnamejnl))))
;; attempt to recreate database
(system (conc "cd " dbdir ";sqlite3 old/" tmpname " .dump | sqlite3 " fname))))
;; return #f to indicate the dbdat should be closed/reopened
;; else return dbdat
;;
(define (db:repair-db dbdat #!key (numtries 1))
(let* ((dbpath (dbr:dbdat-dbfile dbdat))
(dbdir (pathname-directory dbpath))
(fname (pathname-strip-directory dbpath)))
(debug:print-info 0 *default-log-port* "Checking db " dbpath " for errors.")
(cond
((not (file-write-access? dbdir))
(debug:print 0 *default-log-port* "WARNING: can't write to " dbdir ", can't fix " fname)
#f)
;; handle special cases, megatest.db and monitor.db
;;
;; NOPE: apply this same approach to all db files
;;
(else ;; ((equal? fname "megatest.db") ;; this file can be regenerated if needed
(handle-exceptions
exn
(begin
(debug:print 0 *default-debug-port* "Problems trying to repair the db, exn=" exn)
;; (db:move-and-recreate-db dbdat)
(if (> numtries 0)
(db:repair-db dbdat numtries: (- numtries 1))
#f)
(debug:print 0 *default-log-port* "FATAL: file " dbpath " was found corrupted, an attempt to fix has been made but you must start over.")
(debug:print 0 *default-log-port*
" check the following:\n"
" 1. full directories, look in ~/ /tmp and " dbdir "\n"
" 2. write access to " dbdir "\n\n"
" if the automatic recovery failed you may be able to recover data by doing \""
(if (member fname '("megatest.db" "monitor.db"))
"megatest -cleanup-db"
"megatest -import-megatest.db;megatest -cleanup-db")
"\"\n")
(exit) ;; we can not safely continue when a db was corrupted - even if fixed.
)
;; test read/write access to the database
(let ((db (sqlite3:open-database dbpath)))
(sqlite3:set-busy-handler! db (sqlite3:make-busy-timeout 136000))
(sqlite3:execute db "PRAGMA synchronous = 0;")
(cond
((equal? fname "megatest.db")
(sqlite3:execute db "DELETE FROM tests WHERE state='DELETED';"))
((equal? fname "main.db")
(sqlite3:execute db "DELETE FROM runs WHERE state='deleted';"))
((string-match "\\d.db" fname)
(sqlite3:execute db "UPDATE tests SET state='DELETED' WHERE state='DELETED';"))
((equal? fname "monitor.db")
(sqlite3:execute "DELETE FROM servers WHERE state LIKE 'defunct%';"))
(else
(sqlite3:execute db "vacuum;")))
(sqlite3:finalize! db)
#t))))))
(define (db:adj-target db)
(let ((fields (configf:get-section *configdat* "fields"))
(field-num 0))
;; because we will be refreshing the keys table it is best to clear it here
(sqlite3:execute db "DELETE FROM keys;")
(for-each
(lambda (field)
(let ((column (car field))
(spec (cadr field)))
(handle-exceptions
exn
(if (string-match ".*duplicate.*" ((condition-property-accessor 'exn 'message) exn))
(debug:print 0 *default-log-port* "Target field " column " already exists in the runs table")
(db:general-sqlite-error-dump exn "alter table runs ..." #f "none"))
;; Add the column if needed
(sqlite3:execute
db
(conc "ALTER TABLE runs ADD COLUMN " column " " spec)))
;; correct the entry in the keys column
(sqlite3:execute
db
"INSERT INTO keys (id,fieldname,fieldtype) VALUES (?,?,?);"
field-num column spec)
;; fill in blanks (not allowed as it would be part of the path
(sqlite3:execute
db
(conc "UPDATE runs SET " column "='x' WHERE " column "='';"))
(set! field-num (+ field-num 1))))
fields)))
(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)
(debug:print 2 *default-log-port* "not doing cached calls right now"))
;; (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 (db:get-sqlite3-mod-time target))
;; (if (common:file-exists? target)
;; BUG: This needs to include wal mode stuff .shm etc.
;; (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)))
(define (db:get-sqlite3-mod-time fname)
(let* ((wal-file (conc fname "-wal"))
(shm-file (conc fname "-shm"))
(get-mtime (lambda (f)
(if (and (file-exists? f)
(file-read-access? f))
(file-modification-time f)
0))))
(max (get-mtime fname)
(get-mtime wal-file)
(get-mtime shm-file))))
;; (define (db:all-db-sync dbstruct)
;; (let* ((dbdat (db:open-db dbstruct #f db:initialize-main-db))
;; (data-synced 0) ;; count of changed records
;; (tmp-area (common:make-tmpdir-name *toppath*))
;; (dbfiles (glob (conc tmp-area"/.mtdb/*.db")))
;; (sync-durations (make-hash-table))
;; (no-sync-db (db:open-no-sync-db)))
;; (for-each
;; (lambda (file) ;; tmp db file
;; (debug:print-info 3 *default-log-port* "file: " file)
;; (let* ((fname (conc (pathname-file file) ".db")) ;; fname is tmp db file
;; (wal-file (conc fname "-wal"))
;; (shm-file (conc fname "-shm"))
;; (fulln (conc *toppath*"/,mtdb/"fname)) ;; fulln is nfs db name
;; (wal-time (if (file-exists? wal-file)
;; (file-modification-time wal-file)
;; 0))
;; (shm-time (if (file-exists? shm-file)
;; (file-modification-time shm-file)
;; 0))
;; (time1 (db:get-sqlite3-mod-time file))
;; ;; (if (file-exists? file) ;; time1 is the max itime of the tmp db, -wal and -shm files.
;; ;; (max (file-modification-time file) wal-time shm-time)
;; ;; (begin
;; ;; (debug:print-info 2 *default-log-port* "Sync - I do not see file "file)
;; ;; 1)))
;; (time2 (db:get-sqlite3-mod-time fulln))
;; ;; (if (file-exists? fulln) ;; time2 is nfs file time
;; ;; (file-modification-time fulln)
;; ;; (begin
;; ;; (debug:print-info 2 *default-log-port* "Sync - I do not see file "fulln)
;; ;; 0)))
;; (changed (> (- time1 time2) (+ (random 5) 1))) ;; it has been at some few seconds since last synced
;; (changed10 (> (- time1 time2) 10)) ;; it has been at least ten seconds since sync'd
;; (jfile-exists (file-exists? (conc file"-journal"))) ;; i.e. are we busy?
;; (do-cp (cond
;; ((not (file-exists? fulln)) ;; shouldn't happen, but this might recover
;; (cons #t (conc "File "fulln" not found! Copying "fname" to "fulln)))
;; ((and (not jfile-exists) changed)
;; (cons #t "not busy, changed")) ;; not busy and changed
;; ((and jfile-exists changed10)
;; (cons #t "busy but not synced in a while")) ;; busy but not sync'd in over 10 seconds
;; ((and changed *time-to-exit*)
;; (cons #t "Time to exit, forced final sync")) ;; last sync
;; (else
;; (cons #f "No sync needed")))))
;; (if (car do-cp)
;; (let* ((start-time (current-milliseconds))
;; (fname (pathname-file file))
;; (runid (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, reason: "(cdr do-cp))
;; (db:lock-and-delta-sync no-sync-db dbstruct fname runid (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)
;; ;; WHY does the dbdat need to be added back?
;; (if dbdat (dbfile:add-dbdat dbstruct #f dbdat))
;; )
;; #t)
(define (db:kill-servers)
(let* ((tl (launch:setup)) ;; need this to initialize *toppath*
(servdir (conc *toppath* "/.servinfo"))
(servfiles (glob (conc servdir "/*:*.db")))
(fmtstr "~10a~22a~10a~25a~25a~8a\n")
(dbfiles (append (glob (conc *toppath* "/.mtdb/main.db")) (glob (conc *toppath* "/.mtdb/?.db"))(glob (conc *toppath* "/.mtdb/??.db"))))
(ttdat (make-tt areapath: *toppath*))
)
(format #t fmtstr "DB" "host:port" "PID" "age" "last mod" "state")
(for-each
(lambda (dbfile)
(let* (
(dbfname (conc (pathname-file dbfile) ".db"))
(sfiles (tt:find-server *toppath* dbfname))
)
(for-each
(lambda (sfile)
(let (
(sinfos (tt:get-server-info-sorted ttdat dbfname))
)
(for-each
(lambda (sinfo)
(let* (
(db (list-ref sinfo 5))
(pid (list-ref sinfo 4))
(host (list-ref sinfo 0))
(port (list-ref sinfo 1))
(server-id (list-ref sinfo 3))
(age (seconds->hr-min-sec (- (current-seconds) (list-ref sinfo 2))))
(last-mod (seconds->string (list-ref sinfo 2)))
(killed (system (conc "ssh " host " kill " pid " > /dev/null")))
(dummy2 (sleep 1))
(state (if (> (system (conc "ssh " host " ps " pid " > /dev/null")) 0) "dead" "alive"))
)
(format #t fmtstr db (conc host ":" port) pid age last-mod state)
(system (conc "rm " sfile))
)
)
sinfos
)
)
)
sfiles
)
)
)
dbfiles
)
;; remove this db, because otherwise metadata contains records for old servers, and this causes a problem with db:no-sync-get-lock-with-id.
(if (file-exists? (conc *toppath* "/.mtdb/no-sync.db"))
(delete-file (conc *toppath* "/.mtdb/no-sync.db"))
)
)
)
;; options:
;;
;; 'killservers - kills all servers
;; 'dejunk - removes junk records
;; 'adj-testids - move test-ids into correct ranges
;; 'old2new - sync megatest.db to /tmp/.../megatest.db and /tmp/.../megatest_ref.db
;; 'new2old - sync /tmp/.../megatest.db to megatest.db and /tmp/.../megatest_ref.db (and update data_synced)
;; '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 dbfile:db-init-proc))
(data-synced 0) ;; count of changed records
(tmp-area (common:make-tmpdir-name *toppath* ""))
(old2new (member 'old2new options))
(dejunk (member 'dejunk options))
(killservers (member 'killservers options))
(src-area (if old2new *toppath* tmp-area))
(dest-area (if old2new tmp-area (conc *toppath* "/.mtdb")))
(dbfiles (if old2new (glob (conc *toppath* "/.mtdb/*.db"))
(glob (conc tmp-area "/*.db"))))
(keys (db:get-keys dbstruct))
(sync-durations (make-hash-table)))
;; kill servers
;; (if killservers (db:kill-servers))
(if (not dbfiles)
(debug:print-error 0 *default-log-port* "no dbfiles found in " (conc *toppath* "/.mtdb"))
(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 "/" fname))
(dest-directory dest-area)
(time1 (file-modification-time srcfile))
(time2 (if (file-exists? destfile)
(begin
(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 ( < (- time2 time1) 6.0)) ;; dest db not updated within last 6 seconds
(do-cp (cond
((not (file-exists? destfile)) ;; shouldn't happen, but this might recover
(debug:print-info 2 *default-log-port* "File " destfile " not found. Copying "srcfile" to "destfile)
;; TODO: Need to fix this for WAL mod. Can't just copy.
(system (conc "/bin/mkdir -p " dest-directory))
(system (conc "/bin/cp " srcfile " " destfile))
#t)
(changed ;; (and changed
#t)
((and changed *time-to-exit*) ;; last sync
#t)
(else
#f))))
(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)))
(dbdat (or (dbfile:get-dbdat dbstruct run-id) (dbfile:open-db dbstruct run-id dbfile:db-init-proc)))
(mtdb (dbr:subdb-mtdbdat subdb))
;;
;; BUG: -mrw- I think this next line is wrong. run-id should be the path to .mtdb/<runid>.db
;;
(tmpdb (dbfile:open-db dbstruct run-id dbfile:db-init-proc)))
(if dejunk
(begin
(debug:print 0 *default-log-port* "Cleaning tmp DB")
(db:clean-up run-id tmpdb)
(debug:print 0 *default-log-port* "Cleaning nfs DB")
(db:clean-up run-id mtdb)
)
)
(debug:print-info 2 *default-log-port* "delta syncing file: " srcfile ", time diff: " (- time1 time2) " seconds")
(if old2new
(begin
(db:sync-tables (db:sync-all-tables-list
(db:get-keys dbstruct))
#f mtdb tmpdb))
(begin
(db:sync-tables (db:sync-all-tables-list (db:get-keys dbstruct)) #f tmpdb mtdb)))
(hash-table-set! sync-durations (conc srcfile ".db") (- (current-milliseconds) start-time)))
(debug:print-info 2 *default-log-port* "skipping delta sync. " srcfile " is up to date"))))
dbfiles))
data-synced))
;; Sync all changed db's
;;
(define (db:tmp->megatest.db-sync dbstruct run-id last-update)
(let* ((subdbs (hash-table-values (dbr:dbstruct-subdbs dbstruct)))
(res '()))
(for-each
(lambda (subdb)
(let* ((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 (db:get-keys dbstruct)) last-update tmpdb refndb mtdb)))
;; (stack-push! (dbr:subdb-dbstack subdb) tmpdb)
;; BUG: verify this is really needed
(dbfile:add-dbdat dbstruct run-id tmpdb)
(set! res (cons newres res))))
subdbs)
res))
;;;; run-ids
;; if #f use *db-local-sync* : or 'local-sync-flags
;; if #t use timestamps : or 'timestamps
;;
;; NB// no-sync-db is the db handle, not a flag!
;;
(define (db:sync-to-megatest.db dbstruct #!key (no-sync-db #f))
(let* ((start-time (current-seconds))
(last-full-update (if no-sync-db
(db:no-sync-get/default no-sync-db "LAST_FULL_UPDATE" 0)
0))
(full-sync-needed (> (- start-time last-full-update) 3600)) ;; every hour do a full sync
(last-update (if full-sync-needed
0
(if no-sync-db
(db:no-sync-get/default no-sync-db "LAST_UPDATE" 0)
0))) ;; (or (db:get-var dbstruct "LAST_UPDATE") 0))
(sync-needed (> (- start-time last-update) 6))
(res (if (or sync-needed ;; don't sync if a sync already occurred in the past 6 seconds
full-sync-needed)
(begin
(if no-sync-db
(begin
(if full-sync-needed (db:no-sync-set no-sync-db "LAST_FULL_UPDATE" start-time))
(db:no-sync-set no-sync-db "LAST_UPDATE" start-time)))
(db:tmp->megatest.db-sync dbstruct last-update))
0))
(sync-time (- (current-seconds) start-time)))
(debug:print-info 3 *default-log-port* "Sync of newdb to olddb completed in " sync-time " seconds pid="(current-process-id))
(if (common:low-noise-print 30 "sync new to old")
(if sync-needed
(debug:print-info 0 *default-log-port* "Sync of " res " records from newdb to olddb completed in " sync-time " seconds pid="(current-process-id))
(debug:print-info 0 *default-log-port* "No sync needed, last updated " (- start-time last-update) " seconds ago")))
res))
(define (db:initialize-main-db db)
(when (not *configinfo*)
(launch:setup)) ;; added because Elena was getting stack dump because *configinfo* below was #f.
(let* ((configdat (car *configinfo*)) ;; tut tut, global warning...
(keys (keys:config-get-fields configdat))
(havekeys (> (length keys) 0))
(keystr (keys->keystr keys))
(fieldstr (keys:make-key/field-string configdat))
#;(db (dbr:dbdat-dbh dbdat)))
(for-each (lambda (key)
(let ((keyn key))
(if (member (string-downcase keyn)
(list "runname" "state" "status" "owner" "event_time" "comment" "fail_count"
"pass_count" "contour"))
(begin
(debug:print 0 *default-log-port* "ERROR: your key cannot be named " keyn " as this conflicts with the same named field in the runs table, you must remove your megatest.db and <linktree>/.db before trying again.")
(exit 1)))))
keys)
(sqlite3:with-transaction
db
(lambda ()
;; handle-exceptions
;; exn
;; (begin
;; (debug:print 0 "ERROR: Failed to create tables. Look at your [fields] section, should be: fieldname TEXT DEFAULT 'yourdefault'")
;; (exit))
(sqlite3:execute db "CREATE TABLE IF NOT EXISTS keys (id INTEGER PRIMARY KEY, fieldname TEXT, fieldtype TEXT, CONSTRAINT keyconstraint UNIQUE (fieldname));")
(for-each
(lambda (key)
(let* ((fieldname #f)
(fieldtype #f))
(sqlite3:for-each-row
(lambda (fn ft)
(set! fieldname fn)
(set! fieldtype ft))
db
"SELECT fieldname,fieldtype FROM keys WHERE fieldname=?" key)
(if (not fieldname)
(sqlite3:execute db "INSERT INTO keys (fieldname,fieldtype) VALUES (?,?);" key "TEXT"))))
keys)
(sqlite3:execute db (conc
"CREATE TABLE IF NOT EXISTS runs (id INTEGER PRIMARY KEY, \n "
fieldstr (if havekeys "," "") "
runname TEXT DEFAULT 'norun',
contour TEXT DEFAULT '',
state TEXT DEFAULT '',
status TEXT DEFAULT '',
owner TEXT DEFAULT '',
event_time TIMESTAMP DEFAULT (strftime('%s','now')),
comment TEXT DEFAULT '',
fail_count INTEGER DEFAULT 0,
pass_count INTEGER DEFAULT 0,
last_update INTEGER DEFAULT (strftime('%s','now')),
CONSTRAINT runsconstraint UNIQUE (runname" (if havekeys "," "") keystr "));"))
;; All triggers created at once in end
;;(sqlite3:execute db "CREATE TRIGGER IF NOT EXISTS update_runs_trigger AFTER UPDATE ON runs
;; FOR EACH ROW
;; BEGIN
;; UPDATE runs SET last_update=(strftime('%s','now'))
;; WHERE id=old.id;
;; END;")
(sqlite3:execute db "CREATE TABLE IF NOT EXISTS run_stats (
id INTEGER PRIMARY KEY,
run_id INTEGER,
state TEXT,
status TEXT,
count INTEGER,
last_update INTEGER DEFAULT (strftime('%s','now')))")
;; All triggers created at once in end
;; (sqlite3:execute db "CREATE TRIGGER IF NOT EXISTS update_run_stats_trigger AFTER UPDATE ON run_stats
;; FOR EACH ROW
;; BEGIN
;; UPDATE run_stats SET last_update=(strftime('%s','now'))
;; WHERE id=old.id;
;; END;")
(sqlite3:execute db "CREATE TABLE IF NOT EXISTS test_meta (
id INTEGER PRIMARY KEY,
testname TEXT DEFAULT '',
author TEXT DEFAULT '',
owner TEXT DEFAULT '',
description TEXT DEFAULT '',
reviewed TIMESTAMP,
iterated TEXT DEFAULT '',
avg_runtime REAL,
avg_disk REAL,
tags TEXT DEFAULT '',
jobgroup TEXT DEFAULT 'default',
CONSTRAINT test_meta_constraint UNIQUE (testname));")
(sqlite3:execute db "CREATE TABLE IF NOT EXISTS tasks_queue (id INTEGER PRIMARY KEY,
action TEXT DEFAULT '',
owner TEXT,
state TEXT DEFAULT 'new',
target TEXT DEFAULT '',
name TEXT DEFAULT '',
testpatt TEXT DEFAULT '',
keylock TEXT,
params TEXT,
creation_time TIMESTAMP DEFAULT (strftime('%s','now')),
execution_time TIMESTAMP);")
;; archive disk areas, cached info from [archive-disks]
(sqlite3:execute db "CREATE TABLE IF NOT EXISTS archive_disks (
id INTEGER PRIMARY KEY,
archive_area_name TEXT,
disk_path TEXT,
last_df INTEGER DEFAULT -1,
last_df_time TIMESTAMP DEFAULT (strftime('%s','now')),
creation_time TIMESTAMP DEFAULT (strftime('%s','now')));")
;; individual bup (or tar) data chunks
(sqlite3:execute db "CREATE TABLE IF NOT EXISTS archive_blocks (
id INTEGER PRIMARY KEY,
archive_disk_id INTEGER,
disk_path TEXT,
last_du INTEGER DEFAULT -1,
last_du_time TIMESTAMP DEFAULT (strftime('%s','now')),
creation_time TIMESTAMP DEFAULT (strftime('%s','now')));")
;; tests allocated to what chunks. reusing a chunk for a test/item_path is very efficient
;; NB// the per run/test recording of where the archive is stored is done in the test
;; record.
(sqlite3:execute db "CREATE TABLE IF NOT EXISTS archive_allocations (
id INTEGER PRIMARY KEY,
archive_block_id INTEGER,
testname TEXT,
item_path TEXT,
creation_time TIMESTAMP DEFAULT (strftime('%s','now')));")
;; move this clean up call somewhere else
(sqlite3:execute db "DELETE FROM tasks_queue WHERE state='done' AND creation_time < ?;" (- (current-seconds)(* 24 60 60))) ;; remove older than 24 hrs
(sqlite3:execute db (conc "CREATE INDEX IF NOT EXISTS runs_index ON runs (runname" (if havekeys "," "") keystr ");"))
;; (sqlite3:execute db "CREATE VIEW runs_tests AS SELECT * FROM runs INNER JOIN tests ON runs.id=tests.run_id;")
(sqlite3:execute db "CREATE TABLE IF NOT EXISTS extradat (id INTEGER PRIMARY KEY, run_id INTEGER, key TEXT, val TEXT);")
(sqlite3:execute db "CREATE TABLE IF NOT EXISTS metadat (id INTEGER PRIMARY KEY, var TEXT, val TEXT,
CONSTRAINT metadat_constraint UNIQUE (var));")
(sqlite3:execute db "CREATE TABLE IF NOT EXISTS access_log (id INTEGER PRIMARY KEY, user TEXT, accessed TIMESTAMP, args TEXT);")
;; Must do this *after* running patch db !! No more.
;; cannot use db:set-var since it will deadlock, hardwire the code here
(let* ((prev-version #f)
(curr-version (common:version-signature)))
(sqlite3:for-each-row
(lambda (ver)
(set! prev-version ver))
db
"SELECT val FROM metadat WHERE var='MEGATEST_VERSION';")
(if prev-version
(if (not (equal? prev-version curr-version))
(sqlite3:execute db "UPDATE metadat SET val=? WHERE var=?;" curr-version "MEGATEST_VERSION"))
(sqlite3:execute db "INSERT OR REPLACE INTO metadat (var,val) VALUES (?,?);" "MEGATEST_VERSION" curr-version) ))
(debug:print-info 11 *default-log-port* "db:initialize END") ;; ))))
;;======================================================================
;; R U N S P E C I F I C D B
;;======================================================================
;; (define (db:initialize-run-id-db db)
;; (sqlite3:with-transaction
;; db
;; (lambda ()
(sqlite3:execute db "CREATE TABLE IF NOT EXISTS tests
(id INTEGER PRIMARY KEY,
run_id INTEGER DEFAULT -1,
testname TEXT DEFAULT 'noname',
host TEXT DEFAULT 'n/a',
cpuload REAL DEFAULT -1,
diskfree INTEGER DEFAULT -1,
uname TEXT DEFAULT 'n/a',
rundir TEXT DEFAULT '/tmp/badname',
shortdir TEXT DEFAULT '/tmp/badname',
item_path TEXT DEFAULT '',
state TEXT DEFAULT 'NOT_STARTED',
status TEXT DEFAULT 'FAIL',
attemptnum INTEGER DEFAULT 0,
final_logf TEXT DEFAULT 'logs/final.log',
logdat TEXT DEFAULT '',
run_duration INTEGER DEFAULT 0,
comment TEXT DEFAULT '',
event_time TIMESTAMP DEFAULT (strftime('%s','now')),
fail_count INTEGER DEFAULT 0,
pass_count INTEGER DEFAULT 0,
archived INTEGER DEFAULT 0, -- 0=no, > 1=archive block id where test data can be found
last_update INTEGER DEFAULT (strftime('%s','now')),
CONSTRAINT testsconstraint UNIQUE (run_id, testname, item_path));")
;; deprecated -- (sqlite3:execute db "CREATE INDEX IF NOT EXISTS tests_index ON tests (run_id, testname, item_path, uname);")
(sqlite3:execute db "CREATE INDEX IF NOT EXISTS tests_run_id_index ON tests (run_id);") ;; new
(sqlite3:execute db "CREATE INDEX IF NOT EXISTS tests_testname_index ON tests (testname,item_path);") ;; new
(sqlite3:execute db "CREATE INDEX IF NOT EXISTS tests_state_status_index ON tests (state, status); ") ;; new
;; All triggers created at once in end
;;(sqlite3:execute db "CREATE TRIGGER IF NOT EXISTS update_tests_trigger AFTER UPDATE ON tests
;; FOR EACH ROW
;; BEGIN
;; UPDATE tests SET last_update=(strftime('%s','now'))
;; WHERE id=old.id;
;; END;")
(sqlite3:execute db "CREATE TABLE IF NOT EXISTS test_steps
(id INTEGER PRIMARY KEY,
test_id INTEGER,
stepname TEXT,
state TEXT DEFAULT 'NOT_STARTED',
status TEXT DEFAULT 'n/a',
event_time TIMESTAMP,
comment TEXT DEFAULT '',
logfile TEXT DEFAULT '',
last_update INTEGER DEFAULT (strftime('%s','now')),
CONSTRAINT test_steps_constraint UNIQUE (test_id,stepname,state));")
(sqlite3:execute db "CREATE INDEX IF NOT EXISTS teststeps_index ON test_steps (test_id, stepname, state);")
;; All triggers created at once in end
;;(sqlite3:execute db "CREATE TRIGGER IF NOT EXISTS update_teststeps_trigger AFTER UPDATE ON test_steps
;; FOR EACH ROW
;; BEGIN
;; UPDATE test_steps SET last_update=(strftime('%s','now'))
;; WHERE id=old.id;
;; END;")
(sqlite3:execute db "CREATE TABLE IF NOT EXISTS test_data (id INTEGER PRIMARY KEY,
test_id INTEGER,
category TEXT DEFAULT '',
variable TEXT,
value REAL,
expected REAL,
tol REAL,
units TEXT,
comment TEXT DEFAULT '',
status TEXT DEFAULT 'n/a',
type TEXT DEFAULT '',
last_update INTEGER DEFAULT (strftime('%s','now')),
CONSTRAINT test_data_constraint UNIQUE (test_id,category,variable));")
(sqlite3:execute db "CREATE INDEX IF NOT EXISTS test_data_index ON test_data (test_id);")
;; All triggers created at once in end
;;(sqlite3:execute db "CREATE TRIGGER IF NOT EXISTS update_test_data_trigger AFTER UPDATE ON test_data
;; FOR EACH ROW
;; BEGIN
;; UPDATE test_data SET last_update=(strftime('%s','now'))
;; WHERE id=old.id;
;; END;")
(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,
last_update INTEGER DEFAULT (strftime('%s','now')));")
(sqlite3:execute db "CREATE TABLE IF NOT EXISTS archives (
id INTEGER PRIMARY KEY,
test_id INTEGER,
state TEXT DEFAULT 'new',
status TEXT DEFAULT 'n/a',
archive_type TEXT DEFAULT 'bup',
du INTEGER,
archive_path TEXT,
last_update INTEGER DEFAULT (strftime('%s','now')));")))
(db:create-triggers db)
db)) ;; )
;;======================================================================
;; A R C H I V E S
;;======================================================================
;; dneeded is minimum space needed, scan for existing archives that
;; are on disks with adequate space and already have this test/itempath
;; archived
;;
(define (db:archive-get-allocations dbstruct testname itempath dneeded)
(let* ((dbdat (db:get-subdb dbstruct #f)) ;; archive tables are in main.db
(db (dbr:dbdat-dbh dbdat))
(res '())
(blocks '())) ;; a block is an archive chunck that can be added too if there is space
(sqlite3:for-each-row
(lambda (id archive-disk-id disk-path last-du last-du-time)
(set! res (cons (vector id archive-disk-id disk-path last-du last-du-time) res)))
db
"SELECT b.id,b.archive_disk_id,b.disk_path,b.last_du,b.last_du_time FROM archive_blocks AS b
INNER JOIN archive_allocations AS a ON a.archive_block_id=b.id
WHERE a.testname=? AND a.item_path=?;"
testname itempath)
;; Now res has list of candidate paths, look in archive_disks for candidate with potential free space
(if (null? res)
'()
(sqlite3:for-each-row
(lambda (id archive-area-name disk-path last-df last-df-time)
(set! blocks (cons (vector id archive-area-name disk-path last-df last-df-time) blocks)))
db
(conc
"SELECT d.id,d.archive_area_name,disk_path,last_df,last_df_time FROM archive_disks AS d
INNER JOIN archive_blocks AS b ON d.id=b.archive_disk_id
WHERE b.id IN (" (string-intersperse (map conc res) ",") ") AND
last_df > ?;")
dneeded))
;; BUG: Verfify this is really needed
(dbfile:add-dbdat dbstruct #f dbdat)
blocks))
;; returns id of the record, register a disk allocated to archiving and record it's last known
;; available space
;;
(define (db:archive-register-disk dbstruct bdisk-name bdisk-path df)
(let* ((dbdat (db:get-subdb dbstruct #f)) ;; archive tables are in main.db
(db (dbr:dbdat-dbh dbdat))
(res #f))
(sqlite3:for-each-row
(lambda (id)
(set! res id))
db
"SELECT id FROM archive_disks WHERE archive_area_name=? AND disk_path=?;"
bdisk-name bdisk-path)
(if res ;; record exists, update df and return id
(begin
(sqlite3:execute db "UPDATE archive_disks SET last_df=?,last_df_time=(strftime('%s','now'))
WHERE archive_area_name=? AND disk_path=?;"
df bdisk-name bdisk-path)
(dbfile:add-dbdat dbstruct #f dbdat)
res)
(begin
(sqlite3:execute
db
"INSERT OR REPLACE INTO archive_disks (archive_area_name,disk_path,last_df)
VALUES (?,?,?);"
bdisk-name bdisk-path df)
(dbfile:add-dbdat dbstruct #f dbdat)
(db:archive-register-disk dbstruct bdisk-name bdisk-path df)))))
;; record an archive path created on a given archive disk (identified by it's bdisk-id)
;; if path starts with / then it is full, otherwise it is relative to the archive disk
;; preference is to store the relative path.
;;
(define (db:archive-register-block-name dbstruct bdisk-id archive-path #!key (du #f))
(let* ((dbdat (db:get-subdb dbstruct #f)) ;; archive tables are in main.db
(db (dbr:dbdat-dbh dbdat))
(res #f))
;; first look to see if this path is already registered
(sqlite3:for-each-row
(lambda (id)
(set! res id))
db
"SELECT id FROM archive_blocks WHERE archive_disk_id=? AND disk_path=?;"
bdisk-id archive-path)
(if res ;; record exists, update du if applicable and return res
(if du (sqlite3:execute db "UPDATE archive_blocks SET last_du=?,last_du_time=(strftime('%s','now'))
WHERE archive_disk_id=? AND disk_path=?;"
bdisk-id archive-path du))
(begin
(sqlite3:execute db "INSERT OR REPLACE INTO archive_blocks (archive_disk_id,disk_path,last_du)
VALUES (?,?,?);"
bdisk-id archive-path (or du 0))
(set! res (db:archive-register-block-name dbstruct bdisk-id archive-path du: du))))
(dbfile:add-dbdat dbstruct #f dbdat)
res))
;; The "archived" field in tests is overloaded; 0 = not archived, > 0 archived in block with given id
;;
(define (db:test-set-archive-block-id dbstruct run-id test-id archive-block-id)
(db:with-db
dbstruct
run-id
#t
(lambda (dbdat db)
(sqlite3:execute db "UPDATE tests SET archived=? WHERE id=?;"
archive-block-id test-id))))
;; Look up the archive block info given a block-id
;;
(define (db:test-get-archive-block-info dbstruct archive-block-id)
(db:with-db
dbstruct
#f
#f
(lambda (dbdat db)
(let ((res #f))
(sqlite3:for-each-row
;; 0 1 2 3 4 5
(lambda (id archive-disk-id disk-path last-du last-du-time creation-time)
(set! res (vector id archive-disk-id disk-path last-du last-du-time creation-time)))
db
"SELECT id,archive_disk_id,disk_path,last_du,last_du_time,creation_time FROM archive_blocks WHERE id=?;"
archive-block-id)
res))))
;; (define (db:archive-allocate-testsuite/area-to-block block-id testsuite-name areakey)
;; (let* ((dbdat (db:get-subdb dbstruct #f)) ;; archive tables are in main.db
;; (db (dbr:dbdat-dbh dbdat))
;; (res '())
;; (blocks '())) ;; a block is an archive chunck that can be added too if there is space
;; (sqlite3:for-each-row #f)
;;======================================================================
;; D B U T I L S
;;======================================================================
;;======================================================================
;; M A I N T E N A N C E
;;======================================================================
;; (define (db:have-incompletes? dbstruct run-id ovr-deadtime)
;; (let* ((incompleted '())
;; (oldlaunched '())
;; (toplevels '())
;; (deadtime-str (configf:lookup *configdat* "setup" "deadtime"))
;; (deadtime (if (and deadtime-str
;; (string->number deadtime-str))
;; (string->number deadtime-str)
;; 72000))) ;; twenty hours
;; (db:with-db
;; dbstruct run-id #f
;; (lambda (dbdat db)
;; (if (number? ovr-deadtime)(set! deadtime ovr-deadtime))
;;
;; ;; in RUNNING or REMOTEHOSTSTART for more than 10 minutes
;; ;;
;; ;; HOWEVER: this code in run:test seems to work fine
;; ;; (> (- (current-seconds)(+ (db:test-get-event_time testdat)
;; ;; (db:test-get-run_duration testdat)))
;; ;; 600)
;; ;; (db:delay-if-busy dbdat)
;; (sqlite3:for-each-row
;; (lambda (test-id run-dir uname testname item-path)
;; (if (and (equal? uname "n/a")
;; (equal? item-path "")) ;; this is a toplevel test
;; ;; what to do with toplevel? call rollup?
;; (begin
;; (set! toplevels (cons (list test-id run-dir uname testname item-path run-id) toplevels))
;; (debug:print-info 0 *default-log-port* "Found old toplevel test in RUNNING state, test-id=" test-id))
;; (set! incompleted (cons (list test-id run-dir uname testname item-path run-id) incompleted))))
;; (db:get-cache-stmth dbdat db
;; "SELECT id,rundir,uname,testname,item_path FROM tests WHERE run_id=? AND (strftime('%s','now') - event_time) > (run_duration + ?) AND state IN ('RUNNING','REMOTEHOSTSTART');")
;; run-id deadtime)
;;
;; ;; in LAUNCHED for more than one day. Could be long due to job queues TODO/BUG: Need override for this in config
;; ;;
;; ;; (db:delay-if-busy dbdat)
;; (sqlite3:for-each-row
;; (lambda (test-id run-dir uname testname item-path)
;; (if (and (equal? uname "n/a")
;; (equal? item-path "")) ;; this is a toplevel test
;; ;; what to do with toplevel? call rollup?
;; (set! toplevels (cons (list test-id run-dir uname testname item-path run-id) toplevels))
;; (set! oldlaunched (cons (list test-id run-dir uname testname item-path run-id) oldlaunched))))
;; (db:get-cache-stmth dbdat db
;; "SELECT id,rundir,uname,testname,item_path FROM tests WHERE run_id=? AND (strftime('%s','now') - event_time) > 86400 AND state IN ('LAUNCHED');")
;; run-id)
;;
;; (debug:print-info 18 *default-log-port* "Found " (length oldlaunched) " old LAUNCHED items, " (length toplevels) " old LAUNCHED toplevel tests and " (length incompleted) " tests marked RUNNING but apparently dead.")
;; (if (and (null? incompleted)
;; (null? oldlaunched)
;; (null? toplevels))
;; #f
;; #t)))))
;; BUG: Probably broken - does not explicitly use run-id in the query
;;
(define (db:top-test-set-per-pf-counts dbstruct run-id test-name)
(db:general-call dbstruct run-id 'top-test-set-per-pf-counts (list test-name test-name test-name test-name test-name test-name test-name test-name test-name test-name test-name test-name test-name test-name test-name test-name test-name)))
;; Clean out old junk and vacuum the database
;;
;; Ultimately do something like this:
;;
;; 1. Look at test records either deleted or part of deleted run:
;; a. If test dir exists, set the the test to state='UNKNOWN', Set the run to 'unknown'
;; 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 run-id dbdat)
(if run-id
(begin
(debug:print 0 *default-log-port* "Cleaning run DB " run-id)
(db:clean-up-rundb dbdat run-id)
)
(begin
(debug:print 0 *default-log-port* "Cleaning main DB ")
(db:clean-up-maindb dbdat)
)
)
)
;; Clean out old junk and vacuum the database
;;
;; Ultimately do something like this:
;;
;; 1. Look at test records either deleted or part of deleted run:
;; a. If test dir exists, set the the test to state='UNKNOWN', Set the run to 'unknown'
;; 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-rundb dbdat run-id)
;; (debug:print 0 *default-log-port* "WARNING: db clean up not fully ported to v1.60, cleanup action will be on megatest.db")
(let* ((db (dbr:dbdat-dbh dbdat))
(test-count-stmt (sqlite3:prepare db "SELECT (SELECT count(id) FROM tests);"))
(step-count-stmt (sqlite3:prepare db "SELECT (SELECT count(id) FROM test_steps);"))
(statements
(map (lambda (stmt)
(sqlite3:prepare db stmt))
(list
"DELETE FROM tests WHERE state='DELETED';"
"DELETE FROM test_steps WHERE status = 'DELETED';"
"DELETE FROM tests WHERE run_id IN (SELECT id FROM runs WHERE state = 'deleted');"
))))
(sqlite3:with-transaction
db
(lambda ()
(sqlite3:for-each-row (lambda (tot)
(debug:print-info 0 *default-log-port* "Test records count before clean: " tot))
test-count-stmt)
(sqlite3:for-each-row (lambda (tot)
(debug:print-info 0 *default-log-port* "Test_step records count before clean: " tot))
step-count-stmt)
(map sqlite3:execute statements)
(sqlite3:for-each-row (lambda (tot)
(debug:print-info 0 *default-log-port* "Test records count after clean: " tot))
test-count-stmt)
(sqlite3:for-each-row (lambda (tot)
(debug:print-info 0 *default-log-port* "Test_step records count after clean: " tot))
step-count-stmt)))
(map sqlite3:finalize! statements)
(sqlite3:finalize! test-count-stmt)
(sqlite3:finalize! step-count-stmt)
(sqlite3:execute db "VACUUM;")))
;; Clean out old junk and vacuum the database
;;
;; Ultimately do something like this:
;;
;; 1. Look at test records either deleted or part of deleted run:
;; a. If test dir exists, set the the test to state='UNKNOWN', Set the run to 'unknown'
;; 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-maindb 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* ((db (dbr:dbdat-dbh dbdat))
(count-stmt (sqlite3:prepare db "SELECT (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 NOT IN (" (string-intersperse (map conc valid-runs) ",") ");")
;; delete all tests that are 'DELETED'
"DELETE FROM runs WHERE state='deleted';"
)))
(dead-runs '()))
(sqlite3:for-each-row
(lambda (run-id)
(set! dead-runs (cons run-id dead-runs)))
db
"SELECT id FROM runs WHERE state='deleted';")
;; (db:delay-if-busy dbdat)
(sqlite3:with-transaction
db
(lambda ()
(sqlite3:for-each-row (lambda (tot)
(debug:print-info 0 *default-log-port* "Run records count before clean: " tot))
count-stmt)
(map sqlite3:execute statements)
(sqlite3:for-each-row (lambda (tot)
(debug:print-info 0 *default-log-port* "Run 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;")
dead-runs))
;;======================================================================
;; no-sync.db - small bits of data to be shared between servers
;;======================================================================
;; if we are not a server create a db handle. this is not finalized
;; so watch for problems. I'm still not clear if it is needed to manually
;; finalize sqlite3 dbs with the sqlite3 egg.
;;
(define (db:no-sync-db db-in)
(mutex-lock! *db-access-mutex*)
(let ((res (if db-in
db-in
(let ((db (db:open-no-sync-db)))
(set! *no-sync-db* db)
db))))
(mutex-unlock! *db-access-mutex*)
res))
(define (db:get-dbsync-path)
(case (rmt:transport-mode)
((http)(common:make-tmpdir-name *toppath* ""))
((tcp) (conc *toppath*"/.mtdb"))
((nfs) (conc *toppath*"/.mtdb"))
(else "/tmp/dunno-this-gonna-exist")))
(define (db:no-sync-add-job db-in host-type vars-list exekey cmdline)
(sqlite3:execute (db:no-sync-db db-in) "INSERT INTO jobs_queue (host_type,vars,exekey,cmdline,state,event_time,last_update) VALUES (?,?,?,?,?,?,?);"
host-type
(with-output-to-string
(lambda ()
(write vars-list)))
exekey cmdline "waiting" (current-seconds)(current-seconds)))
;; find next job (waiting longest) that matches host-type - future, we'll find jobs that fit if no exact match
(define (db:no-sync-take-job db-in host-type)
(let* ((db (db:no-sync-db db-in))
(stmt1 "SELECT id,host_type,vars,exekey,cmdline,state,event_time,last_update FROM jobs_queue WHERE host_type=? AND state != 'taken' ORDER BY event_time ASC;")
(stmt1h (sqlite3:prepare db stmt1))
(stmt2 "UPDATE jobs_queue SET state='taken',last_update=? WHERE id=?;")
(stmt2h (sqlite3:prepare db stmt2))
(res (sqlite3:with-transaction
db
(lambda ()
(let* ((matching-jobs (sqlite3:fold-row
(lambda (res . row) ;; id host-type vars exekey state event-time last-update)
(cons row res))
'()
stmt1h
host-type)))
(if (null? matching-jobs)
#f
(let ((choosen-one (let loop ((tal matching-jobs)
(res #f)) ;; put bestest one in here
(if (null? tal)
res
(let ((curr (car tal))
(rem (cdr tal)))
curr) ;; here we will compare with res, if better candidate the loop with curr else loop with res
))))
(if choosen-one ;; we need to mark it as taken
(sqlite3:execute stmt2h (current-seconds) (car choosen-one)))
choosen-one)))))))
(sqlite3:finalize! stmt1h) ;; it'd be nice to cache these and finalize on exit.
(sqlite3:finalize! stmt2h)
res))
;; clean out old jobs in queue, i.e. taken and event_time > 24 hrs ago
;;
(define (db:no-sync-job-records-clean db)
(sqlite3:execute (db:no-sync-db db) "DELETE FROM jobs_queue WHERE state='taken' AND event_time < ?;" (- (current-seconds)(* 24 3600))))
(define (db:no-sync-get/default db-in var default)
(let ((db (db:no-sync-db db-in))
(res default))
(sqlite3:for-each-row
(lambda (val)
(set! res val))
(db:no-sync-db db)
"SELECT val FROM no_sync_metadat WHERE var=?;"
var)
(if res
(let ((newres (if (string? res)
(string->number res)
#f)))
(if newres
newres
res))
res)))
;; This is needed for api.scm
(define (db:open-no-sync-db)
(dbfile:open-no-sync-db (db:get-dbsync-path)))
;; why get the keys from the db? why not get from the *configdat*
;; using keys:config-get-fields?
(define (db:get-keys dbstruct)
(keys:config-get-fields *configdat*))
;; extract index number given a header/data structure
(define (db:get-index-by-header header field)
(list-index (lambda (x)(equal? x field)) header))
;; look up values in a header/data structure
(define (db:get-value-by-header row header field)
(let ((len (if (vector? row)
(vector-length row)
0)))
(if (or (null? header) (not row))
#f
(let loop ((hed (car header))
(tal (cdr header))
(n 0))
(if (equal? hed field)
(handle-exceptions
exn
(begin
(debug:print 4 *default-log-port* "WARNING: attempt to read non-existant field, row="
row " header=" header " field=" field ", exn=" exn)
#f)
(if (>= n len)
#f
(vector-ref row n)))
(if (null? tal) #f (loop (car tal)(cdr tal)(+ n 1))))))))
;; Accessors for the header/data structure
;; get rows and header from
(define (db:get-header vec)(vector-ref vec 0))
(define (db:get-rows vec)(vector-ref vec 1))
;;======================================================================
;; R U N S
;;======================================================================
(define (db:get-run-times dbstruct run-patt target-patt)
(let ((res `())
(qry (conc "select runname, (max(end_time)-min(event_time))/60 as runtime, target from (select runname, run_id,tests.event_time,tests.event_time+run_duration AS end_time, " (string-join (db:get-keys dbstruct) " || '/' || ") " as target from tests inner join runs on tests.run_id = runs.id where runs.runname like ? and target like ?) group by run_id ;")))
;(print qry)
(db:with-db
dbstruct
#f ;; this is for the main runs db
#f ;; does not modify db
(lambda (dbdat db)
(sqlite3:for-each-row
(lambda (runname runtime target )
(set! res (cons (vector runname runtime target) res)))
db
qry
run-patt target-patt)
res))))
(define (db:get-run-name-from-id dbstruct run-id)
(db:with-db
dbstruct
#f ;; this is for the main runs db
#f ;; does not modify db
(lambda (dbdat db)
(let ((res #f))
(sqlite3:for-each-row
(lambda (runname)
(set! res runname))
db
"SELECT runname FROM runs WHERE id=?;"
run-id)
res))))
(define (db:get-run-key-val dbstruct run-id key)
(db:with-db
dbstruct
#f
#f
(lambda (dbdat db)
(let ((res #f))
(sqlite3:for-each-row
(lambda (val)
(set! res val))
db
(conc "SELECT " key " FROM runs WHERE id=?;")
run-id)
res))))
;; keys list to key1,key2,key3 ...
(define (runs:get-std-run-fields keys remfields)
(let* ((header (append keys remfields))
(keystr (conc (keys->keystr keys) ","
(string-intersperse remfields ","))))
(list keystr header)))
;; make a query (fieldname like 'patt1' OR fieldname
(define (db:patt->like fieldname pattstr #!key (comparator " OR "))
(let ((patts (if (string? pattstr)
(string-split pattstr ",")
'("%"))))
(string-intersperse (map (lambda (patt)
(let ((wildtype (if (substring-index "%" patt) "LIKE" "GLOB")))
(conc fieldname " " wildtype " '" patt "'")))
(if (null? patts)
'("")
patts))
comparator)))
;; register a test run with the db, this accesses the main.db and does NOT
;; use server api
;;
(define (db:register-run dbstruct keyvals runname state status user contour-in)
(let* ((keys (map car keyvals))
(keystr (keys->keystr keys))
(contour (or contour-in "")) ;; empty string to force no hierarcy and be backwards compatible.
(comma (if (> (length keys) 0) "," ""))
(andstr (if (> (length keys) 0) " AND " ""))
(valslots (keys->valslots keys)) ;; ?,?,? ...
(allvals (append (list runname state status user contour) (map cadr keyvals)))
(qryvals (append (list runname) (map cadr keyvals)))
(key=?str (string-intersperse (map (lambda (k)(conc k "=?")) keys) " AND ")))
;; (debug:print 0 *default-log-port* "Got here 0.")
(debug:print 3 *default-log-port* "keys: " keys " allvals: " allvals " keyvals: " keyvals " key=?str is " key=?str)
(debug:print 2 *default-log-port* "NOTE: using target " (string-intersperse (map cadr keyvals) "/") " for this run")
(if (and runname (null? (filter (lambda (x)(not x)) keyvals))) ;; there must be a better way to "apply and"
(db:with-db
dbstruct #f #t
(lambda (dbdat db)
;; (debug:print 0 *default-log-port* "Got here 1.")
(let ((res #f))
(apply sqlite3:execute db
(conc "INSERT OR IGNORE INTO runs (runname,state,status,owner,event_time,contour"
comma keystr ") VALUES (?,?,?,?,strftime('%s','now'),?" comma valslots ");")
allvals)
(apply sqlite3:for-each-row
(lambda (id)
(set! res id))
db
(let ((qry (conc "SELECT id FROM runs WHERE (runname=? " andstr key=?str ");")))
qry)
qryvals)
(sqlite3:execute db "UPDATE runs SET state=?,status=?,event_time=strftime('%s','now') WHERE id=? AND state='deleted';" state status res)
res)))
(begin
(debug:print-error 0 *default-log-port* "Called without all necessary keys")
#f))))
(define (db:get-run-id dbstruct runname target)
(let ((runs (db:simple-get-runs dbstruct runname #f #f target #f))) ;; runpatt count offset target last-update
(if (null? runs)
#f
(simple-run-id (car runs)))))
;; called with run-id=#f so will operate on main.db
;;
(define (db:insert-run dbstruct run-id target runname run-meta)
(let* ((keys (db:get-keys dbstruct))
(runs (db:simple-get-runs dbstruct runname #f #f target #f))) ;; runpatt count offset target last-update
;; need to insert run based on target and runname
(let* ((targvals (string-split target "/"))
(keystr (string-intersperse keys ","))
(key?str (string-intersperse (make-list (length targvals) "?") ","))
(qrystr (conc "INSERT INTO runs (id,runname,"keystr") VALUES (?,?,"key?str")"))
(get-var (lambda (db qrystr)
(let* ((res #f))
(sqlite3:for-each-row
(lambda row
(set res (car row)))
db qrystr run-id runname)
res))))
(if (null? runs)
(begin
(db:create-initial-run-record dbstruct run-id runname target)
)
)
(let* ()
;;(debug:print 0 *default-log-port* "db:insert-run: Calling db:with-db to update the run record")
(debug:print 0 *default-log-port* "db:insert-run: runid = " run-id)
#; (db:with-db
dbstruct
#f #t
(lambda (dbdat db)
(debug:print 0 *default-log-port* "In the lambda proc for " dbdat " " db)
(for-each
(lambda (keyval)
(debug:print 0 *default-log-port* "In the lambda proc for " keyval)
(let* ((fieldname (car keyval))
(getqry (conc "SELECT "fieldname" FROM runs WHERE id=?;"))
(setqry (conc "UPDATE runs SET "fieldname"=? WHERE id=?;"))
(val (cdr keyval))
(valnum (if (number? val)
val
(if (string? val)
(string->number val)
#f))))
(debug:print 0 *default-log-port* "fieldname " fieldname " val " val " valnum " valnum)
(if (not (member fieldname (cons "runname" keys))) ;; don't attempt to tweak these
(let* ((curr-val (get-var db getqry))
(have-it (or (equal? curr-val val)
(equal? curr-val valnum))))
(debug:print 0 *default-log-port* "have-it = " have-it)
(if (not have-it)
(begin
(debug:print 0 *default-log-port* "Do sqlite3:execute")
;; (sqlite3:execute db setqry (or valnum val) run-id)
)
)
)
)
(debug:print 0 *default-log-port* "Done with update")
)
(debug:print 0 *default-log-port* "next keyval")
)
run-meta)))
run-id))))
(define (db:create-initial-run-record dbstruct run-id runname target)
(let* ((keys (db:get-keys dbstruct))
(targvals (string-split target "/"))
(keystr (string-intersperse keys ","))
(key?str (string-intersperse (make-list (length targvals) "?") ",")) ;; a string with the same length as targvals, where each element is "?" and interspersed with commas.
(qrystr (conc "INSERT INTO runs (id,runname,"keystr") VALUES (?,?,"key?str")")))
(debug:print 0 *default-log-port* "db:create-initial-run-record")
(debug:print 0 *default-log-port* "qrystr = " qrystr)
(db:with-db
dbstruct #f #t ;; run-id writable
(lambda (dbdat db)
(debug:print 0 *default-log-port* "lambda proc: dbdat: " dbdat " db: " db)
(apply sqlite3:execute db qrystr run-id runname targvals)))))
(define (db:insert-test dbstruct run-id test-rec)
(let* ((testname (alist-ref "testname" test-rec equal?))
(item-path (alist-ref "item_path" test-rec equal?))
(id (db:get-test-id dbstruct run-id testname item-path))
(fieldvals (filter (lambda (x)(not (member (car x) '("id" "last_update")))) test-rec))
(setqry (conc "UPDATE tests SET "(string-intersperse
(map (lambda (dat)
(conc (car dat)"=?"))
fieldvals)
",")" WHERE id=?;"))
(insqry (conc "INSERT INTO tests ("(string-intersperse (map (lambda (x) (car x)) fieldvals) ",")
") VALUES ("(string-intersperse (make-list (length fieldvals) "?") ",")");")))
;; (debug:print 0 *default-log-port* "id: "id"\nset: "setqry"\ninsqry: "insqry)
(db:with-db
dbstruct
run-id #t
(lambda (dbdat db)
(if id
(apply sqlite3:execute db setqry (append (map cdr fieldvals) (list id)))
(apply sqlite3:execute db insqry (map cdr fieldvals)))))))
;; replace header and keystr with a call to runs:get-std-run-fields
;;
;; keypatts: ( (KEY1 "abc%def")(KEY2 "%") )
;; runpatts: patt1,patt2 ...
;;
(define (db:get-runs dbstruct runpatt count offset keypatts)
(let* ((res '())
(keys (db:get-keys dbstruct))
(runpattstr (db:patt->like "runname" runpatt))
(remfields (list "id" "runname" "state" "status" "owner" "event_time"))
(header (append keys remfields))
(keystr (conc (keys->keystr keys) ","
(string-intersperse remfields ",")))
(qrystr (conc "SELECT " keystr " FROM runs WHERE (" runpattstr ") " ;; runname LIKE ? "
;; Generate: " AND x LIKE 'keypatt' ..."
(if (null? keypatts) ""
(conc " AND "
(string-join
(map (lambda (keypatt)
(let ((key (car keypatt))
(patt (cadr keypatt)))
(db:patt->like key patt)))
keypatts)
" AND ")))
" AND state != 'deleted' ORDER BY event_time DESC "
(if (number? count)
(conc " LIMIT " count)
"")
(if (number? offset)
(conc " OFFSET " offset)
""))))
(debug:print-info 11 *default-log-port* "db:get-runs START qrystr: " qrystr " keypatts: " keypatts " offset: " offset " limit: " count)
(db:with-db dbstruct #f #f
(lambda (dbdat db)
(sqlite3:for-each-row
(lambda (a . x)
(set! res (cons (apply vector a x) res)))
db
qrystr
)))
(debug:print-info 11 *default-log-port* "db:get-runs END qrystr: " qrystr " keypatts: " keypatts " offset: " offset " limit: " count)
(vector header res)))
;; simple get-runs
;;
;; records used defined in dbfile
;;
(define (db:simple-get-runs dbstruct runpatt count offset target last-update)
(let* ((res '())
(keys (db:get-keys dbstruct))
(runpattstr (db:patt->like "runname" runpatt))
(remfields (list "id" "runname" "state" "status" "owner" "event_time"))
(targstr (string-intersperse keys "||'/'||"))
(keystr (conc targstr " AS target,"
(string-intersperse remfields ",")))
(qrystr (conc "SELECT " keystr " FROM runs WHERE (" runpattstr ") " ;; runname LIKE ? "
;; Generate: " AND x LIKE 'keypatt' ..."
" AND target LIKE '" target "'"
" AND state != 'deleted' "
(if (number? last-update)
(conc " AND last_update >= " last-update)
"")
" ORDER BY event_time DESC "
(if (number? count)
(conc " LIMIT " count)
"")
(if (number? offset)
(conc " OFFSET " offset)
"")))
)
(debug:print-info 11 *default-log-port* "db:get-runs START qrystr: " qrystr " target: " target " offset: " offset " limit: " count)
(db:with-db dbstruct #f #f
(lambda (dbdat db)
(sqlite3:for-each-row
(lambda (target id runname state status owner event_time)
(set! res (cons (make-simple-run target id runname state status owner event_time) res)))
db
qrystr
)))
(debug:print-info 11 *default-log-port* "db:get-runs END qrystr: " qrystr " target: " target " offset: " offset " limit: " count)
res))
;; TODO: Switch this to use max(update_time) from each run db? Then if using a server there is no disk traffic (using cachedb db) ???
;;
;; NOTE: This DOESN'T (necessarily) get the real run ids, but the number of the <number>.db!!
(define (db:get-changed-run-ids since-time)
(let* ((dbdir (common:make-tmpdir-name *toppath* "")) ;; (configf:lookup *configdat* "setup" "dbdir"))
(alldbs (glob (conc *toppath* "/.mtdb/[0-9]*.db*")))
(changed (filter (lambda (dbfile)
(> (file-modification-time dbfile) since-time))
alldbs)))
(delete-duplicates
(map (lambda (dbfile)
(let* ((res (string-match ".*\\/(\\d+)\\.db*" dbfile)))
(if res
(string->number (cadr res))
(begin
(debug:print 2 *default-log-port* "WARNING: Failed to process " dbfile " for run-id")
0))))
changed))))
;; Get all targets from the db
;;
(define (db:get-targets dbstruct)
(let* ((res '())
(keys (db:get-keys dbstruct))
(header keys) ;; (map key:get-fieldname keys))
(keystr (keys->keystr keys))
(qrystr (conc "SELECT " keystr " FROM runs WHERE state != 'deleted';"))
(seen (make-hash-table)))
(db:with-db
dbstruct
#f
#f
(lambda (dbdat db)
(sqlite3:for-each-row
(lambda (a . x)
(let ((targ (cons a x)))
(if (not (hash-table-ref/default seen targ #f))
(begin
(hash-table-set! seen targ #t)
(set! res (cons (apply vector targ) res))))))
db
qrystr)
(debug:print-info 11 *default-log-port* "db:get-targets END qrystr: " qrystr )
(vector header res)))))
;; just get count of runs
(define (db:get-num-runs dbstruct runpatt)
(db:with-db
dbstruct
#f
#f
(lambda (dbdat db)
(let ((numruns 0))
(debug:print-info 11 *default-log-port* "db:get-num-runs START " runpatt)
(sqlite3:for-each-row
(lambda (count)
(set! numruns count))
db
"SELECT COUNT(id) FROM runs WHERE runname LIKE ? AND state != 'deleted';" runpatt)
(debug:print-info 11 *default-log-port* "db:get-num-runs END " runpatt)
numruns))))
;; just get count of runs
(define (db:get-runs-cnt-by-patt dbstruct runpatt targetpatt keys)
(db:with-db
dbstruct
#f
#f
(lambda (dbdat db)
(let ((numruns 0)
(qry-str #f)
(key-patt "")
(keyvals (if targetpatt (keys:target->keyval keys targetpatt) '())))
(for-each (lambda (keyval)
(let* ((key (car keyval))
(patt (cadr keyval))
(fulkey (conc ":" key))
(wildtype (if (substring-index "%" patt) "like" "glob")))
(if patt
(set! key-patt (conc key-patt " AND " key " " wildtype " '" patt "'"))
(begin
(debug:print-error 0 *default-log-port* "searching for runs with no pattern set for " fulkey)
(exit 6)))))
keyvals)
;(print runpatt " -- " key-patt)
(set! qry-str (conc "SELECT COUNT(id) FROM runs WHERE state != 'deleted' AND runname like '" runpatt "'" key-patt))
;(print qry-str )
(sqlite3:for-each-row
(lambda (count)
(set! numruns count))
db
qry-str)
(debug:print-info 11 *default-log-port* "db:get-num-runs END " runpatt)
numruns))))
;; (sqlite3#fold-row proc3670 init3671 db-or-stmt3672 . params3673)>
;;
(define (db:get-raw-run-stats dbstruct run-id)
(db:with-db
dbstruct
run-id
#f
(lambda (dbdat db)
(sqlite3:fold-row
(lambda (res state status count)
(cons (list state status count) res))
'()
db
"SELECT state,status,count(id) AS count FROM tests WHERE run_id=? AND NOT(uname='n/a' AND item_path='') GROUP BY state,status;"
run-id))))
;; Update run_stats for given run_id
;; input data is a list (state status count)
;;
(define (db:update-run-stats dbstruct run-id stats-in)
(let* ((stats (if (list? stats-in)
stats-in
(db:get-raw-run-stats dbstruct run-id))))
(mutex-lock! *db-transaction-mutex*)
(db:with-db
dbstruct
#f
#t
(lambda (dbdat db)
;; remove previous data
(let* ((stmt1 (sqlite3:prepare db "DELETE FROM run_stats WHERE run_id=? AND state=? AND status=?;"))
(stmt2 (sqlite3:prepare db "INSERT INTO run_stats (run_id,state,status,count) VALUES (?,?,?,?);"))
(res
(sqlite3:with-transaction
db
(lambda ()
(for-each
(lambda (dat)
(sqlite3:execute stmt1 run-id (car dat)(cadr dat))
(apply sqlite3:execute stmt2 run-id dat))
stats)))))
(sqlite3:finalize! stmt1)
(sqlite3:finalize! stmt2)
(mutex-unlock! *db-transaction-mutex*)
res)))))
(define (db:get-main-run-stats dbstruct run-id)
(db:with-db
dbstruct
#f ;; this data comes from main
#f
(lambda (dbdat db)
(sqlite3:fold-row
(lambda (res state status count)
(cons (list state status count) res))
'()
db
"SELECT state,status,count FROM run_stats WHERE run_id=? AND run_id IN (SELECT id FROM runs WHERE state NOT IN ('DELETED','deleted'));"
run-id))))
(define (db:print-current-query-stats)
;; generate stats from *db-api-call-time*
(let ((ordered-keys (sort (hash-table-keys *db-api-call-time*)
(lambda (a b)
(let ((sum-a (common:sum (hash-table-ref *db-api-call-time* a)))
(sum-b (common:sum (hash-table-ref *db-api-call-time* b))))
(> sum-a sum-b)))))
(total 0))
(for-each
(lambda (cmd-key)
(let* ((dat (hash-table-ref *db-api-call-time* cmd-key))
(num (length dat))
(avg (if (> num 0)
(/ (common:sum dat)(length dat)))))
(set! total (+ total num))
(debug:print-info 0 *default-log-port* cmd-key "\tavg: " avg " max: " (common:max dat) " min: " (common:min-max < dat) " num: " (length dat))))
ordered-keys)
(debug:print-info 0 *default-log-port* "TOTAL: " total " api calls since start.")))
(define (db:get-all-run-ids dbstruct)
(db:with-db
dbstruct
#f
#f
(lambda (dbdat db)
(let ((run-ids '()))
(sqlite3:for-each-row
(lambda (run-id)
(set! run-ids (cons run-id run-ids)))
db
"SELECT id FROM runs WHERE state != 'deleted' ORDER BY event_time DESC;")
(reverse run-ids)))))
;; get some basic run stats
;;
;; data structure:
;;
;; ( (runname (( state count ) ... ))
;; ( ...
;;
(define (db:get-run-stats dbstruct)
(let* ((totals (make-hash-table))
(curr (make-hash-table))
(res '())
(runs-info '()))
;; First get all the runname/run-ids
(db:with-db
dbstruct #f #f
(lambda (dbdat db)
(sqlite3:for-each-row
(lambda (run-id runname)
(set! runs-info (cons (list run-id runname) runs-info)))
db
"SELECT id,runname FROM runs WHERE state != 'deleted' ORDER BY event_time DESC;"))) ;; If you change this to the more logical ASC please adjust calls to db:get-run-stats
;; for each run get stats data
(for-each
(lambda (run-info)
;; get the net state/status counts for this run
(let* ((run-id (car run-info))
(run-name (cadr run-info)))
(db:with-db
dbstruct
run-id
#f
(lambda (dbdat db)
(sqlite3:for-each-row
(lambda (state status count)
(let ((netstate (if (equal? state "COMPLETED") status state)))
(if (string? netstate)
(begin
(hash-table-set! totals netstate (+ (hash-table-ref/default totals netstate 0) count))
(hash-table-set! curr netstate (+ (hash-table-ref/default curr netstate 0) count))))))
db
"SELECT state,status,count(id) FROM tests AS t WHERE run_id=? GROUP BY state,status ORDER BY state,status DESC;"
run-id)
;; add the per run counts to res
(for-each (lambda (state)
(set! res (cons (list run-name state (hash-table-ref curr state)) res)))
(sort (hash-table-keys curr) string>=))
(set! curr (make-hash-table))))))
runs-info)
(for-each (lambda (state)
(set! res (cons (list "Totals" state (hash-table-ref totals state)) res)))
(sort (hash-table-keys totals) string>=))
res))
;; db:get-runs-by-patt
;; get runs by list of criteria
;; register a test run with the db
;;
;; Use: (db:get-value-by-header (db:get-header runinfo)(db:get-rows runinfo))
;; to extract info from the structure returned
;;
(define (db:get-runs-by-patt dbstruct keys runnamepatt targpatt offset limit fields last-update sort-order ) ;; test-name)
(let* ((tmp (runs:get-std-run-fields keys (or fields '("id" "runname" "state" "status" "owner" "event_time"))))
(keystr (car tmp))
(header (cadr tmp))
(key-patt "")
(runwildtype (if (substring-index "%" runnamepatt) "like" "glob"))
(qry-str #f)
(keyvals (if targpatt (keys:target->keyval keys targpatt) '())))
(for-each (lambda (keyval)
(let* ((key (car keyval))
(patt (cadr keyval))
(fulkey (conc ":" key))
(wildtype (if (substring-index "%" patt) "like" "glob")))
(if patt
(set! key-patt (conc key-patt " AND " key " " wildtype " '" patt "'"))
(begin
(debug:print-error 0 *default-log-port* "searching for runs with no pattern set for " fulkey)
(exit 6)))))
keyvals)
(set! qry-str (conc "SELECT " keystr " FROM runs WHERE state != 'deleted' AND runname " runwildtype " ? " key-patt
(if last-update
(conc " AND last_update >= " last-update " ")
" ")
" ORDER BY event_time " sort-order " "
(if limit (conc " LIMIT " limit) "")
(if offset (conc " OFFSET " offset) "")
";"))
(debug:print-info 4 *default-log-port* "runs:get-runs-by-patt qry=" qry-str " " runnamepatt)
;(print "runs:get-runs-by-patt qry=" qry-str " " runnamepatt)
(vector header
(reverse
(db:with-db
dbstruct #f #f ;; reads db, does not write to it.
(lambda (dbdat db)
(sqlite3:fold-row
(lambda (res . r)
(cons (list->vector r) res))
'()
db
qry-str
runnamepatt)))))))
;; use (get-value-by-header (db:get-header runinfo)(db:get-rows runinfo))
;; NOTE: Does NOT return a list of rows (or one row) for the first slot of the vector
;; this is inconsistent with get-runs but it makes some sense.
;;
(define (db:get-run-info dbstruct run-id)
;;(if (hash-table-ref/default *run-info-cache* run-id #f)
;; (hash-table-ref *run-info-cache* run-id)
(let* ((res (vector #f #f #f #f))
(keys (db:get-keys dbstruct))
(remfields (list "id" "runname" "state" "status" "owner" "event_time" "comment" "fail_count" "pass_count" "contour" "last_update")) ;; "area_id"))
(header (append keys remfields))
(keystr (conc (keys->keystr keys) ","
(string-intersperse remfields ","))))
(debug:print-info 11 *default-log-port* "db:get-run-info run-id: " run-id " header: " header " keystr: " keystr)
(db:with-db
dbstruct #f #f
(lambda (dbdat db)
(sqlite3:for-each-row
(lambda (a . x)
(set! res (apply vector a x)))
db
(conc "SELECT " keystr " FROM runs WHERE id=?;")
run-id)))
(debug:print-info 11 *default-log-port* "db:get-run-info run-id: " run-id " header: " header " keystr: " keystr)
(let ((finalres (vector header res)))
;; (hash-table-set! *run-info-cache* run-id finalres)
finalres)))
(define (db:set-comment-for-run dbstruct run-id comment)
(db:with-db
dbstruct #f #f
(lambda (dbdat db)
(sqlite3:execute db "UPDATE runs SET comment=? WHERE id=?;" comment ;; (sdb:qry 'getid comment)
run-id))))
;; does not (obviously!) removed dependent data. But why not!!?
(define (db:delete-run dbstruct run-id)
(db:with-db
dbstruct #f #t
(lambda (dbdat db)
(sqlite3:with-transaction
db
(lambda ()
(sqlite3:execute db "DELETE FROM test_steps WHERE test_id IN (SELECT id FROM tests WHERE run_id=?);" run-id)
(sqlite3:execute db "DELETE FROM test_data WHERE test_id IN (SELECT id FROM tests WHERE run_id=?);" run-id)
(sqlite3:execute db "UPDATE tests SET state='DELETED',comment='' WHERE run_id=?;" run-id)
;; (db:delay-if-busy dbdat)
(sqlite3:execute db "UPDATE runs SET state='deleted',comment='' WHERE id=?;" run-id))))))
(define (db:update-run-event_time dbstruct run-id)
(db:with-db
dbstruct #f #t
(lambda (dbdat db)
(sqlite3:execute db "UPDATE runs SET event_time=strftime('%s','now') WHERE id=?;" run-id))))
(define (db:lock/unlock-run dbstruct run-id lock unlock user)
(db:with-db
dbstruct #f #t
(lambda (dbdat db)
(let ((newlockval (if lock "locked"
(if unlock
"unlocked"
"locked")))) ;; semi-failsafe
(sqlite3:execute db "UPDATE runs SET state=? WHERE id=?;" newlockval run-id)
(sqlite3:execute db "INSERT INTO access_log (user,accessed,args) VALUES(?,strftime('%s','now'),?);"
user (conc newlockval " " run-id))
(debug:print-info 1 *default-log-port* "" newlockval " run number " run-id)))))
(define (db:set-run-status dbstruct run-id status msg)
(db:with-db
dbstruct #f #t
(lambda (dbdat db)
(if msg
(sqlite3:execute db "UPDATE runs SET status=?,comment=? WHERE id=?;" status msg run-id)
(sqlite3:execute db "UPDATE runs SET status=? WHERE id=?;" status run-id)))))
(define (db:set-run-state-status-db dbdat db run-id state status )
(sqlite3:execute
(db:get-cache-stmth
dbdat db "UPDATE runs SET status=?,state=? WHERE id=?;") status state run-id))
(define (db:set-run-state-status dbstruct run-id state status )
(db:with-db
dbstruct #f #t
(lambda (dbdat db)
(db:set-run-state-status-db dbdat db run-id state status))))
(define (db:get-run-status dbstruct run-id)
(let ((res "n/a"))
(db:with-db
dbstruct #f #f
(lambda (dbdat db)
(sqlite3:for-each-row
(lambda (status)
(set! res status))
(db:get-cache-stmth
dbdat db
"SELECT status FROM runs WHERE id=?;" )
run-id)
res))))
(define (db:get-run-state dbstruct run-id)
(let ((res "n/a"))
(db:with-db
dbstruct #f #f
(lambda (dbdat db)
(sqlite3:for-each-row
(lambda (status)
(set! res status))
(db:get-cache-stmth
dbdat db
"SELECT state FROM runs WHERE id=?;" )
run-id)
res))))
(define (db:get-run-state-status dbstruct run-id)
(let ((res (cons "n/a" "n/a")))
(db:with-db
dbstruct #f #f
(lambda (dbdat db)
(sqlite3:for-each-row
(lambda (state status)
(set! res (cons state status)))
(db:get-cache-stmth
dbdat db
"SELECT state,status FROM runs WHERE id=?;" )
run-id)
res))))
;;======================================================================
;; K E Y S
;;======================================================================
;; get key val pairs for a given run-id
;; ( (FIELDNAME1 keyval1) (FIELDNAME2 keyval2) ... )
(define (db:get-key-val-pairs dbstruct run-id)
(let* ((keys (db:get-keys dbstruct))
(res '()))
(db:with-db
dbstruct #f #f
(lambda (dbdat db)
(for-each
(lambda (key)
(let ((qry (conc "SELECT " key " FROM runs WHERE id=?;")))
(sqlite3:for-each-row
(lambda (key-val)
(set! res (cons (list key (if (string? key-val) key-val "")) res))) ;; replace non-string bad values with empty string to prevent crashes. This scenario can happen when Megatest is killed on updating the db
db qry run-id)))
keys)))
(reverse res)))
;; get key vals for a given run-id
(define (db:get-key-vals dbstruct run-id)
(let* ((keys (db:get-keys dbstruct))
(res '()))
(db:with-db
dbstruct #f #f
(lambda (dbdat db)
(for-each
(lambda (key)
(let ((qry (conc "SELECT " key " FROM runs WHERE id=?;")))
;; (db:delay-if-busy dbdat)
(sqlite3:for-each-row
(lambda (key-val)
(set! res (cons (if (string? key-val) key-val "") res))) ;; check that the key-val is a string for cases where a crash injected bad data in the megatest.db
db qry run-id)))
keys)))
(let ((final-res (reverse res)))
(hash-table-set! *keyvals* run-id final-res)
final-res)))
;; The target is keyval1/keyval2..., cached in *target* as it is used often
(define (db:get-target dbstruct run-id)
(let* ((keyvals (db:get-key-vals dbstruct run-id))
(thekey (string-intersperse (map (lambda (x)(if x x "-na-")) keyvals) "/")))
thekey))
;; Get run-ids for runs with same target but different runnames and NOT run-id
;;
(define (db:get-prev-run-ids dbstruct run-id)
(let* ((keyvals (db:get-key-val-pairs dbstruct run-id))
(kvalues (map cadr keyvals))
(keys (db:get-keys dbstruct))
(qrystr (string-intersperse (map (lambda (x)(conc x "=?")) keys) " AND ")))
(let ((prev-run-ids '()))
(if (null? keyvals)
'()
(begin
(db:with-db dbstruct #f #f ;; #f means work with the zeroth db - i.e. the runs db
(lambda (dbdat db)
(apply sqlite3:for-each-row
(lambda (id)
(set! prev-run-ids (cons id prev-run-ids)))
db
(conc "SELECT id FROM runs WHERE " qrystr " AND state != 'deleted' AND id != ?;")
(append kvalues (list run-id)))))
prev-run-ids)))))
;;======================================================================
;; T E S T S
;;======================================================================
;; states and statuses are lists, turn them into ("PASS","FAIL"...) and use NOT IN
;; i.e. these lists define what to NOT show.
;; states and statuses are required to be lists, empty is ok
;; not-in #t = above behaviour, #f = must match
;; mode:
;; 'dashboard - use state = 'COMPLETED' AND status in ( statuses ) OR state in ( states )
;;
(define (db:get-tests-for-run dbstruct run-id testpatt states statuses offset limit not-in sort-by sort-order qryvals last-update mode)
(let* ((qryvalstr (case qryvals
((shortlist) "id,run_id,testname,item_path,state,status")
((#f) db:test-record-qry-selector) ;; "id,run_id,testname,state,status,event_time,host,cpuload,diskfree,uname,rundir,item_path,run_duration,final_logf,comment")
(else qryvals)))
(res '())
;; if states or statuses are null then assume match all when not-in is false
(states-qry (if (null? states)
#f
(conc " state "
(if (eq? mode 'dashboard)
" IN ('"
(if not-in
" NOT IN ('"
" IN ('"))
(string-intersperse states "','")
"')")))
(statuses-qry (if (null? statuses)
#f
(conc " status "
(if (eq? mode 'dashboard)
" IN ('"
(if not-in
" NOT IN ('"
" IN ('") )
(string-intersperse statuses "','")
"')")))
(interim-qry (conc " AND " (if not-in "NOT " "") "( state='COMPLETED' " (if statuses-qry (conc " AND " statuses-qry " ) ") " ) ")
(if states-qry
(conc (if not-in " AND " " OR ") states-qry ) ;; " ) ")
"")))
(states-statuses-qry
(cond
((and states-qry statuses-qry)
(case mode
((dashboard)
(if not-in
(conc " AND (state='COMPLETED' AND status NOT IN ('" (string-intersperse statuses "','") "')) "
" OR (state != 'COMPLETED' AND state NOT IN ('" (string-intersperse states "','") "')) ")
(conc " AND (state='COMPLETED' AND status IN ('" (string-intersperse statuses "','") "')) "
" OR (state NOT IN ('COMPLETED','DELETED') AND state IN ('" (string-intersperse states "','") "')) ")))
(else (conc " AND ( " states-qry " AND " statuses-qry " ) "))))
(states-qry
(case mode
((dashboard) (conc " AND " (if not-in "NOT " "") " state IN ('" (string-intersperse states "','") "') ")) ;; interim-qry)
(else (conc " AND " states-qry))))
(statuses-qry
(case mode
((dashboard) (conc " AND " (if not-in "NOT " "") " status IN ('" (string-intersperse statuses "','") "') ")) ;; interim-qry)
(else (conc " AND " statuses-qry))))
(else "")))
(tests-match-qry (tests:match->sqlqry testpatt))
(qry (conc "SELECT " qryvalstr
(if run-id
" FROM tests WHERE run_id=? "
" FROM tests WHERE ? > 0 ") ;; should work?
(if last-update " " " AND state != 'DELETED' ") ;; if using last-update we want deleted tests?
states-statuses-qry
(if tests-match-qry (conc " AND (" tests-match-qry ") ") "")
(if last-update (conc " AND last_update >= " last-update " ") "")
(case sort-by
((rundir) " ORDER BY length(rundir) ")
((testname) (conc " ORDER BY testname " (if sort-order (conc sort-order ",") "") " item_path "))
((statestatus) (conc " ORDER BY state " (if sort-order (conc sort-order ",") "") " status "))
((event_time) " ORDER BY event_time ")
(else (if (string? sort-by)
(conc " ORDER BY " sort-by " ")
" ")))
(if sort-order sort-order " ")
(if limit (conc " LIMIT " limit) " ")
(if offset (conc " OFFSET " offset) " ")
";"
)))
(debug:print-info 8 *default-log-port* "db:get-tests-for-run run-id=" run-id ", qry=" qry)
(let* ((res (db:with-db dbstruct run-id #f
(lambda (dbdat db)
;; (let* ((stmth (db:get-cache-stmth dbstruct db qry))) ;; due to use of last-update we can't efficiently cache this query
(reverse
(sqlite3:fold-row
(lambda (res . row)
;; id run-id testname state status event-time host cpuload
;; diskfree uname rundir item-path run-duration final-logf comment)
(cons (list->vector row) res))
'()
db qry ;; stmth
(or run-id 1) ;; 1 > 0 , for the case where we are seeking tests matching criteral for all runs
))))))
(case qryvals
((shortlist)(map db:test-short-record->norm res))
((#f) res)
(else res)))))
(define (db:test-short-record->norm inrec)
;; "id,run_id,testname,item_path,state,status"
;; "id,run_id,testname,state,status,event_time,host,cpuload,diskfree,uname,rundir,item_path,run_duration,final_logf,comment
(vector (vector-ref inrec 0) ;; id
(vector-ref inrec 1) ;; run_id
(vector-ref inrec 2) ;; testname
(vector-ref inrec 4) ;; state
(vector-ref inrec 5) ;; status
-1 "" -1 -1 "" "-"
(vector-ref inrec 3) ;; item-path
-1 "-" "-"))
;;
;; 1. cache tests-match-qry
;; 2. compile qry and store in hash
;; 3. convert for-each-row to fold
;;
;; (define (db:get-tests-for-run-state-status dbstruct run-id testpatt)
;; (db:with-db
;; dbstruct run-id #f
;; (lambda (dbdat db)
;; (let* ((res '())
;; (stmt-cache (dbr:dbstruct-stmt-cache dbstruct))
;; (stmth (let* ((sh (db:hoh-get stmt-cache db testpatt)))
;; (or sh
;; (let* ((tests-match-qry (tests:match->sqlqry testpatt))
;; (qry (conc "SELECT id,testname,item_path,state,status FROM tests WHERE run_id=? "
;; (if tests-match-qry (conc " AND (" tests-match-qry ") ") "")))
;; (newsh (sqlite3:prepare db qry)))
;; (debug:print-info 8 *default-log-port* "db:get-tests-for-run qry=" qry)
;; (db:hoh-set! stmt-cache db testpatt newsh)
;; newsh)))))
;; (reverse
;; (sqlite3:fold-row
;; (lambda (res id testname item-path state status)
;; ;; id,run_id,testname,state,status,event_time,host,cpuload,diskfree,uname,rundir,item_path,run_duration,final_logf,comment
;; (cons (vector id run-id testname state status -1 "" -1 -1 "" "-" item-path -1 "-" "-") res))
;; '()
;; stmth
;; run-id))))))
(define (db:get-tests-for-run-state-status dbstruct run-id testpatt #!optional (last-update 0))
(let* ((res '())
(tests-match-qry (tests:match->sqlqry testpatt))
(qry (conc "SELECT id,testname,item_path,state,status,event_time,run_duration FROM tests WHERE run_id=? "
" AND last_update > ? "
(if tests-match-qry (conc " AND (" tests-match-qry ") ") "")
)))
(debug:print-info 8 *default-log-port* "db:get-tests-for-run qry=" qry)
(db:with-db dbstruct run-id #f
(lambda (dbdat db)
(sqlite3:fold-row
(lambda (res id testname item-path state status event-time run-duration)
;; id,run_id,testname,state,status,event_time,host,cpuload,diskfree,uname,rundir,item_path,run_duration,final_logf,comment
(cons (vector id run-id testname state status event-time "" -1 -1 "" "-" item-path run-duration "-" "-") res))
'()
db
qry
run-id
(or last-update 0))))))
(define (db:get-testinfo-state-status dbstruct run-id test-id)
(db:with-db
dbstruct run-id #f
(lambda (dbdat db)
(let* ((res #f)
(stmth (db:get-cache-stmth dbdat db "SELECT run_id,testname,item_path,state,status FROM tests WHERE id=? and run_id=?;")))
(sqlite3:for-each-row
(lambda (run-id testname item-path state status)
;; id,run_id,testname,state,status,event_time,host,cpuload,diskfree,uname,rundir,item_path,run_duration,final_logf,comment
(set! res (vector test-id run-id testname state status -1 "" -1 -1 "" "-" item-path -1 "-" "-")))
;; db
;; "SELECT run_id,testname,item_path,state,status FROM tests WHERE id=? and run_id=?;"
stmth
test-id run-id)
res))))
;; get a useful subset of the tests data (used in dashboard
;; use db:mintest-get-{id ,run_id,testname ...}
;;
(define (db:get-tests-for-run-mindata dbstruct run-id testpatt states statuses not-in)
(db:get-tests-for-run dbstruct run-id testpatt states statuses #f #f not-in #f #f "id,run_id,testname,state,status,event_time,item_path" 0 #f))
;; do not use.
;;
(define (db:get-tests-for-runs dbstruct run-ids testpatt states statuses #!key (not-in #f)(qryvals #f))
;; (db:delay-if-busy)
(let ((res '()))
(for-each
(lambda (run-id)
(set! res (append
res
(db:get-tests-for-run dbstruct run-id testpatt states statuses #f #f not-in #f #f qryvals #f 'normal))))
(if run-ids
run-ids
(db:get-all-run-ids dbstruct)))
res))
;; Convert calling routines to get list of run-ids and loop, do not use the get-tests-for-runs
;;
(define (db:delete-test-records dbstruct run-id test-id)
(db:general-call dbstruct run-id 'delete-test-step-records (list test-id))
(db:general-call dbstruct run-id 'delete-test-data-records (list test-id))
(db:with-db
dbstruct run-id #t
(lambda (dbdat db)
(sqlite3:execute db "UPDATE tests SET state='DELETED',status='n/a',comment='' WHERE id=?;" test-id))))
;;
(define (db:delete-old-deleted-test-records dbstruct run-id)
(let* ((targtime (- (current-seconds)
(or (configf:lookup-number *configdat* "setup" "keep-deleted-records")
(* 7 24 60 60)))) ;; cleanup if over one week old
(mtdbfile (dbmod:run-id->full-dbfname dbstruct run-id))
(qry1 "DELETE FROM test_steps WHERE test_id IN (SELECT id FROM tests WHERE state='DELETED' AND event_time<?);")
(qry2 "DELETE FROM test_data WHERE test_id IN (SELECT id FROM tests WHERE state='DELETED' AND event_time<?);")
(qry3 "DELETE FROM tests WHERE state='DELETED' AND event_time<?;")
(delproc (lambda (db)
(sqlite3:with-transaction
db
(lambda ()
(sqlite3:execute db qry1 targtime)
(sqlite3:execute db qry2 targtime)
(sqlite3:execute db qry3 targtime))))))
;; first the /tmp db
(db:with-db
dbstruct
run-id
#t
(lambda (dbdat db)
(delproc db)))
(if (and (file-exists? mtdbfile)
(file-write-access? mtdbfile))
(let* ((db (sqlite3:open-database mtdbfile)))
(delproc db)
(sqlite3:finalize! db)))))
;; set tests with state currstate and status currstatus to newstate and newstatus
;; use currstate = #f and or currstatus = #f to apply to any state or status respectively
;; WARNING: SQL injection risk. NB// See new but not yet used "faster" version below
;;
;; AND NOT (item_path='' AND testname in (SELECT DISTINCT testname FROM tests WHERE testname=? AND item_path != ''));")))
;; (debug:print 0 *default-log-port* "QRY: " qry)
;; (db:delay-if-busy)
;;
;; NB// This call only operates on toplevel tests. Consider replacing it with more general call
;;
(define (db:set-tests-state-status dbstruct run-id testnames currstate currstatus newstate newstatus)
(let ((test-ids '()))
(for-each
(lambda (testname)
(let ((qry (conc "UPDATE tests SET state=?,status=? WHERE "
(if currstate (conc "state='" currstate "' AND ") "")
(if currstatus (conc "status='" currstatus "' AND ") "")
" run_id=? AND testname LIKE ?;"))
(test-id (db:get-test-id dbstruct run-id testname "")))
(db:with-db
dbstruct
run-id
#t
(lambda (dbdat db)
(sqlite3:execute db qry
(or newstate currstate "NOT_STARTED")
(or newstatus currstate "UNKNOWN")
run-id testname)))
(if test-id
(begin
(set! test-ids (cons test-id test-ids))
(mt:process-triggers dbstruct run-id test-id newstate newstatus)))))
testnames)
test-ids))
;; ;; speed up for common cases with a little logic
;; ;; NB// Ultimately this will be deprecated in deference to mt:test-set-state-status-by-id
;;
;; NOTE: run-id is not used
;; ;;
(define (db:test-set-state-status dbstruct run-id test-id newstate newstatus newcomment)
(db:with-db
dbstruct
run-id #t
(lambda (dbdat db)
(db:test-set-state-status-db db run-id test-id newstate newstatus newcomment))))
(define (db:test-set-state-status-db db run-id test-id newstate newstatus newcomment)
(cond
((and newstate newstatus newcomment)
(sqlite3:execute db "UPDATE tests SET state=?,status=?,comment=? WHERE id=?;" newstate newstatus newcomment ;; (sdb:qry 'getid newcomment)
test-id))
((and newstate newstatus)
(sqlite3:execute db "UPDATE tests SET state=?,status=? WHERE id=?;" newstate newstatus test-id))
(else
(if newstate (sqlite3:execute db "UPDATE tests SET state=? WHERE id=?;" newstate test-id))
(if newstatus (sqlite3:execute db "UPDATE tests SET status=? WHERE id=?;" newstatus test-id))
(if newcomment (sqlite3:execute db "UPDATE tests SET comment=? WHERE id=?;" newcomment ;; (sdb:qry 'getid newcomment)
test-id))))
;; (mt:process-triggers dbstruct run-id test-id newstate newstatus)) ;; NOTE: Moved into calling function
)
;; NEW BEHAVIOR: Count tests running in all runs!
;;
(define (db:get-count-tests-running dbstruct run-id) ;; fastmode)
(let* ((qry "SELECT count(id) FROM tests WHERE state in ('RUNNING','LAUNCHED','REMOTEHOSTSTART') AND NOT (uname = 'n/a' AND item_path = '');"))
(db:with-db
dbstruct
run-id
#f
(lambda (dbdat db)
(let* ((stmth (db:get-cache-stmth dbdat db qry)))
(sqlite3:first-result stmth))))))
;; NEW BEHAVIOR: Count tests running in only one run!
;;
(define (db:get-count-tests-actually-running dbstruct run-id)
(db:with-db
dbstruct
run-id
#f
(lambda (dbdat db)
(sqlite3:first-result
db
;; WARNING BUG EDIT ME - merged from v1.55 - not sure what is right here ...
;; "SELECT count(id) FROM tests WHERE state in ('RUNNING','LAUNCHED','REMOTEHOSTSTART') AND run_id NOT IN (SELECT id FROM runs WHERE state='deleted') AND NOT (uname = 'n/a' AND item_path = '');")
"SELECT count(id) FROM tests WHERE state in ('RUNNING','REMOTEHOSTSTART','LAUNCHED') AND run_id=?;"
run-id)))) ;; NOT IN (SELECT id FROM runs WHERE state='deleted');")
;; 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 dbstruct run-id) ;; fastmode)
(let* ((qry ;; (if fastmode
;; "SELECT count(id) FROM tests WHERE state in ('RUNNING','LAUNCHED','REMOTEHOSTSTART') AND run_id=? LIMIT 1;"
"SELECT count(id) FROM tests WHERE state in ('RUNNING','LAUNCHED','REMOTEHOSTSTART') AND run_id=?;")) ;; )
(db:with-db
dbstruct
run-id
#f
(lambda (dbdat db)
(let* ((stmth (db:get-cache-stmth dbdat db qry)))
(sqlite3:first-result stmth run-id))))))
;; For a given testname how many items are running? Used to determine
;; probability for regenerating html
;;
(define (db:get-count-tests-running-for-testname dbstruct run-id testname)
(db:with-db
dbstruct
run-id
#f
(lambda (dbdat db)
(let* ((stmt "SELECT count(id) FROM tests WHERE state in ('RUNNING','LAUNCHED','REMOTEHOSTSTART') AND run_id=? AND NOT (uname = 'n/a' AND item_path = '') AND testname=?;")
(stmth (db:get-cache-stmth dbdat db stmt)))
(sqlite3:first-result
stmth run-id testname)))))
(define (db:get-not-completed-cnt dbstruct run-id)
(db:with-db
dbstruct
run-id
#f
(lambda (dbdat db)
;(print "SELECT count(id) FROM tests WHERE state not in ('COMPLETED', 'DELETED') AND run_id=" run-id)
(sqlite3:first-result
db
"SELECT count(id) FROM tests WHERE state not in ('COMPLETED', 'DELETED') AND run_id=?;" run-id))))
(define (db:get-count-tests-running-in-jobgroup dbstruct run-id jobgroup)
(if (not jobgroup)
0 ;;
(let ((testnames '()))
;; get the testnames
(db:with-db
dbstruct #f #f
(lambda (dbdat db)
(sqlite3:for-each-row
(lambda (testname)
(set! testnames (cons testname testnames)))
db
"SELECT testname FROM test_meta WHERE jobgroup=?"
jobgroup)))
;; get the jobcount NB// EXTEND THIS TO OPPERATE OVER ALL RUNS?
(if (not (null? testnames))
(db:with-db
dbstruct
run-id
#f
(lambda (dbdat db)
(sqlite3:first-result
db
(conc "SELECT count(id) FROM tests WHERE state in ('RUNNING','LAUNCHED','REMOTEHOSTSTART') AND testname in ('"
(string-intersperse testnames "','")
"') AND NOT (uname = 'n/a' AND item_path='');")) ;; should this include the (uname = 'n/a' ...) ???
))
0))))
;; tags: '("tag%" "tag2" "%ag6")
;;
;; done with run when:
;; 0 tests in LAUNCHED, NOT_STARTED, REMOTEHOSTSTART, RUNNING
(define (db:estimated-tests-remaining dbstruct run-id)
(db:with-db
dbstruct
run-id
#f
(lambda (dbdat db)
(sqlite3:first-result
db
"SELECT count(id) FROM tests WHERE state in ('LAUNCHED','NOT_STARTED','REMOTEHOSTSTART','RUNNING','KILLREQ') AND run_id=?;")
run-id)))
;; map run-id, testname item-path to test-id
(define (db:get-test-id dbstruct run-id testname item-path)
(db:with-db
dbstruct
run-id
#f
(lambda (dbdat db)
(db:first-result-default
db
"SELECT id FROM tests WHERE testname=? AND item_path=? AND run_id=?;"
#f ;; the default
testname item-path run-id))))
;; overload the unused attemptnum field for the process id of the runscript or
;; ezsteps step script in progress
;;
(define (db:test-set-top-process-pid dbstruct run-id test-id pid)
(db:with-db
dbstruct
run-id
#t
(lambda (dbdat db)
(sqlite3:execute db "UPDATE tests SET attemptnum=? WHERE id=?;"
pid test-id))))
(define (db:test-get-top-process-pid dbstruct run-id test-id)
(db:with-db
dbstruct
run-id
#f
(lambda (dbdat db)
(db:first-result-default
db
"SELECT attemptnum FROM tests WHERE id=? AND run_id=?;"
#f
test-id run-id))))
(define db:test-record-fields '("id" "run_id" "testname" "state" "status" "event_time"
"host" "cpuload" "diskfree" "uname" "rundir" "item_path"
"run_duration" "final_logf" "comment" "shortdir" "attemptnum" "archived" "last_update"))
;; fields *must* be a non-empty list
;;
(define (db:field->number fieldname fields)
(if (null? fields)
#f
(let loop ((hed (car fields))
(tal (cdr fields))
(indx 0))
(if (equal? fieldname hed)
indx
(if (null? tal)
#f
(loop (car tal)(cdr tal)(+ indx 1)))))))
(define db:test-record-qry-selector (string-intersperse db:test-record-fields ","))
(define (db:update-tesdata-on-repilcate-db dbstruct old-lt new-lt)
(db:with-db
dbstruct #f #t
(lambda (dbdat db)
(sqlite3:execute db "UPDATE tests SET rundir= replace(rundir,?,?), shortdir=replace(shortdir,?,?);"
old-lt new-lt old-lt new-lt))))
;; NOTE: Use db:test-get* to access records
;; NOTE: This needs rundir 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 '()))
(db:with-db
dbstruct #f #f
(lambda (dbdat db)
(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 shortdir attemptnum archived)
;; 0 1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16
(set! res (cons (vector id run-id testname state status event-time host cpuload diskfree uname rundir item-path run-duration final-logf comment shortdir attemptnum archived)
res)))
db
(conc "SELECT " db:test-record-qry-selector " FROM tests WHERE state != 'DELETED' AND run_id=?;")
run-id)))
res))
(define (db:replace-test-records dbstruct run-id testrecs)
(db:with-db dbstruct run-id #t
(lambda (dbdat db)
(let* ((qmarks (string-intersperse (make-list (length db:test-record-fields) "?") ","))
(qrystr (conc "INSERT OR REPLACE INTO tests (" db:test-record-qry-selector ") VALUES (" qmarks ") WHERE run_id=?;"))
(qry (sqlite3:prepare db qrystr)))
(debug:print 0 *default-log-port* "INFO: migrating test records for run with id " run-id)
(sqlite3:with-transaction
db
(lambda ()
(for-each
(lambda (rec)
;; (debug:print 0 *default-log-port* "INFO: Inserting values: " (string-intersperse (map conc (vector->list rec)) ",") "\n")
(apply sqlite3:execute qry (append (vector->list rec)(list run-id))))
testrecs)))
(sqlite3:finalize! qry)))))
;; map a test-id into the proper range
;;
(define (db:adj-test-id mtdb min-test-id test-id)
(if (>= test-id min-test-id)
test-id
(let loop ((new-id min-test-id))
(let ((test-id-found #f))
(sqlite3:for-each-row
(lambda (id)
(set! test-id-found id))
(dbr:dbdat-dbh mtdb)
"SELECT id FROM tests WHERE id=?;"
new-id)
;; if test-id-found then need to try again
(if test-id-found
(loop (+ new-id 1))
(begin
(debug:print-info 0 *default-log-port* "New test id " new-id " selected for test with id " test-id)
(sqlite3:execute mtdb "UPDATE tests SET id=? WHERE id=?;" new-id test-id)))))))
;; move test ids into the 30k * run_id range
;;
(define (db:prep-megatest.db-adj-test-ids mtdb run-id testrecs)
(debug:print-info 0 *default-log-port* "Adjusting test ids in megatest.db for run " run-id)
(let ((min-test-id (* run-id 30000)))
(for-each
(lambda (testrec)
(let* ((test-id (vector-ref testrec (db:field->number "id" db:test-record-fields))))
(db:adj-test-id (dbr:dbdat-dbh mtdb) min-test-id test-id)))
testrecs)))
;; 1. move test ids into the 30k * run_id range
;; 2. move step ids into the 30k * run_id range
;;
(define (db:prep-megatest.db-for-migration mtdb)
(let* ((run-ids (db:get-all-run-ids mtdb)))
(for-each
(lambda (run-id)
(let ((testrecs (db:get-all-tests-info-by-run-id mtdb run-id)))
(db:prep-megatest.db-adj-test-ids (dbr:dbdat-dbh mtdb) run-id testrecs)))
run-ids)))
;; Get test data using test_id
;;
(define (db:get-test-info-by-id dbstruct run-id test-id)
(db:with-db
dbstruct
run-id
#f
(lambda (dbdat db)
(let ((res #f))
(sqlite3:for-each-row ;; attemptnum added to hold pid of top process (not Megatest) controlling a test
(lambda (id run-id testname state status event-time host cpuload diskfree uname rundir-id item-path run_duration final-logf-id comment short-dir-id attemptnum archived last-update)
;; 0 1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16
(set! res (vector id run-id testname state status event-time host cpuload diskfree uname rundir-id item-path run_duration final-logf-id comment short-dir-id attemptnum archived last-update)))
db
;; (db:get-cache-stmth dbdat db
;; (conc "SELECT " db:test-record-qry-selector " FROM tests WHERE id=? AND run_id=?;"))
(conc "SELECT " db:test-record-qry-selector " FROM tests WHERE id=? AND run_id=?;")
test-id run-id)
res))))
;; Get test state, status using test_id
;;
(define (db:get-test-state-status-by-id dbstruct run-id test-id)
(db:with-db
dbstruct
run-id
#f
(lambda (dbdat db)
(let ((res (cons #f #f))
(stmth (db:get-cache-stmth dbdat db "SELECT state,status FROM tests WHERE id=? AND run_id=?;")))
(sqlite3:for-each-row ;; attemptnum added to hold pid of top process (not Megatest) controlling a test
(lambda (state status)
(cons state status))
;; db
stmth ;;"SELECT state,status FROM tests WHERE id=? AND run_id=?;" ;; stmth try not compiling this one - yes, this fixed the bind issue
test-id run-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)
(db:with-db
dbstruct
run-id
#f
(lambda (dbdat db)
(let ((res '()))
(sqlite3:for-each-row
(lambda (a . b)
;; 0 1 2 3 4 5 6 7 8 9 10 11 12 13 14
(set! res (cons (apply vector a b) res)))
db
(conc "SELECT " db:test-record-qry-selector " FROM tests WHERE id in ("
(string-intersperse (map conc test-ids) ",") ");"))
res))))
;; try every second until tries times proc
;;
(define (db:keep-trying-until-true proc params tries)
(let* ((res (apply proc params)))
(if res
res
(if (> tries 0)
(begin
(thread-sleep! 1)
(db:keep-trying-until-true proc params (- tries 1)))
(begin
;; (debug:print-info 0 *default-log-port* "proc never returned true, params="params)
(print"db:keep-trying-until-true proc never returned true, proc = " proc " params =" params " tries = " tries)
#f)))))
(define (db:get-test-info dbstruct run-id test-name item-path)
(db:with-db
dbstruct
run-id
#f
(lambda (dbdat db)
(db:get-test-info-db db run-id test-name item-path))))
(define (db:get-test-info-db db run-id test-name item-path)
(let ((res #f))
(sqlite3:for-each-row
(lambda (a . b)
(set! res (apply vector a b)))
db
(conc "SELECT " db:test-record-qry-selector " FROM tests WHERE testname=? AND item_path=? AND run_id=?;")
test-name item-path run-id)
res))
(define (db:test-get-rundir-from-test-id dbstruct run-id test-id)
(db:with-db
dbstruct
run-id
#f
(lambda (dbdat db)
(db:first-result-default
db
"SELECT rundir FROM tests WHERE id=? AND run_id=?;"
#f ;; default result
test-id run-id))))
(define (db:get-test-times dbstruct run-name target)
(let ((res `())
(qry (conc "select testname, item_path, run_duration, "
(string-join (db:get-keys dbstruct) " || '/' || ")
" as target from tests inner join runs on tests.run_id = runs.id where runs.runname = ? and target = ? ;")))
(db:with-db
dbstruct
#f ;; this is for the main runs db
#f ;; does not modify db
(lambda (dbdat db)
(sqlite3:for-each-row
(lambda (test-name item-path test-time target )
(set! res (cons (vector test-name item-path test-time) res)))
db
qry
run-name target)
res))))
;;======================================================================
;; S T E P S
;;======================================================================
(define (db:teststep-set-status! dbstruct run-id test-id teststep-name state-in status-in comment logfile)
(db:with-db
dbstruct
run-id
#t
(lambda (dbdat db)
(sqlite3:execute
db
"INSERT OR REPLACE into test_steps (test_id,stepname,state,status,event_time,comment,logfile) VALUES(?,?,?,?,?,?,?);"
test-id teststep-name state-in status-in (current-seconds)
(if comment comment "")
(if logfile logfile "")))))
(define (db:delete-steps-for-test! dbstruct run-id test-id)
;; TODO: figure out why status is the key field rather than state (note: CONSTRAINT test_steps_constraint UNIQUE (test_id,stepname,state) )
(db:with-db
dbstruct
run-id
#t
(lambda (dbdat db)
(sqlite3:execute
db
"UPDATE test_steps set status='DELETED' where test_id=?" ;; and run_id=? !! - run_id not in table (bummer) TODO: get run_id into schema for test_steps
test-id))))
;; db-get-test-steps-for-run
(define (db:get-steps-for-test dbstruct run-id test-id)
(db:with-db
dbstruct
run-id
#f
(lambda (dbdat db)
(let* ((res '()))
(sqlite3:for-each-row
(lambda (id test-id stepname state status event-time logfile comment)
(set! res (cons (vector id test-id stepname state status event-time (if (string? logfile) logfile "") comment) res)))
db
"SELECT id,test_id,stepname,state,status,event_time,logfile,comment FROM test_steps WHERE status != 'DELETED' AND test_id=? ORDER BY id ASC;" ;; event_time DESC,id ASC;
test-id)
(reverse res)))))
(define (db:get-steps-info-by-id dbstruct run-id test-step-id)
(db:with-db
dbstruct
run-id
#f
(lambda (dbdat db)
(let* ((res (vector #f #f #f #f #f #f #f #f #f)))
(sqlite3:for-each-row
(lambda (id test-id stepname state status event-time logfile comment last-update)
(set! res (vector id test-id stepname state status event-time (if (string? logfile) logfile "") comment last-update)))
db
"SELECT id,test_id,stepname,state,status,event_time,logfile,comment,last_update FROM test_steps WHERE id=? ORDER BY id ASC;" ;; event_time DESC,id ASC;
test-step-id)
res))))
(define (db:get-steps-data dbstruct run-id test-id)
(db:with-db
dbstruct
run-id
#f
(lambda (dbdat db)
(let ((res '()))
(sqlite3:for-each-row
(lambda (id test-id stepname state status event-time logfile)
(set! res (cons (vector id test-id stepname state status event-time (if (string? logfile) logfile "")) res)))
db
"SELECT id,test_id,stepname,state,status,event_time,logfile FROM test_steps WHERE status != 'DELETED' AND test_id=? ORDER BY id ASC;" ;; event_time DESC,id ASC;
test-id)
(reverse res)))))
;;======================================================================
;; T E S T D A T A
;;======================================================================
(define (db:get-data-info-by-id dbstruct run-id test-data-id)
(let* ((stmt "SELECT id,test_id, category, variable, value, expected, tol, units, comment, status, type, last_update FROM test_data WHERE id=? ORDER BY id ASC;")) ;; event_time DESC,id ASC;
(db:with-db
dbstruct
run-id
#f
(lambda (dbdat db)
(let* ((stmth (db:get-cache-stmth dbdat db stmt))
(res (sqlite3:fold-row
(lambda (res id test-id category variable value expected tol units comment status type last-update)
(vector id test-id category variable value expected tol units comment status type last-update))
(vector #f #f #f #f #f #f #f #f #f #f #f #f)
stmth
test-data-id)))
res)))))
;; WARNING: Do NOT call this for the parent test on an iterated test
;; Roll up test_data pass/fail results
;; look at the test_data status field,
;; if all are pass (any case) and the test status is PASS or NULL or '' then set test status to PASS.
;; if one or more are fail (any case) then set test status to PASS, non "pass" or "fail" are ignored
(define (db:test-data-rollup dbstruct run-id test-id status)
(let* ((fail-count 0)
(pass-count 0))
(db:with-db
dbstruct run-id #t
(lambda (dbdat db)
(sqlite3:for-each-row
(lambda (fcount pcount)
(set! fail-count fcount)
(set! pass-count pcount))
db
"SELECT (SELECT count(id) FROM test_data WHERE test_id=? AND status like 'fail') AS fail_count,
(SELECT count(id) FROM test_data WHERE test_id=? AND status like 'pass') AS pass_count;"
test-id test-id)
;; Now rollup the counts to the central megatest.db
(db:general-call dbstruct run-id 'pass-fail-counts (list pass-count fail-count test-id))
;; if the test is not FAIL then set status based on the fail and pass counts.
(db:general-call dbstruct run-id 'test_data-pf-rollup (list test-id test-id test-id test-id))))))
;; each section is a rule except "final" which is the final result
;;
;; [rule-5]
;; operator in
;; section LogFileBody
;; desc Output voltage
;; status OK
;; expected 1.9
;; measured 1.8
;; type +/-
;; tolerance 0.1
;; pass 1
;; fail 0
;;
;; [final]
;; exit-code 6
;; exit-status SKIP
;; message If flagged we are asking for this to exit with code 6
;;
;; recorded in steps table:
;; category: stepname
;; variable: rule-N
;; value: measured
;; expected: expected
;; tol: tolerance
;; units: -
;; comment: desc or message
;; status: status
;; type: type
;;
(define (db:logpro-dat->csv dat stepname)
(let ((res '()))
(for-each
(lambda (entry-name)
(if (equal? entry-name "final")
(set! res (append
res
(list
(list stepname
entry-name
(configf:lookup dat entry-name "exit-code") ;; 0 ;; Value
0 ;; 1 ;; Expected
0 ;; 2 ;; Tolerance
"n/a" ;; 3 ;; Units
(configf:lookup dat entry-name "message") ;; 4 ;; Comment
(configf:lookup dat entry-name "exit-status") ;; 5 ;; Status
"logpro" ;; 6 ;; Type
))))
(let* ((value (or (configf:lookup dat entry-name "measured") "n/a"))
(expected (or (configf:lookup dat entry-name "expected") 0.0))
(tolerance (or (configf:lookup dat entry-name "tolerance") 0.0))
(comment (or (configf:lookup dat entry-name "comment")
(configf:lookup dat entry-name "desc") "n/a"))
(status (or (configf:lookup dat entry-name "status") "n/a"))
(type (or (configf:lookup dat entry-name "expected") "n/a")))
(set! res (append
res
(list (list stepname
entry-name
value ;; 0
expected ;; 1
tolerance ;; 2
"n/a" ;; 3 Units
comment ;; 4
status ;; 5
type ;; 6
)))))))
(hash-table-keys dat))
res))
;; $MT_MEGATEST -load-test-data << EOF
;; foo,bar, 1.2, 1.9, >
;; foo,rab, 1.0e9, 10e9, 1e9
;; foo,bla, 1.2, 1.9, <
;; foo,bal, 1.2, 1.2, < , ,Check for overload
;; foo,alb, 1.2, 1.2, <= , Amps,This is the high power circuit test
;; foo,abl, 1.2, 1.3, 0.1
;; foo,bra, 1.2, pass, silly stuff
;; faz,bar, 10, 8mA, , ,"this is a comment"
;; EOF
(define (db:csv->test-data dbstruct run-id test-id csvdata)
(debug:print 4 *default-log-port* "test-id " test-id ", csvdata: " csvdata)
(db:with-db
dbstruct #f #t
(lambda (dbdat db)
(let* ((csvlist (csv->list (make-csv-reader
(open-input-string csvdata)
'((strip-leading-whitespace? #t)
(strip-trailing-whitespace? #t)))))) ;; (csv->list csvdata)))
(for-each
(lambda (csvrow)
(let* ((padded-row (take (append csvrow (list #f #f #f #f #f #f #f #f #f)) 9))
(category (list-ref padded-row 0))
(variable (list-ref padded-row 1))
(value (any->number-if-possible (list-ref padded-row 2)))
(expected (any->number-if-possible (list-ref padded-row 3)))
(tol (any->number-if-possible (list-ref padded-row 4))) ;; >, <, >=, <=, or a number
(units (list-ref padded-row 5))
(comment (list-ref padded-row 6))
(status (let ((s (list-ref padded-row 7)))
(if (and (string? s)(or (string-match (regexp "^\\s*$") s)
(string-match (regexp "^n/a$") s)))
#f
s))) ;; if specified on the input then use, else calculate
(type (list-ref padded-row 8)))
;; look up expected,tol,units from previous best fit test if they are all either #f or ''
(debug:print 4 *default-log-port* "BEFORE: category: " category " variable: " variable " value: " value
", expected: " expected " tol: " tol " units: " units " status: " status " comment: " comment " type: " type)
(if (and (or (not expected)(equal? expected ""))
(or (not tol) (equal? expected ""))
(or (not units) (equal? expected "")))
(let-values (((new-expected new-tol new-units)(tdb:get-prev-tol-for-test #f test-id category variable)))
(set! expected new-expected)
(set! tol new-tol)
(set! units new-units)))
(debug:print 4 *default-log-port* "AFTER: category: " category " variable: " variable " value: " value
", expected: " expected " tol: " tol " units: " units " status: " status " comment: " comment)
;; calculate status if NOT specified
(if (and (not status)(number? expected)(number? value)) ;; need expected and value to be numbers
(if (number? tol) ;; if tol is a number then we do the standard comparison
(let* ((max-val (+ expected tol))
(min-val (- expected tol))
(result (and (>= value min-val)(<= value max-val))))
(debug:print 4 *default-log-port* "max-val: " max-val " min-val: " min-val " result: " result)
(set! status (if result "pass" "fail")))
(set! status ;; NB// need to assess each one (i.e. not return operator since need to act if not valid op.
(case (string->symbol tol) ;; tol should be >, <, >=, <=
((>) (if (> value expected) "pass" "fail"))
((<) (if (< value expected) "pass" "fail"))
((>=) (if (>= value expected) "pass" "fail"))
((<=) (if (<= value expected) "pass" "fail"))
(else (conc "ERROR: bad tol comparator " tol))))))
(debug:print 4 *default-log-port* "AFTER2: category: " category " variable: " variable " value: " value
", expected: " expected " tol: " tol " units: " units " status: " status " comment: " comment)
;; (db:delay-if-busy dbdat)
(sqlite3:execute db "INSERT OR REPLACE INTO test_data (test_id,category,variable,value,expected,tol,units,comment,status,type) VALUES (?,?,?,?,?,?,?,?,?,?);"
test-id category variable value expected tol units (if comment comment "") status type)))
csvlist)))))
;; This routine moved from tdb.scm, tdb:read-test-data
;;
(define (db:read-test-data dbstruct run-id test-id categorypatt)
(let* ((res '()))
(db:with-db
dbstruct #f #f
(lambda (dbdat db)
(sqlite3:for-each-row
(lambda (id test_id category variable value expected tol units comment status type)
(set! res (cons (vector id test_id category variable value expected tol units comment status type) res)))
db
"SELECT id,test_id,category,variable,value,expected,tol,units,comment,status,type FROM test_data WHERE test_id=? AND category LIKE ? ORDER BY category,variable;" test-id categorypatt)
(reverse res)))))
;; This routine moved from tdb.scm, :read-test-data
;;
(define (db:read-test-data-varpatt dbstruct run-id test-id categorypatt varpatt)
(let* ((res '()))
(db:with-db
dbstruct #f #f
(lambda (dbdat db)
(sqlite3:for-each-row
(lambda (id test_id category variable value expected tol units comment status type)
(set! res (cons (vector id test_id category variable value expected tol units comment status type) res)))
db
"SELECT id,test_id,category,variable,value,expected,tol,units,comment,status,type FROM test_data WHERE test_id=? AND category LIKE ? AND variable LIKE ? ORDER BY category,variable;" test-id categorypatt varpatt)
(reverse res)))))
;;======================================================================
;; Misc. test related queries
;;======================================================================
(define (db:get-run-ids-matching-target dbstruct keynames target res runname testpatt statepatt statuspatt)
(db:with-db
dbstruct #f #f
(lambda (dbdat db)
(let* ((row-ids '())
(keystr (string-intersperse
(map (lambda (key val)
(conc key " like '" val "'"))
keynames
(string-split target "/"))
" AND "))
;; (testqry (tests:match->sqlqry testpatt))
(runsqry (sqlite3:prepare db (conc "SELECT id FROM runs WHERE " keystr " AND runname LIKE '" runname "';"))))
;; (debug:print 8 *default-log-port* "db:test-get-paths-matching-keynames-target-new\n runsqry=" runsqry "\n tstsqry=" testqry)
(sqlite3:for-each-row
(lambda (rid)
(set! row-ids (cons rid row-ids)))
runsqry)
(sqlite3:finalize! runsqry)
row-ids))))
;; finds latest matching all patts for given run-id
;;
(define (db:test-get-paths-matching-keynames-target-new dbstruct run-id keynames target res testpatt statepatt statuspatt runname)
(let* ((testqry (tests:match->sqlqry testpatt))
(tstsqry (conc "SELECT rundir FROM tests WHERE run_id=? AND " testqry " AND state LIKE '" statepatt "' AND status LIKE '" statuspatt "' ORDER BY event_time ASC;")))
(db:with-db
dbstruct
run-id
#f
(lambda (dbdat db)
(sqlite3:for-each-row
(lambda (p)
(set! res (cons p res)))
db
tstsqry
run-id)
res))))
(define (db:test-toplevel-num-items dbstruct run-id testname)
(db:with-db
dbstruct
run-id
#f
(lambda (dbdat db)
(let ((res 0))
(sqlite3:for-each-row
(lambda (num-items)
(set! res num-items))
db
"SELECT count(id) FROM tests WHERE run_id=? AND testname=? AND item_path != '' AND state NOT IN ('DELETED');"
run-id
testname)
res))))
;;======================================================================
;; QUEUE UP META, TEST STATUS AND STEPS REMOTE ACCESS
;;======================================================================
;; NOTE: Can remove the regex and base64 encoding for zmq
(define (db:obj->string obj #!key (transport 'http))
(case transport
;; ((fs) obj)
((http fs)
(string-substitute
(regexp "=") "_"
(base64:base64-encode
(z3:encode-buffer
(with-output-to-string
(lambda ()(serialize obj))))) ;; BB: serialize - this is what causes problems between different builds of megatest communicating. serialize is sensitive to binary image of mtest.
#t))
((zmq nmsg)(with-output-to-string (lambda ()(serialize obj))))
(else obj))) ;; rpc
(define (db:string->obj msg #!key (transport 'http))
(case transport
;; ((fs) msg)
((http fs)
(if (string? msg)
(with-input-from-string
(z3:decode-buffer
(base64:base64-decode
(string-substitute
(regexp "_") "=" msg #t)))
(lambda ()(deserialize)))
(begin
(debug:print-error 0 *default-log-port* "reception failed. Received \"" msg "\" but cannot translate it.")
(print-call-chain (current-error-port))
msg))) ;; crude reply for when things go awry
((zmq nmsg)(with-input-from-string msg (lambda ()(deserialize))))
(else msg))) ;; rpc
;; ; This is to be the big daddy call NOPE: Replaced by db:set-state-status-and-roll-up-items
;; ;
;; define (db:test-set-state-status dbstruct run-id test-id state status msg)
;; (let ((dbdat (db:get-subdb dbstruct run-id)))
;; (if (member state '("LAUNCHED" "REMOTEHOSTSTART"))
;; (db:general-call dbdat 'set-test-start-time (list test-id)))
;; ;; (if msg
;; ;; (db:general-call dbdat 'state-status-msg (list state status msg test-id))
;; ;; (db:general-call dbdat 'state-status (list state status test-id)))
;; (db:set-state-status-and-roll-up-items dbstruct run-id test-id #f state status msg)
;; ;; process the test_data table
;; (if (and test-id state status (equal? status "AUTO"))
;; (db:test-data-rollup dbstruct run-id test-id status))
;; (mt:process-triggers dbstruct run-id test-id state status)))
;; state is the priority rollup of all states
;; status is the priority rollup of all completed statesfu
;;
;; if test-name is an integer work off that as test-id instead of test-name test-path
;;
(define (db:set-state-status-and-roll-up-items dbstruct run-id test-name item-path state status comment)
;; establish info on incoming test followed by info on top level test
;; BBnote - for mode itemwait, linkage between upstream test & matching item status is propagated to run queue in db:prereqs-not-met
(let* ((testdat (if (number? test-name)
(db:get-test-info-by-id dbstruct run-id test-name) ;; test-name is actually a test-id
(db:keep-trying-until-true ;; in our threaded stuff this call could happen before the test is registered (maybe?)
db:get-test-info
(list dbstruct run-id test-name item-path)
10)))
(test-id (db:test-get-id testdat))
(test-name (if (number? test-name)
(db:test-get-testname testdat)
test-name))
(item-path (db:test-get-item-path testdat))
(tl-testdat (db:get-test-info dbstruct run-id test-name ""))
(tl-test-id (if tl-testdat
(db:test-get-id tl-testdat)
#f))
(new-state-eh #f)
(new-status-eh #f))
(if (member state '("LAUNCHED" "REMOTEHOSTSTART"))
(db:general-call dbstruct run-id 'set-test-start-time (list test-id)))
(mutex-lock! *db-transaction-mutex*)
(db:with-db
dbstruct run-id #t
(lambda (dbdat db)
(let ((tr-res
(sqlite3:with-transaction
db
(lambda ()
;; NB// Pass the db so it is part fo the transaction
(db:test-set-state-status-db db run-id test-id state status comment) ;; this call sets the item state/status
(if (not (equal? item-path "")) ;; only roll up IF incoming test is an item
(let* ((state-status-counts (db:get-all-state-status-counts-for-test db run-id test-name item-path state status)) ;; item-path is used to exclude current state/status of THIS test
(state-statuses (db:roll-up-rules state-status-counts state status))
(newstate (car state-statuses))
(newstatus (cadr state-statuses)))
(set! new-state-eh newstate)
(set! new-status-eh newstatus)
(debug:print 4 *default-log-port* "BB> tl-test-id="tl-test-id" ; "test-name":"item-path" newstate="newstate" newstatus="newstatus" len(sscs)="(length state-status-counts) " state-status-counts: "
(apply conc
(map (lambda (x)
(conc
(with-output-to-string (lambda () (pp (dbr:counts->alist x)))) " | "))
state-status-counts))); end debug:print
(if tl-test-id
(db:test-set-state-status-db db run-id tl-test-id newstate newstatus #f)) ;; we are still in the transaction - must access the db and not the dbstruct
))))))
(mutex-unlock! *db-transaction-mutex*)
(if (and test-id state status (equal? status "AUTO"))
(db:test-data-rollup dbstruct run-id test-id status))
(if new-state-eh ;; moved from db:test-set-state-status
(mt:process-triggers dbstruct run-id test-id new-state-eh new-status-eh))
tr-res)))))
(define (db:roll-up-rules state-status-counts state status)
(if (null? state-status-counts)
'(#f #f)
(let* ((running (length (filter (lambda (x)
(member (dbr:counts-state x) *common:running-states*))
state-status-counts)))
(bad-not-started (length (filter (lambda (x)
(and (equal? (dbr:counts-state x) "NOT_STARTED")
(not (member (dbr:counts-status x) *common:not-started-ok-statuses*))))
state-status-counts)))
(all-curr-states (common:special-sort ;; worst -> best (sort of)
(delete-duplicates
(if (and state (not (member state *common:dont-roll-up-states*)))
(cons state (map dbr:counts-state state-status-counts))
(map dbr:counts-state state-status-counts)))
*common:std-states* >))
(all-curr-statuses (common:special-sort ;; worst -> best
(delete-duplicates
(if (and state status (not (member state *common:dont-roll-up-states*)))
(cons status (map dbr:counts-status state-status-counts))
(map dbr:counts-status state-status-counts)))
*common:std-statuses* >))
(non-completes (filter (lambda (x)
(not (member x (cons "COMPLETED" *common:dont-roll-up-states*))))
all-curr-states))
(preq-fails (filter (lambda (x)
(equal? x "PREQ_FAIL"))
all-curr-statuses))
(num-non-completes (length non-completes))
(newstate (cond
((> running 0) "RUNNING") ;; anything running, call the situation running
((> (length preq-fails) 0) "NOT_STARTED")
((> bad-not-started 0) "COMPLETED") ;; we have an ugly situation, it is completed in the sense we cannot do more.
((> num-non-completes 0) (car non-completes)) ;; (remove (lambda (x)(equal? "COMPLETED" x)) all-curr-states))) ;; only rollup DELETED if all DELETED
(else (car all-curr-states))))
(newstatus (cond
((> (length preq-fails) 0) "PREQ_FAIL")
((or (> bad-not-started 0)
(and (equal? newstate "NOT_STARTED")
(> num-non-completes 0)))
"STARTED")
(else (car all-curr-statuses)))))
(debug:print-info 2 *default-log-port*
"\n--> probe db:set-state-status-and-roll-up-items: "
"\n--> state-status-counts: "(map dbr:counts->alist state-status-counts)
"\n--> running: "running
"\n--> bad-not-started: "bad-not-started
"\n--> non-non-completes: "num-non-completes
"\n--> non-completes: "non-completes
"\n--> all-curr-states: "all-curr-states
"\n--> all-curr-statuses: "all-curr-statuses
"\n--> newstate "newstate
"\n--> newstatus "newstatus
"\n\n")
;; NB// Pass the db so it is part of the transaction
(list newstate newstatus))))
(define (db:set-state-status-and-roll-up-run dbstruct run-id curr-state curr-status)
(mutex-lock! *db-transaction-mutex*)
(db:with-db
dbstruct run-id #t
(lambda (dbdat db)
(let ((tr-res
(sqlite3:with-transaction
db
(lambda ()
(let* ((state-status-counts (db:get-all-state-status-counts-for-run-db dbdat db run-id))
(state-statuses (db:roll-up-rules state-status-counts #f #f ))
(newstate (car state-statuses))
(newstatus (cadr state-statuses)))
(if (or (not (eq? newstate curr-state)) (not (eq? newstatus curr-status)))
(db:set-run-state-status-db dbdat db run-id newstate newstatus )))))))
(mutex-unlock! *db-transaction-mutex*)
tr-res))))
(define (db:get-all-state-status-counts-for-run-db dbdat db run-id)
(sqlite3:map-row
(lambda (state status count)
(make-dbr:counts state: state status: status count: count))
(db:get-cache-stmth
dbdat db
"SELECT state,status,count(id) FROM tests WHERE run_id=? GROUP BY state,status;")
run-id ))
(define (db:get-all-state-status-counts-for-run dbstruct run-id)
(db:with-db
dbstruct #f #f
(lambda (dbdat db)
(db:get-all-state-status-counts-for-run-db dbdat db run-id))))
;; BBnote: db:get-all-state-status-counts-for-test returns dbr:counts object aggregating state and status of items of a given test, *not including rollup state/status*
;;
;; NOTE: This is called within a transaction
;;
(define (db:get-all-state-status-counts-for-test db run-id test-name item-path item-state-in item-status-in)
(let* ((test-info (db:get-test-info-db db run-id test-name item-path))
(item-state (or item-state-in (db:test-get-state test-info)))
(item-status (or item-status-in (db:test-get-status test-info)))
(other-items-count-recs (sqlite3:map-row
(lambda (state status count)
(make-dbr:counts state: state status: status count: count))
db
;; ignore current item because we have changed its value in the current transation so this select will see the old value.
"SELECT state,status,count(id) FROM tests WHERE run_id=? AND testname=? AND item_path != '' AND item_path !=? GROUP BY state,status;"
run-id test-name item-path))
;; add current item to tally outside of sql query
(match-countrec-lambda (lambda (countrec)
(and (equal? (dbr:counts-state countrec) item-state)
(equal? (dbr:counts-status countrec) item-status))))
(already-have-count-rec-list
(filter match-countrec-lambda other-items-count-recs)) ;; will have either 0 or 1 count recs depending if another item shares this item's state/status
(updated-count-rec (if (null? already-have-count-rec-list)
(make-dbr:counts state: item-state status: item-status count: 1)
(let* ((our-count-rec (car already-have-count-rec-list))
(new-count (add1 (dbr:counts-count our-count-rec))))
(make-dbr:counts state: item-state status: item-status count: new-count))))
(nonmatch-countrec-lambda (lambda (countrec) (not (match-countrec-lambda countrec))))
(unrelated-rec-list
(filter nonmatch-countrec-lambda other-items-count-recs)))
(cons updated-count-rec unrelated-rec-list)))
;; (define (db:get-all-item-states db run-id test-name)
;; (sqlite3:map-row
;; (lambda (a) a)
;; db
;; "SELECT DISTINCT state FROM tests WHERE item_path != '' AND state != 'DELETED' AND run_id=? AND testname=?"
;; run-id test-name))
;;
;; (define (db:get-all-item-statuses db run-id test-name)
;; (sqlite3:map-row
;; (lambda (a) a)
;; db
;; "SELECT DISTINCT status FROM tests WHERE item_path != '' AND state != 'DELETED' AND state='COMPLETED' AND run_id=? AND testname=?"
;; run-id test-name))
(define (db:test-get-logfile-info dbstruct run-id test-name)
(db:with-db
dbstruct
run-id
#f
(lambda (dbdat db)
(let ((res #f))
(sqlite3:for-each-row
(lambda (path final_logf)
;; (let ((path (sdb:qry 'getstr path-id))
;; (final_logf (sdb:qry 'getstr final_logf-id)))
(set! logf final_logf)
(set! res (list path final_logf))
(if (directory? path)
(debug:print 2 *default-log-port* "Found path: " path)
(debug:print 2 *default-log-port* "No such path: " path))) ;; )
db
"SELECT rundir,final_logf FROM tests WHERE testname=? AND item_path='' AND run_id=?;"
test-name run-id)
res))))
;;======================================================================
;; A G R E G A T E D T R A N S A C T I O N D B W R I T E S
;;======================================================================
(define db:queries
(list '(update-run-duration "UPDATE tests SET run_duration=? WHERE id=?;")
;; TESTS
'(register-test "INSERT OR IGNORE INTO tests (run_id,testname,event_time,item_path,state,status) VALUES (?,?,strftime('%s','now'),?,'NOT_STARTED','n/a');")
;; Test state and status
'(set-test-state "UPDATE tests SET state=? WHERE id=?;")
'(set-test-status "UPDATE tests SET state=? WHERE id=?;")
'(state-status "UPDATE tests SET state=?,status=? WHERE id=?;") ;; D/ONE
'(state-status-msg "UPDATE tests SET state=?,status=?,comment=? WHERE id=?;") ;; DONE
;; Test comment
'(set-test-comment "UPDATE tests SET comment=? WHERE id=?;")
'(set-test-start-time "UPDATE tests SET event_time=strftime('%s','now') WHERE id=?;") ;; DONE
'(pass-fail-counts "UPDATE tests SET pass_count=?,fail_count=? WHERE id=?;")
;; test_data-pf-rollup is used to set a tests PASS/FAIL based on the pass/fail info from the steps
'(test_data-pf-rollup "UPDATE tests
SET status=CASE WHEN (SELECT fail_count FROM tests WHERE id=?) > 0
THEN 'FAIL'
WHEN (SELECT pass_count FROM tests WHERE id=?) > 0 AND
(SELECT status FROM tests WHERE id=?) NOT IN ('WARN','FAIL')
THEN 'PASS'
ELSE status
END WHERE id=?;") ;; DONE
'(test-set-log "UPDATE tests SET final_logf=? WHERE id=?;") ;; DONE
;; '(test-set-rundir-by-test-id "UPDATE tests SET rundir=? WHERE id=?") ;; DONE
;; '(test-set-rundir "UPDATE tests SET rundir=? AND testname=? AND item_path=?;") ;; DONE
'(test-set-rundir-shortdir "UPDATE tests SET rundir=?,shortdir=? WHERE testname=? AND item_path=? AND run_id=?;") ;; BROKEN!!! NEEDS run-id
'(delete-tests-in-state ;; "DELETE FROM tests WHERE state=?;") ;; DONE
"UPDATE tests SET state='DELETED' WHERE state=?")
'(tests:test-set-toplog "UPDATE tests SET final_logf=? WHERE run_id=? AND testname=? AND item_path='';")
'(update-cpuload-diskfree "UPDATE tests SET cpuload=?,diskfree=? WHERE id=?;") ;; DONE
'(update-uname-host "UPDATE tests SET uname=?,host=? WHERE id=?;") ;; DONE
'(update-test-rundat "INSERT INTO test_rundat (test_id,update_time,cpuload,diskfree,diskusage,run_duration) VALUES (?,?,?,?,?,?);")
'(update-test-state "UPDATE tests SET state=? WHERE state=? AND run_id=? AND testname=? AND NOT (item_path='' AND testname IN (SELECT DISTINCT testname FROM tests WHERE testname=? AND item_path != ''));")
'(update-test-status "UPDATE tests SET status=? WHERE status like ? AND run_id=? AND testname=? AND NOT (item_path='' AND testname IN (SELECT DISTINCT testname FROM tests WHERE testname=? AND item_path != ''));")
;; stuff for set-state-status-and-roll-up-items
'(update-pass-fail-counts "UPDATE tests
SET fail_count=(SELECT count(id) FROM tests WHERE testname=? AND item_path != '' AND status IN ('FAIL','CHECK','INCOMPLETE','ABORT')),
pass_count=(SELECT count(id) FROM tests WHERE testname=? AND item_path != '' AND status IN ('PASS','WARN','WAIVED'))
WHERE testname=? AND item_path='' AND run_id=?;") ;; DONE ;; BROKEN!!! NEEDS run-id
'(top-test-set-running "UPDATE tests SET state='RUNNING' WHERE testname=? AND item_path='' AND run_id=?;") ;; DONE ;; BROKEN!!! NEEDS run-id
;; NOT USED
;;
;; Might be the following top-test-set-per-pf-counts query could be better based off of something like this:
;;
;; select state,status,count(state) from tests where run_id=59 AND testname='runfirst' group by state,status;
;;
'(top-test-set-per-pf-counts "UPDATE tests
SET state=CASE
WHEN (SELECT count(id) FROM tests
WHERE testname=?
AND item_path != ''
AND status NOT IN ('n/a')
AND state in ('NOT_STARTED')) > 0 THEN 'UNKNOWN'
WHEN (SELECT count(id) FROM tests
WHERE testname=?
AND item_path != ''
AND (status NOT IN ('TEN_STRIKES','BLOCKED') OR status IN ('INCOMPLETE'))
AND state in ('RUNNING','NOT_STARTED','LAUNCHED','REMOTEHOSTSTART')) > 0 THEN 'RUNNING'
WHEN (SELECT count(id) FROM tests
WHERE testname=?
AND item_path != ''
AND state NOT IN ('COMPLETED','DELETED')) = 0 THEN 'COMPLETED'
WHEN (SELECT count(id) FROM tests
WHERE testname=?
AND item_path != ''
AND state = 'NOT_STARTED') > 0 THEN 'NOT_STARTED'
ELSE 'UNKNOWN' END,
status=CASE
WHEN fail_count > 0 THEN 'FAIL'
WHEN (SELECT count(id) FROM tests
WHERE testname=?
AND item_path != ''
AND state IN ('BLOCKED','INCOMPLETE')) > 0 THEN 'FAIL'
WHEN (SELECT count(id) FROM tests
WHERE testname=?
AND item_path != ''
AND state NOT IN ('DELETED')
AND status IN ('INCOMPLETE','ABORT')) > 0 THEN 'ABORT'
WHEN (SELECT count(id) FROM tests
WHERE testname=?
AND item_path != ''
AND state NOT IN ('DELETED')
AND status = 'AUTO') > 0 THEN 'AUTO'
WHEN (SELECT count(id) FROM tests
WHERE testname=?
AND item_path != ''
AND state NOT IN ('DELETED')
AND status IN ('STUCK/INCOMPLETE', 'INCOMPLETE')) > 0 THEN 'INCOMPLETE'
WHEN (SELECT count(id) FROM tests
WHERE testname=?
AND item_path != ''
AND state IN ('COMPLETED','STUCK/INCOMPLETE','INCOMPLETE')
AND status = 'FAIL') > 0 THEN 'FAIL'
WHEN (SELECT count(id) FROM tests
WHERE testname=?
AND item_path != ''
AND state NOT IN ('DELETED')
AND status = 'CHECK') > 0 THEN 'CHECK'
WHEN (SELECT count(id) FROM tests
WHERE testname=?
AND item_path != ''
AND state NOT IN ('DELETED')
AND status = 'SKIP') > 0 THEN 'SKIP'
WHEN (SELECT count(id) FROM tests
WHERE testname=?
AND item_path != ''
AND state NOT IN ('DELETED')
AND status = 'WARN') > 0 THEN 'WARN'
WHEN (SELECT count(id) FROM tests
WHERE testname=?
AND item_path != ''
AND state NOT IN ('DELETED')
AND status = 'WAIVED') > 0 THEN 'WAIVED'
WHEN (SELECT count(id) FROM tests
WHERE testname=?
AND item_path != ''
AND state NOT IN ('DELETED')
AND status NOT IN ('PASS','FAIL','WARN','WAIVED')) > 0 THEN 'ABORT'
WHEN (SELECT count(id) FROM tests
WHERE testname=?
AND item_path != ''
AND state='NOT_STARTED') > 0 THEN 'n/a'
WHEN (SELECT count(id) FROM tests
WHERE testname=?
AND item_path != ''
AND state = 'COMPLETED'
AND status = 'PASS') > 0 THEN 'PASS'
WHEN pass_count > 0 AND fail_count=0 THEN 'PASS'
ELSE 'UNKNOWN' END
WHERE testname=? AND item_path='';") ;; DONE ;; BROKEN!!! NEEDS run-id
;; STEPS
'(delete-test-step-records "UPDATE test_steps SET status='DELETED' WHERE test_id=?;")
'(delete-test-data-records "UPDATE test_data SET status='DELETED' WHERE test_id=?;") ;; using status since no state field
))
(define (db:lookup-query qry-name)
(let ((q (alist-ref qry-name db:queries)))
(if q (car q) #f)))
;; do not run these as part of the transaction
(define db:special-queries '(rollup-tests-pass-fail
;; db:set-state-status-and-roll-up-items ;; WHY NOT!?
login
immediate
flush
sync
set-verbosity
killserver
))
(define (db:login dbstruct calling-path calling-version client-signature)
(cond
((not (equal? calling-path *toppath*))
(list #f "Login failed due to mismatch paths: " calling-path ", " *toppath*))
;; ((not (equal? *run-id* run-id))
;; (list #f "Login failed due to mismatch run-id: " run-id ", " *run-id*))
((not (equal? megatest-version calling-version))
(list #t (conc "Login warning due to mismatch megatest version: " calling-version ", " megatest-version)))
(else
(hash-table-set! *logged-in-clients* client-signature (current-seconds))
'(#t "successful login"))))
;; NO WAY TO KNOW IF IT MODIFIES THE DB BUT NEARLY ALL ARE UPDATES/INSERTS
;;
(define (db:general-call dbstruct run-id stmtname params)
;; Why is db:lookup-query above not used here to get the query?
(let ((query (let ((q (alist-ref (if (string? stmtname)
(string->symbol stmtname)
stmtname)
db:queries)))
(if q (car q) #f))))
(db:with-db
dbstruct run-id #t
(lambda (dbdat db)
(apply sqlite3:execute db query params)
#t))))
;; get a summary of state and status counts to calculate a rollup
;;
(define (db:get-state-status-summary dbstruct run-id testname)
(let ((res '()))
(db:with-db
dbstruct run-id #f
(lambda (dbdat db)
(sqlite3:for-each-row
(lambda (state status count)
(set! res (cons (vector state status count) res)))
db
"SELECT state,status,count(state) FROM tests WHERE run_id=? AND testname=? AND item_path='' GROUP BY state,status;"
run-id testname)
res))))
(define (db:get-latest-host-load dbstruct raw-hostname)
(let* ((hostname (string-substitute "\\..*$" "" raw-hostname))
(res (cons -1 0)))
(db:with-db
dbstruct #f #f
(lambda (dbdat db)
(sqlite3:for-each-row
(lambda (cpuload update-time) (set! res (cons cpuload update-time)))
db
"SELECT tr.cpuload, tr.update_time FROM test_rundat tr, tests t WHERE t.host=? AND tr.cpuload != -1 AND tr.test_id=t.id ORDER BY tr.update_time DESC LIMIT 1;"
hostname))) res ))
(define (db:set-top-level-from-items dbstruct run-id testname)
(let* ((summ (db:get-state-status-summary dbstruct run-id testname))
(find (lambda (state status)
(if (null? summ)
#f
(let loop ((hed (car summ))
(tal (cdr summ)))
(if (and (string-match state (vector-ref hed 0))
(string-match status (vector-ref hed 1)))
hed
(if (null? tal)
#f
(loop (car tal)(cdr tal)))))))))
;;; E D I T M E ! !
(cond
((> (find "COMPLETED" ".*") 0) #f))))
;; get the previous records for when these tests were run where all keys match but runname
;; NB// Merge this with test:get-previous-test-run-records? This one looks for all matching tests
;; can use wildcards. Also can likely be factored in with get test paths?
;;
;; Run this remotely!!
;;
(define (db:get-matching-previous-test-run-records dbstruct run-id test-name item-path)
(let* ((keys (db:get-keys dbstruct))
(selstr (string-intersperse keys ","))
(qrystr (string-intersperse (map (lambda (x)(conc x "=?")) keys) " AND "))
(keyvals #f)
(tests-hash (make-hash-table)))
;; first look up the key values from the run selected by run-id
(db:with-db
dbstruct #f #f
(lambda (dbdat db)
(sqlite3:for-each-row
(lambda (a . b)
(set! keyvals (cons a b)))
db
(conc "SELECT " selstr " FROM runs WHERE id=? ORDER BY event_time DESC;") run-id)))
(if (not keyvals)
'()
(let ((prev-run-ids '()))
(db:with-db
dbstruct #f #f
(lambda (dbdat db)
(apply sqlite3:for-each-row
(lambda (id)
(set! prev-run-ids (cons id prev-run-ids)))
db
(conc "SELECT id FROM runs WHERE " qrystr " AND id != ?;") (append keyvals (list run-id)))))
;; collect all matching tests for the runs then
;; extract the most recent test and return that.
(debug:print 4 *default-log-port* "selstr: " selstr ", qrystr: " qrystr ", keyvals: " keyvals
", previous run ids found: " prev-run-ids)
(if (null? prev-run-ids) '() ;; no previous runs? return null
(let loop ((hed (car prev-run-ids))
(tal (cdr prev-run-ids)))
(let ((results (db:get-tests-for-run dbstruct hed (conc test-name "/" item-path) '() '() #f #f #f #f #f #f #f 'normal)))
(debug:print 4 *default-log-port* "Got tests for run-id " run-id ", test-name " test-name
", item-path " item-path " results: " (intersperse results "\n"))
;; Keep only the youngest of any test/item combination
(for-each
(lambda (testdat)
(let* ((full-testname (conc (db:test-get-testname testdat) "/" (db:test-get-item-path testdat)))
(stored-test (hash-table-ref/default tests-hash full-testname #f)))
(if (or (not stored-test)
(and stored-test
(> (db:test-get-event_time testdat)(db:test-get-event_time stored-test))))
;; this test is younger, store it in the hash
(hash-table-set! tests-hash full-testname testdat))))
results)
(if (null? tal)
(map cdr (hash-table->alist tests-hash)) ;; return a list of the most recent tests
(loop (car tal)(cdr tal))))))))))
;; Function recursively checks if <db>.journal exists; if yes means db busy; call itself after delayed interval
;; return the sqlite3 db handle if possible
;;
(define (db:delay-if-busy dbdat #!key (count 6))
(if (not (configf:lookup *configdat* "server" "delay-on-busy"))
(and dbdat (dbr:dbdat-dbh dbdat))
(if dbdat
(let* ((dbpath (dbr:dbdat-dbfile dbdat))
(db (dbr:dbdat-dbh dbdat)) ;; we'll return this so (db:delay--if-busy can be called inline
(dbfj (conc dbpath "-journal")))
(if (handle-exceptions
exn
(begin
(debug:print-info 0 *default-log-port* "WARNING: failed to test for existance of " dbfj ", exn=" exn)
(thread-sleep! 1)
(db:delay-if-busy count (- count 1)))
(common:file-exists? dbfj))
(case count
((6)
(thread-sleep! 0.2)
(db:delay-if-busy count: 5))
((5)
(thread-sleep! 0.4)
(db:delay-if-busy count: 4))
((4)
(thread-sleep! 0.8)
(db:delay-if-busy count: 3))
((3)
(thread-sleep! 1.6)
(db:delay-if-busy count: 2))
((2)
(thread-sleep! 3.2)
(db:delay-if-busy count: 1))
((1)
(thread-sleep! 6.4)
(db:delay-if-busy count: 0))
(else
(debug:print-info 0 *default-log-port* "delaying db access due to high database load.")
(thread-sleep! 12.8))))
db)
"bogus result from db:delay-if-busy")))
(define (db:test-get-records-for-index-file dbstruct run-id test-name)
(let ((res '()))
(db:with-db
dbstruct
run-id
#f
(lambda (dbdat db)
(sqlite3:for-each-row
(lambda (id itempath state status run_duration logf comment)
(set! res (cons (vector id itempath state status run_duration logf comment) res)))
db
"SELECT id,item_path,state,status,run_duration,final_logf,comment FROM tests WHERE testname=? AND item_path != '' AND run_id=?;" ;; BUG! WHY NO run_id?
test-name
run-id)
res))))
;;======================================================================
;; Tests meta data
;;======================================================================
;; returns a hash table of tags to tests
;;
(define (db:get-tests-tags dbstruct)
(db:with-db
dbstruct #f #f
(lambda (dbdat db)
(let* ((res (make-hash-table)))
(sqlite3:for-each-row
(lambda (testname tags-in)
(let ((tags (string-split tags-in ",")))
(for-each
(lambda (tag)
(hash-table-set! res tag
(delete-duplicates
(cons testname (hash-table-ref/default res tag '())))))
tags)))
db
"SELECT testname,tags FROM test_meta")
(hash-table->alist res)))))
;; testmeta doesn't change, we can cache it for up too an hour
(define *db:testmeta-cache* (make-hash-table))
(define *db:testmeta-last-update* 0)
;; read the record given a testname
(define (db:testmeta-get-record dbstruct testname)
(if (and (< (- (current-seconds) *db:testmeta-last-update*) 600)
(hash-table-exists? *db:testmeta-cache* testname))
(hash-table-ref *db:testmeta-cache* testname)
(let ((res #f))
(db:with-db
dbstruct
#f
#f
(lambda (dbdat db)
(sqlite3:for-each-row
(lambda (id testname author owner description reviewed iterated avg_runtime avg_disk tags jobgroup)
(set! res (vector id testname author owner description reviewed iterated avg_runtime avg_disk tags jobgroup)))
db
"SELECT id,testname,author,owner,description,reviewed,iterated,avg_runtime,avg_disk,tags,jobgroup FROM test_meta WHERE testname=?;"
testname)))
(hash-table-set! *db:testmeta-cache* testname res)
(set! *db:testmeta-last-update* (current-seconds))
res)))
;; create a new record for a given testname
(define (db:testmeta-add-record dbstruct testname)
(db:with-db dbstruct #f #t
(lambda (dbdat db)
(sqlite3:execute
db
"INSERT OR IGNORE INTO test_meta (testname,author,owner,description,reviewed,iterated,avg_runtime,avg_disk,tags) VALUES (?,'','','','','','','','');" testname))))
;; update one of the testmeta fields
(define (db:testmeta-update-field dbstruct testname field value)
(db:with-db dbstruct #f #t
(lambda (dbdat db)
(sqlite3:execute
db
(conc "UPDATE test_meta SET " field "=? WHERE testname=?;") value testname))))
(define (db:testmeta-get-all dbstruct)
(db:with-db dbstruct #f #f
(lambda (dbdat db)
(let ((res '()))
(sqlite3:for-each-row
(lambda (a . b)
(set! res (cons (apply vector a b) res)))
db
"SELECT id,testname,author,owner,description,reviewed,iterated,avg_runtime,avg_disk,tags,jobgroup FROM test_meta;")
res))))
;;======================================================================
;; M I S C M A N A G E M E N T I T E M S
;;======================================================================
;; A routine to map itempaths using a itemmap
;; patha and pathb must be strings or this will fail
;;
;; path-b is waiting on path-a
;;
(define (db:compare-itempaths test-b-name path-a path-b itemmaps )
(debug:print-info 6 *default-log-port* "ITEMMAPS: " itemmaps)
(let* ((itemmap (tests:lookup-itemmap itemmaps test-b-name)))
(if itemmap
(let ((path-b-mapped (db:multi-pattern-apply path-b itemmap)))
(debug:print-info 6 *default-log-port* "ITEMMAP is " itemmap ", path: " path-b ", mapped path: " path-b-mapped)
(equal? path-a path-b-mapped))
(equal? path-b path-a))))
;; A routine to convert test/itempath using a itemmap
;; NOTE: to process only an itempath (i.e. no prepended testname)
;; just call db:multi-pattern-apply
;;
(define (db:convert-test-itempath path-in itemmap)
(debug:print-info 6 *default-log-port* "ITEMMAP is " itemmap)
(let* ((path-parts (string-split path-in "/"))
(test-name (if (null? path-parts) "" (car path-parts)))
(item-path (string-intersperse (if (null? path-parts) '() (cdr path-parts)) "/")))
(conc test-name "/"
(db:multi-pattern-apply item-path itemmap))))
;; patterns are:
;; "rx1" "replacement1"\n
;; "rx2" "replacement2"
;; etc.
;;
(define (db:multi-pattern-apply item-path itemmap)
(let ((all-patts (string-split itemmap "\n")))
(if (null? all-patts)
item-path
(let loop ((hed (car all-patts))
(tal (cdr all-patts))
(res item-path))
(let* ((parts (string-split hed))
(patt (car parts))
(repl (if (> (length parts) 1)(cadr parts) ""))
(newr (if (and patt repl)
(begin
(handle-exceptions
exn
(begin
(debug:print 0 *default-log-port*
"WARNING: itemmap has problem \"" itemmap "\", patt: " patt ", repl: " repl ", exn=" exn)
res)
(string-substitute patt repl res))
)
(begin
(debug:print 0 *default-log-port*
"WARNING: itemmap has problem \"" itemmap "\", patt: " patt ", repl: " repl)
res))))
(if (null? tal)
newr
(loop (car tal)(cdr tal) newr)))))))
;; the new prereqs calculation, looks also at itempath if specified
;; all prereqs must be met
;; if prereq test with itempath='' is in common:well-ended-states, then prereq is met
;; if prereq test with itempath=ref-item-path and COMPLETED with PASS, WARN, CHECK, or WAIVED then prereq is met
;;
;; 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 ]]
;; mode 'exclusive means this test/item cannot run if the same test/item is LAUNCHED,REMOTEHOSTSTART or RUNNING
;;
;; IDEA for consideration:
;; 1. collect all tests "upstream"
;; 2. any NOT completed and good? if yes => return those as prereqs not met, if no => return null list
;;
;; (define (db:get-prereqs-not-met dbstruct run-id waitons ref-item-path mode)
(define (db:get-prereqs-not-met dbstruct run-id waitons ref-test-name ref-item-path mode itemmaps) ;; #!key (mode '(normal))(itemmap #f))
;; BBnote - rollup of an itemized test's overall state/status done in db:set-state-status-and-roll-up-items
(debug:print 4 *default-log-port* "db:get-prereqs-not-met: " waitons)
(append
(if (member 'exclusive mode)
(let ((running-tests (db:get-tests-for-run dbstruct
#f ;; run-id of #f means for all runs.
(if (string=? ref-item-path "") ;; testpatt
ref-test-name
(conc ref-test-name "/" ref-item-path))
'("LAUNCHED" "REMOTEHOSTSTART" "RUNNING") ;; states
'() ;; statuses
#f ;; offset
#f ;; limit
#f ;; not-in
#f ;; sort by
#f ;; sort order
'shortlist ;; query type
0 ;; last update, beginning of time ....
#f ;; mode
)))
;;(map (lambda (testdat)
;; (if (equal? (db:test-get-item-path testdat) "")
;; (db:test-get-testname testdat)
;; (conc (db:test-get-testname testdat)
;; "/"
;; (db:test-get-item-path testdat))))
running-tests) ;; calling functions want the entire data
'())
;; collection of: for each waiton -
;; if this ref-test-name is an item in an itemized test and mode is itemwait/itemmatch:
;; if waiton is not itemized - if waiton is not both completed and in ok status, add as unmet prerequisite
;; if waiton is itemized:
;; and waiton's items are not expanded, add as unmet prerequisite
;; else if matching waiton item is not both completed and in an ok status, add as unmet prerequisite
;; else
;; if waiton toplevel is not in both completed and ok status, add as unmet prerequisite
(if (or (not waitons)
(null? waitons))
'()
(let* ((ref-test-itemized-mode (not (null? (lset-intersection eq? mode '(itemmatch itemwait))))) ;; how is this different from using member?
(ref-test-toplevel-mode (not (null? (lset-intersection eq? mode '(toplevel)))))
(ref-test-is-toplevel (equal? ref-item-path ""))
(ref-test-is-item (not ref-test-is-toplevel))
(unmet-pre-reqs '())
(result '())
(unmet-prereq-items '())
)
(for-each ; waitons
(lambda (waitontest-name)
;; by getting the tests with matching name we are looking only at the matching test
;; and related sub items
;; next should be using mt:get-tests-for-run?
(let (;(waiton-is-itemized ...)
;(waiton-items-are-expanded ...)
(waiton-tests (db:get-tests-for-run-state-status dbstruct run-id waitontest-name))
(ever-seen #f)
(parent-waiton-met #f)
(item-waiton-met #f)
)
(for-each ; test expanded from waiton
(lambda (waiton-test)
(let* ((waiton-state (db:test-get-state waiton-test))
(waiton-status (db:test-get-status waiton-test))
(waiton-item-path (db:test-get-item-path waiton-test)) ;; BB- this is the upstream itempath
(waiton-test-name (db:test-get-testname waiton-test))
(waiton-is-toplevel (equal? waiton-item-path ""))
(waiton-is-item (not waiton-is-toplevel))
(waiton-is-completed (member waiton-state *common:ended-states*))
(waiton-is-running (member waiton-state *common:running-states*))
(waiton-is-killed (member waiton-state *common:badly-ended-states*))
(waiton-is-ok (member waiton-status *common:well-ended-states*))
;; testname-b path-a path-b
(same-itempath (db:compare-itempaths ref-test-name waiton-item-path ref-item-path itemmaps)) ;; (equal? ref-item-path waiton-item-path)))
(real-ref-test-name (car (string-split ref-test-name "/"))) ;; I THINK ref-test-name SHOULD NEVER HAVE THE ITEM_PATH!
(test-and-ref-are-same (equal? real-ref-test-name waiton-test-name)))
(debug:print 4 *default-log-port* "waiton-test-name " waiton-test-name " ref-test-name: " ref-test-name " test-and-ref-are-same: " test-and-ref-are-same)
(set! ever-seen #t)
;;(BB> "***consider waiton "waiton-test"/"waiton-item-path"***")
(cond
;; case 0 - toplevel of an itemized test, at least one item in prereq has completed
((and waiton-is-item ref-test-is-toplevel ref-test-itemized-mode waiton-is-completed)
(set! parent-waiton-met #t))
;; case 1, non-item (parent test) is
((and waiton-is-toplevel ;; this is the parent test of the waiton being examined
waiton-is-completed
;;(BB> "cond1")
(or waiton-is-ok ref-test-toplevel-mode)) ;; itemmatch itemwait))))))
(set! parent-waiton-met #t))
;; Special case for toplevel and KILLED
((and waiton-is-toplevel ;; this is the parent test
waiton-is-killed
(member 'toplevel mode))
;;(BB> "cond2")
(set! parent-waiton-met #t))
;; For itemwait mode IFF the previous matching item is good the set parent-waiton-met
((and ref-test-itemized-mode ref-test-is-item same-itempath)
;;(BB> "cond3")
(if (and waiton-is-completed (or waiton-is-ok ref-test-toplevel-mode))
(set! item-waiton-met #t)
(set! unmet-prereq-items (cons waiton-test unmet-prereq-items)))
(if (and waiton-is-toplevel ;; if upstream rollup test is completed, parent-waiton-met is set
(or waiton-is-completed waiton-is-running))
(set! parent-waiton-met #t)))
;; normal checking of parent items, any parent or parent item not ok blocks running
((and waiton-is-completed
(or waiton-is-ok
(member 'toplevel mode)) ;; toplevel does not block on FAIL
(and waiton-is-ok (member 'itemmatch mode) ;; itemmatch blocks on not ok ;; TODO: THIS IS PROBABLY A BUG. ITEMMATCH AND ITEMWAIT ARE SYNONYMS!! WHAT HAPPENED OT ITEMWAIT???
))
;;(BB> "cond4")
(set! item-waiton-met #t))
((and waiton-is-completed waiton-is-ok same-itempath)
;;(BB> "cond5")
(set! item-waiton-met #t))
((and waiton-is-completed waiton-is-ok test-and-ref-are-same) ;; probably from [waitons] table
(set! item-waiton-met #t))
(else
#t
;;(BB> "condelse")
))))
waiton-tests)
;; both requirements, parent and item-waiton must be met to NOT add item to
;; prereq's not met list
;; (BB>
;; "\n* waiton-tests "waiton-tests
;; "\n* parent-waiton-met "parent-waiton-met
;; "\n* item-waiton-met "item-waiton-met
;; "\n* ever-seen "ever-seen
;; "\n* ref-test-itemized-mode "ref-test-itemized-mode
;; "\n* unmet-prereq-items "unmet-prereq-items
;; "\n* result (pre) "result
;; "\n* ever-seen "ever-seen
;; "\n")
(cond
((and ref-test-itemized-mode ref-test-is-item (not (null? unmet-prereq-items)))
(set! result (append unmet-prereq-items result)))
((not (or parent-waiton-met item-waiton-met))
(set! result (append (if (null? waiton-tests) (list waitontest-name) waiton-tests) result))) ;; appends the string if the full record is not available
;; if the test is not found then clearly the waiton is not met...
;; (if (not ever-seen)(set! result (cons waitontest-name result)))))
((not ever-seen)
(set! result (append (if (null? waiton-tests)(list waitontest-name) waiton-tests) result))))))
waitons)
(delete-duplicates result)))))
;;======================================================================
;; To sync individual run
;;======================================================================
(define (db:get-run-record-ids dbstruct target run keynames)
(let* ((backcons (lambda (lst item)(cons item lst)))
(all_tests '())
(keystr (string-intersperse
(map (lambda (key val)
(conc key " like '" val "'"))
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 "'"))
(run_ids
(db:with-db dbstruct #f #f
(lambda (dbdat db)
(sqlite3:fold-row backcons '() db run-qry))
)
)
)
run_ids)
)
;;======================================================================
;; Just for sync, procedures to make sync easy
;;======================================================================
;; get an alist of run ids and test/run, test_step/run pairs changed since time since-time
;; '((runs . (1 2 3 ...))(tests . ((5 . 1) (6 . 3) (6 . 2) (7 . 1) ...
;; Retrieves record IDs from the database based on the timestamp of their last update.
;; The function takes two arguments: dbstruct, which represents the database structure, and since-time, which is a timestamp indicating the time of the last update.
;; The function first defines a few helper functions, including backcons, which takes a list and an item and adds the item to the front of the list.
;; It then initializes several variables to empty lists: all_tests, all_test_steps, all_test_data, all_run_ids, and all_test_ids.
;; The function then retrieves a list of IDs for runs that have been changed since since-time using the db:get-changed-run-ids function.
;; It then filters the full list of run IDs to only include those that match the changed run IDs based on their modulo (num-run-dbs).
;; For each changed run ID, the function retrieves a list of test IDs, test step IDs, and test data IDs that have been updated since since-time.
;; It appends these IDs to the appropriate lists (all_tests, all_test_steps, and all_test_data) using the append and map functions.
;; The function then retrieves a list of run stat IDs that have been updated since since-time.
;; Finally, the function returns a list of associations between record types and their corresponding IDs: runs, tests, test_steps, test_data, and run_stats.
;;
(define (db:get-changed-record-ids dbstruct since-time)
;; no transaction, allow the db to be accessed between the big queries
(let* ((backcons (lambda (lst item)(cons item lst)))
(all_tests '())
(changed_run_dbs (db:get-changed-run-ids since-time)) ;; gets the rundb numbers
(all_run_ids
(db:with-db dbstruct #f #f
(lambda (dbdat db)
(sqlite3:fold-row backcons '() db "SELECT id FROM runs"))
)
)
(changed_run_ids (filter (lambda (run) (member (modulo run (num-run-dbs)) changed_run_dbs)) all_run_ids))
(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))
)
)
)
(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 "SELECT id FROM tests WHERE run_id=? and last_update>=?" run_id since-time)
)
)
) all_tests
)
)
)
changed_run_ids
)
(debug:print 2 *default-log-port* "run_ids = " run_ids)
(debug:print 2 *default-log-port* "all_tests = " all_tests)
`((runs . ,run_ids)
(tests . ,all_tests)
)
)
)
(define (db:get-changed-record-test-ids dbstruct since-time run-id)
(let* ((backcons (lambda (lst item)(cons item lst)))
(all-tests (db:with-db dbstruct run-id #f
(lambda (dbdat db)
(sqlite3:fold-row backcons '() db "SELECT id FROM tests WHERE run_id=? and last_update>=?" run-id since-time)))))
all-tests))
(define (db:get-changed-record-run-ids dbstruct since-time)
;; no transaction, allow the db to be accessed between the big queries
(let* ((backcons (lambda (lst item)(cons item lst)))
(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)))))
(debug:print 2 *default-log-port* "run_ids = " run_ids)
run_ids)
)
(define (db:get-all-runids dbstruct)
(let* ((backcons (lambda (lst item)(cons item lst)))
(all_run_ids (db:with-db dbstruct #f #f
(lambda (dbdat db)
(sqlite3:fold-row backcons '() db "SELECT id FROM runs")))))
all_run_ids))
;;======================================================================
;; Extract ods file from the db
;;======================================================================
;; NOT REWRITTEN YET!!!!!
;; runspatt is a comma delimited list of run patterns
;; keypatt-alist must contain *all* keys with an associated pattern: '( ("KEY1" "%") .. )
(define (db:extract-ods-file dbstruct outputfile keypatt-alist runspatt pathmod)
(assert #f "FATAL: call to db:extract-ods-file which is not ported yet.")
(let* ((keysstr (string-intersperse (map car keypatt-alist) ","))
(keyqry (string-intersperse (map (lambda (p)(conc (car p) " LIKE ? ")) keypatt-alist) " AND "))
(numkeys (length keypatt-alist))
(test-ids '())
(dbdat (db:get-subdb dbstruct))
(db (dbr:dbdat-dbh dbdat))
(windows (and pathmod (substring-index "\\" pathmod)))
(tempdir (conc "/tmp/" (current-user-name) "/" runspatt "_" (random 10000) "_" (current-process-id)))
(runsheader (append (list "Run Id" "Runname") ; 0 1
(map car keypatt-alist) ; + N = length keypatt-alist
(list "Testname" ; 2
"Item Path" ; 3
"Description" ; 4
"State" ; 5
"Status" ; 6
"Final Log" ; 7
"Run Duration" ; 8
"When Run" ; 9
"Tags" ; 10
"Run Owner" ; 11
"Comment" ; 12
"Author" ; 13
"Test Owner" ; 14
"Reviewed" ; 15
"Diskfree" ; 16
"Uname" ; 17
"Rundir" ; 18
"Host" ; 19
"Cpu Load" ; 20
)))
(results (list runsheader))
(testdata-header (list "Run Id" "Testname" "Item Path" "Category" "Variable" "Value" "Expected" "Tol" "Units" "Status" "Comment"))
(mainqry (conc "SELECT
t.testname,r.id,runname," keysstr ",t.testname,
t.item_path,tm.description,t.state,t.status,
final_logf,run_duration,
strftime('%m/%d/%Y %H:%M:%S',datetime(t.event_time,'unixepoch'),'localtime'),
tm.tags,r.owner,t.comment,
author,
tm.owner,reviewed,
diskfree,uname,rundir,
host,cpuload
FROM tests AS t JOIN runs AS r ON t.run_id=r.id JOIN test_meta AS tm ON tm.testname=t.testname
WHERE runname LIKE ? AND " keyqry ";")))
(debug:print 2 *default-log-port* "Using " tempdir " for constructing the ods file. keyqry: " keyqry " keystr: " keysstr " with keys: " (map cadr keypatt-alist)
"\n mainqry: " mainqry)
;; "Expected Value"
;; "Value Found"
;; "Tolerance"
(apply sqlite3:for-each-row
(lambda (test-id . b)
(set! test-ids (cons test-id test-ids)) ;; test-id is now testname
(set! results (append results ;; note, drop the test-id
(list
(if pathmod
(let* ((vb (apply vector b))
(keyvals (let loop ((i 0)
(res '()))
(if (>= i numkeys)
res
(loop (+ i 1)
(append res (list (vector-ref vb (+ i 2))))))))
(runname (vector-ref vb 1))
(testname (vector-ref vb (+ 2 numkeys)))
(item-path (vector-ref vb (+ 3 numkeys)))
(final-log (vector-ref vb (+ 7 numkeys)))
(run-dir (vector-ref vb (+ 18 numkeys)))
(log-fpath (conc run-dir "/" final-log))) ;; (string-intersperse keyvals "/") "/" testname "/" item-path "/"
(debug:print 4 *default-log-port* "log: " log-fpath " exists: " (common:file-exists? log-fpath))
(vector-set! vb (+ 7 numkeys) (if (common:file-exists? log-fpath)
(let ((newpath (conc pathmod "/"
(string-intersperse keyvals "/")
"/" runname "/" testname "/"
(if (string=? item-path "") "" (conc "/" item-path))
final-log)))
;; for now throw away newpath and use the log-fpath conc'd with pathmod
(set! newpath (conc pathmod log-fpath))
(if windows (string-translate newpath "/" "\\") newpath))
(if (debug:debug-mode 1)
(conc final-log " not-found")
"")))
(vector->list vb))
b)))))
db
mainqry
runspatt (map cadr keypatt-alist))
(debug:print 2 *default-log-port* "Found " (length test-ids) " records")
(set! results (list (cons "Runs" results)))
;; now, for each test, collect the test_data info and add a new sheet
(for-each
(lambda (test-id)
(let ((test-data (list testdata-header))
(curr-test-name #f))
(sqlite3:for-each-row
(lambda (run-id testname item-path category variable value expected tol units status comment)
(set! curr-test-name testname)
(set! test-data (append test-data (list (list run-id testname item-path category variable value expected tol units status comment)))))
db
;; "SELECT run_id,testname,item_path,category,variable,td.value AS value,expected,tol,units,td.status AS status,td.comment AS comment FROM test_data AS td INNER JOIN tests ON tests.id=td.test_id WHERE test_id=?;"
"SELECT run_id,testname,item_path,category,variable,td.value AS value,td.expected,td.tol,td.units,td.status AS status,td.comment AS comment FROM test_data AS td INNER JOIN tests ON tests.id=td.test_id WHERE testname=?;"
test-id)
(if curr-test-name
(set! results (append results (list (cons curr-test-name test-data)))))
))
(sort (delete-duplicates test-ids) string<=))
(system (conc "mkdir -p " tempdir))
;; (pp results)
(ods:list->ods
tempdir
(if (string-match (regexp "^[/~]+.*") outputfile) ;; full path?
outputfile
(begin
(debug:print 0 *default-log-port* "WARNING: path given, " outputfile " is relative, prefixing with current directory")
(conc (current-directory) "/" outputfile)))
results)
;; brutal clean up
(dbfile:add-dbdat dbstruct #f dbdat)
(system "rm -rf tempdir")))
;; (db:extract-ods-file db "outputfile.ods" '(("sysname" "%")("fsname" "%")("datapath" "%")) "%")
;;======================================================================
;; moving watch dogs here due to dependencies
;;======================================================================
;;======================================================================
;; currently the primary job of the watchdog is to run the sync back to megatest.db from the db in /tmp
;; if we are on the homehost and we are a server (by definition we are on the homehost if we are a server)
;;
(define (common:readonly-watchdog dbstruct)
(thread-sleep! 0.05) ;; delay for startup
(debug:print-info 13 *default-log-port* "common:readonly-watchdog entered.")
;; sync megatest.db to /tmp/.../megatst.db
(let* ((sync-cool-off-duration 3)
(golden-mtdb (dbr:dbstruct-mtdb dbstruct))
(golden-mtpath (db:dbdat-get-path golden-mtdb))
(tmp-mtdb (dbr:dbstruct-tmpdb dbstruct))
(tmp-mtpath (db:dbdat-get-path tmp-mtdb)))
(debug:print-info 0 *default-log-port* "Read-only periodic sync thread started.")
(let loop ((last-sync-time 0))
(debug:print-info 13 *default-log-port* "loop top tmp-mtpath="tmp-mtpath" golden-mtpath="golden-mtpath)
(let* ((duration-since-last-sync (- (current-seconds) last-sync-time)))
(debug:print-info 13 *default-log-port* "duration-since-last-sync="duration-since-last-sync)
(if (and (not *time-to-exit*)
(< duration-since-last-sync sync-cool-off-duration))
(thread-sleep! (- sync-cool-off-duration duration-since-last-sync)))
(if (not *time-to-exit*)
(let ((golden-mtdb-mtime (file-modification-time golden-mtpath))
(tmp-mtdb-mtime (file-modification-time tmp-mtpath)))
(if (> golden-mtdb-mtime tmp-mtdb-mtime)
(if (< golden-mtdb-mtime (- (current-seconds) 3)) ;; file has NOT been touched in past three seconds, this way multiple servers won't fight to sync back
(let ((res (db:multi-db-sync dbstruct 'old2new)))
(debug:print-info 13 *default-log-port* "rosync called, " res " records transferred."))))
(loop (current-seconds)))
#t)))
(debug:print-info 0 *default-log-port* "Exiting readonly-watchdog timer, *time-to-exit* = " *time-to-exit*" pid="(current-process-id)" mtpath="golden-mtpath)))
;; Get a lock from the no-sync-db for the from-db, then copy the from-db to the to-db, otherwise return #f
(define (db:lock-and-sync no-sync-db from-db to-db)
(assert (not *db-sync-in-progress*) "FATAL: db:lock-and-sync called while a sync is in progress.")
(let* ((lockdat (db:no-sync-get-lock no-sync-db from-db))
(gotlock (car lockdat))
(locktime (cdr lockdat)))
(if gotlock
(begin
(file-copy from-db to-db #t)
(db:no-sync-del! no-sync-db from-db)
#t)
(begin
(debug:print 0 *default-log-port* "could not get lock for " from-db " from no-sync-db")
#f
))))
;; sync for filesystem local db writes
;;
(define (db:run-lock-and-sync no-sync-db)
(let* ((tmp-area (common:make-tmpdir-name *toppath* ""))
(dbfiles (glob (conc tmp-area"/.mtdb/*.db")))
(sync-durations (make-hash-table)))
;; (debug:print-info 0 *default-log-port* "lock-and-sync, dbfiles: "dbfiles)
(for-each
(lambda (file)
(let* ((fname (conc (pathname-file file) ".db"))
(fulln (conc *toppath*"/.mtdb/"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)
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)
#t)
(changed ;; (and changed
;; (> (- (current-seconds) time1) 3)) ;; if file is changed and three seconds have passed.
#t)
((and changed *time-to-exit*) ;; last copy
#t)
(else
#f))))
(if do-cp
(let* ((start-time (current-milliseconds)))
(debug:print-info 0 *default-log-port* "sync copy file: " fname", delta: " (- time1 time2) " seconds")
(db:lock-and-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 sync..."))))
dbfiles)
(hash-table->alist sync-durations)))
;; straight forward copy based sync
;; 1. for each .db fil
;; 2. next if file changed since last sync cycle
;; 2. next if time delta /tmp file to MTRA less than 3 seconds
;; 3. get a lock for the file in nosyncdb
;; 4. copy the file
;; 5. when copy is done release the lock
;;
;; DONE
(define (server:writable-watchdog-copysync dbstruct)
(thread-sleep! 0.05) ;; delay for startup
(let ((legacy-sync (common:run-sync?))
(sync-stale-seconds (configf:lookup-number *configdat* "server" "sync-stale-seconds" default: 300))
(debug-mode (debug:debug-mode 1))
(last-time (current-seconds)) ;; last time through the sync loop
(no-sync-db (db:open-no-sync-db))
(sync-duration 0) ;; run time of the sync in milliseconds
(tmp-area (common:make-tmpdir-name *toppath* "")))
;; Sync moved to http-transport keep-running loop
(debug:print-info 2 *default-log-port* "Periodic copy-based sync thread started. syncer is copy-sync, tmp-area is " tmp-area)
(debug:print-info 3 *default-log-port* "watchdog starting. syncer is copy-sync pid="(current-process-id));; " this-wd-num="this-wd-num)
(if (and legacy-sync (not *time-to-exit*))
(begin
(debug:print-info 0 *default-log-port* "Server running, periodic copy-based sync started.")
(let loop ()
;; run the sync and print out durations
(debug:print-info 0 *default-log-port* "Sync durations: "(db:run-lock-and-sync no-sync-db))
;; keep going unless time to exit
;;
(if (not *time-to-exit*)
(let delay-loop ((count 0))
;;(debug:print-info 13 *default-log-port* "delay-loop top; count="count" pid="(current-process-id)" this-wd-num="this-wd-num" *time-to-exit*="*time-to-exit*)
(if (and (not *time-to-exit*)
(< count 6)) ;; was 11, changing to 4.
(begin
(thread-sleep! 1)
(delay-loop (+ count 1))))
(if (not *time-to-exit*) (loop))))
;; ==> ;; time to exit, close the no-sync db here
;; ==> (db:no-sync-close-db no-sync-db stmt-cache)
(if (common:low-noise-print 30)
(debug:print-info 0 *default-log-port* "Exiting watchdog timer, *time-to-exit* = "
*time-to-exit*" pid="(current-process-id) )))))))
(define (server:writable-watchdog-deltasync dbstruct)
;; This is awful complex and convoluted. Plan to redo?
;; for now ... skip it.
(thread-sleep! 0.05) ;; delay for startup
(let ((legacy-sync (common:run-sync?)))
(sync-stale-seconds (configf:lookup-number *configdat* "server" "sync-stale-seconds" default: 300))
(debug-mode (debug:debug-mode 1))
(last-time (current-seconds))
(no-sync-db (db:open-no-sync-db))
(stmt-cache #f) ;; (dbr:dbstruct-stmt-cache dbstruct))
(sync-duration 0) ;; run time of the sync in milliseconds
(subdbs (hash-table-values (dbr:dbstruct-subdbs dbstruct))))
(debug:print-info 2 *default-log-port* "Periodic sync thread started.")
(debug:print-info 3 *default-log-port* "watchdog starting. legacy-sync is " legacy-sync" pid="(current-process-id) );; " this-wd-num="this-wd-num)
(if (and legacy-sync (not *time-to-exit*))
(begin
(debug:print-info 0 *default-log-port* "Server running, periodic sync started.")
(let loop ()
;; sync for filesystem local db writes
;;
(mutex-lock! *db-multi-sync-mutex*)
(let* ((start-file (conc tmp-area "/.start-sync"))
(end-file (conc tmp-area "/.end-sync"))
(need-sync (>= *db-last-access* *db-last-sync*)) ;; no sync since last write
(sync-in-progress *db-sync-in-progress*)
(min-intersync-delay (configf:lookup-number *configdat* "server" "minimum-intersync-delay" default: 5))
(should-sync (and (not *time-to-exit*)
(> (- (current-seconds) *db-last-sync*) min-intersync-delay))) ;; sync every five seconds minimum, deprecated logic, can probably be removed
(start-time (current-seconds))
(cpu-load-adj (alist-ref 'adj-proc-load (common:get-normalized-cpu-load #f)))
(mt-mod-time (file-modification-time mtpath))
(last-sync-start (if (common:file-exists? start-file)
(file-modification-time start-file)
0))
(last-sync-end (if (common:file-exists? end-file)
(file-modification-time end-file)
10))
(sync-period (+ 3 (* cpu-load-adj 30))) ;; as adjusted load increases increase the sync period
(recently-synced (and (< (- start-time mt-mod-time) sync-period) ;; not useful if sync didn't modify megatest.db!
(< mt-mod-time last-sync-start)))
(sync-done (<= last-sync-start last-sync-end))
(sync-stale (> start-time (+ last-sync-start sync-stale-seconds)))
(will-sync (and (not *time-to-exit*) ;; do not start a sync if we are in the process of exiting
(or need-sync should-sync)
(or sync-done sync-stale)
(not sync-in-progress)
(not recently-synced))))
(debug:print-info 13 *default-log-port* "WD writable-watchdog top of loop. need-sync="need-sync" sync-in-progress=" sync-in-progress
" should-sync="should-sync" start-time="start-time" mt-mod-time="mt-mod-time" recently-synced="recently-synced" will-sync="will-sync
" sync-done=" sync-done " sync-period=" sync-period)
(if (and (> sync-period 5)
(common:low-noise-print 30 "sync-period"))
(debug:print-info 0 *default-log-port* "Increased sync period due to long sync times, sync took: " sync-period " seconds."))
;; (if recently-synced (debug:print-info 0 *default-log-port* "Skipping sync due to recently-synced flag=" recently-synced))
;; (debug:print-info 0 *default-log-port* "need-sync: " need-sync " sync-in-progress: " sync-in-progress " should-sync: " should-sync " will-sync: " will-sync)
(if will-sync (set! *db-sync-in-progress* #t))
(mutex-unlock! *db-multi-sync-mutex*)
(if will-sync
(let (;; (max-sync-duration (configf:lookup-number *configdat* "server" "max-sync-duration")) ;; KEEPING THIS AVAILABLE BUT SHOULD NOT USE, I'M PRETTY SURE IT DOES NOT WORK!
(sync-start (current-milliseconds)))
(with-output-to-file start-file (lambda ()(print (current-process-id))))
;; put lock here
;; (if (or (not max-sync-duration)
;; (< sync-duration max-sync-duration)) ;; NOTE: db:sync-to-megatest.db keeps track of time of last sync and syncs incrementally
;;
(for-each
(lambda (subdb)
(let* (;;(dbstruct (db:setup))
(mtdb (dbr:subdb-mtdb subdb))
(mtpath (db:dbdat-get-path mtdb))
(tmp-area (common:make-tmpdir-name *toppath* ""))
(res (db:sync-to-megatest.db dbstruct no-sync-db: no-sync-db))) ;; did we sync any data? If so need to set the db touched flag to keep the server alive
(set! sync-duration (- (current-milliseconds) sync-start))
(if (> res 0) ;; some records were transferred, keep the db alive
(begin
(mutex-lock! *heartbeat-mutex*)
(set! *db-last-access* (current-seconds))
(mutex-unlock! *heartbeat-mutex*)
(debug:print-info 0 *default-log-port* "sync called, " res " records transferred."))
(debug:print-info 2 *default-log-port* "sync called but zero records transferred")))
)
subdbs)))
(if will-sync
(begin
(mutex-lock! *db-multi-sync-mutex*)
(set! *db-sync-in-progress* #f)
(set! *db-last-sync* start-time)
(with-output-to-file end-file (lambda ()(print (current-process-id))))
;; release lock here
(mutex-unlock! *db-multi-sync-mutex*)))
(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))
;;(debug:print-info 13 *default-log-port* "delay-loop top; count="count" pid="(current-process-id)" this-wd-num="this-wd-num" *time-to-exit*="*time-to-exit*)
(if (and (not *time-to-exit*)
(< count 6)) ;; was 11, changing to 4.
(begin
(thread-sleep! 1)
(delay-loop (+ count 1))))
(if (not *time-to-exit*) (loop))))
;; ;; time to exit, close the no-sync db here
;; (db:no-sync-close-db no-sync-db stmt-cache)
(if (common:low-noise-print 30)
(debug:print-info 0 *default-log-port* "Exiting watchdog timer, *time-to-exit* = " *time-to-exit*" pid="(current-process-id) ))))
))
(define (std-exit-procedure)
;;(common:telemetry-log-close)
(on-exit (lambda () 0)) ;; why is this here?
;;(debug:print-info 13 *default-log-port* "std-exit-procedure called; *time-to-exit*="*time-to-exit*)
(let ((no-hurry (if *time-to-exit* ;; hurry up
#f
(begin
(set! *time-to-exit* #t)
#t))))
(debug:print-info 4 *default-log-port* "starting exit process, finalizing databases.")
(if (and no-hurry
(debug:debug-mode 18))
(rmt:print-db-stats))
(let ((th1 (make-thread (lambda () ;; thread for cleaning up, give it five seconds
(if *dbstruct-dbs* (db:close-all *dbstruct-dbs*)) ;; one second allocated
(if (list? *on-exit-procs*)
(for-each
(lambda (proc)
(proc))
*on-exit-procs*))
(if *task-db*
(let ((db (cdr *task-db*)))
(if (sqlite3:database? db)
(begin
(sqlite3:interrupt! db)
(sqlite3:finalize! db #t)
;; (vector-set! *task-db* 0 #f)
(set! *task-db* #f)))))
(if (and *no-sync-db*
(sqlite3:database? *no-sync-db*))
(sqlite3:finalize! *no-sync-db* #t))
(if (and (not (args:get-arg "-server"))
*runremote*
(eq? (rmt:transport-mode) 'http))
(begin
(debug:print-info 0 *default-log-port* "Closing all client connections...")
(http-transport:close-connections *runremote*)
#;(http-client#close-all-connections!)))
;; (if (and *runremote*
;; (remote-conndat *runremote*))
;; (begin
;; (http-client#close-all-connections!))) ;; for http-client
(if (not (eq? *default-log-port* (current-error-port)))
(close-output-port *default-log-port*))
(set! *default-log-port* (current-error-port))) "Cleanup db exit thread"))
(th2 (make-thread (lambda ()
(debug:print 4 *default-log-port* "Attempting clean exit. Please be patient and wait a few seconds...")
(if no-hurry
(begin
(thread-sleep! 5)) ;; give the clean up few seconds to do it's stuff
(begin
(thread-sleep! 2)))
(debug:print 4 *default-log-port* " ... done")
)
"clean exit")))
(thread-start! th1)
(thread-start! th2)
(thread-join! th1)
)
)
0)