;======================================================================
;; 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
(use (srfi 18) extras tcp stack)
(use sqlite3 srfi-1 posix regex regex-case srfi-69 csv-xml s11n md5 message-digest base64 format dot-locking z3 typed-records matchable)
(import (prefix sqlite3 sqlite3:))
(import (prefix base64 base64:))
(declare (unit db))
(declare (uses common))
(declare (uses keys))
(declare (uses ods))
(declare (uses client))
(declare (uses mt))
(include "common_records.scm")
(include "db_records.scm")
(include "key_records.scm")
(include "run_records.scm")
(declare (uses rmtmod))
(import rmtmod)
(declare (uses dbmod))
(import dbmod)
(declare (uses commonmod))
(import commonmod)
(define *rundb-mutex* (make-mutex)) ;; prevent problems opening/closing rundb's
(define *number-of-writes* 0)
(define *number-non-write-queries* 0)
;;======================================================================
;; R E C O R D S
;;======================================================================
;; each db entry is a pair ( db . dbfilepath )
;; I propose this record evolves into the area record
;;
;; MERGED INTO *alldat*
;;
;; (defstruct dbr:dbstruct
;; (tmpdb #f)
;; (dbstack #f) ;; stack for tmp db handles, do not initialize with a stack
;; (mtdb #f)
;; (refndb #f)
;; (homehost #f) ;; not used yet
;; (on-homehost #f) ;; not used yet
;; (read-only #f)
;; ) ;; goal is to converge on one struct for an area but for now it is too confusing
;; record for keeping state,status and count for doing roll-ups in
;; iterated tests
;;
(defstruct dbr:counts
(state #f)
(status #f)
(count 0))
;;======================================================================
;; 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))
(print-call-chain (current-error-port))
default)))
(apply sqlite3:first-result db stmt params)))
;; mod-read:
;; 'mod modified data
;; 'read read data
;; Locks the mutex and depending on 'mod or 'read passed, sets the last timestamp in dbstruct
;;
;; (define (db:done-with dbstruct run-id mod-read)
;; (if (not (sqlite3:database? dbstruct))
;; (begin
;; (mutex-lock! *rundb-mutex*)
;; (if (eq? mod-read 'mod)
;; (dbr:dbstruct-mtime-set! dbstruct (current-milliseconds))
;; (dbr:dbstruct-rtime-set! dbstruct (current-milliseconds)))
;; (dbr:dbstruct-inuse-set! dbstruct #f)
;; (mutex-unlock! *rundb-mutex*))))
;;======================================================================
;; K E E P F I L E D B I N dbstruct
;;======================================================================
;; (define (db:get-filedb dbstruct run-id)
;; (let ((db (vector-ref dbstruct 2)))
;; (if db
;; db
;; (let ((fdb (filedb:open-db (conc *toplevel* "/db/files.db"))))
;; (vector-set! dbstruct 2 fdb)
;; fdb))))
;;
;; ;; Can also be used to save arbitrary strings
;; ;;
;; (define (db:save-path dbstruct path)
;; (let ((fdb (db:get-filedb dbstruct)))b
;; (filedb:register-path fdb path)))
;;
;; ;; Use to get a path. To get an arbitrary string see next define
;; ;;
;; (define (db:get-path dbstruct id)
;; (let ((fdb (db:get-filedb dbstruct)))
;; (filedb:get-path db id)))
;; NB// #f => return dbdir only
;; (was planned to be; zeroth db with name=main.db)
;;
;; If run-id is #f return to create and retrieve the path where the db will live.
;;
;; (define db:dbfile-path common:get-db-tmp-area)
(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))
;; sync run to disk if touched
;;
(define (db:sync-touched dbstruct run-id #!key (force-sync #f))
(let ((tmpdb (db:get-db dbstruct))
(mtdb (dbr:dbstruct-mtdb dbstruct))
(refndb (dbr:dbstruct-refndb dbstruct))
(start-t (current-seconds)))
(debug:print-info 4 *default-log-port* "Syncing for run-id: " run-id)
(mutex-lock! *db-multi-sync-mutex*)
(let ((update_info (cons (if force-sync 0 *db-last-sync*) "last_update")))
(mutex-unlock! *db-multi-sync-mutex*)
(db:sync-tables (db:sync-all-tables-list dbstruct) update_info tmpdb refndb mtdb))
(mutex-lock! *db-multi-sync-mutex*)
(set! *db-last-sync* start-t)
(set! *db-last-access* start-t)
(mutex-unlock! *db-multi-sync-mutex*)
(stack-push! (dbr:dbstruct-dbstack dbstruct) tmpdb)))
(define (db:safely-close-sqlite3-db db #!key (try-num 3))
(if (<= try-num 0)
#f
(handle-exceptions
exn
(begin
(thread-sleep! 3)
(sqlite3:interrupt! db)
(db:safely-close-sqlite3-db db try-num: (- try-num 1)))
(if (sqlite3:database? db)
(begin
(sqlite3:finalize! db)
#t)
#f))))
;; close all opened run-id dbs
(define (db:close-all dbstruct)
(if (dbr:dbstruct? dbstruct)
(handle-exceptions
exn
(begin
(debug:print 0 *default-log-port* "WARNING: Finalizing failed, " ((condition-property-accessor 'exn 'message) exn))
(print-call-chain *default-log-port*))
;; (db:sync-touched dbstruct 0 force-sync: #t) ;; NO. Do not do this here. Instead we rely on a server to be started when there are writes, even if the server itself is not going to be used as a server.
(let ((tdbs (map db:dbdat-get-db
(stack->list (dbr:dbstruct-dbstack dbstruct))))
(mdb (db:dbdat-get-db (dbr:dbstruct-mtdb dbstruct)))
(rdb (db:dbdat-get-db (dbr:dbstruct-refndb dbstruct))))
(map (lambda (db)
(db:safely-close-sqlite3-db db))
;; (if (sqlite3:database? db)
;; (sqlite3:finalize! db)))
tdbs)
(db:safely-close-sqlite3-db mdb) ;; (if (sqlite3:database? mdb) (sqlite3:finalize! mdb))
(db:safely-close-sqlite3-db rdb))))) ;; (if (sqlite3:database? rdb) (sqlite3:finalize! rdb))))))
;; (let ((locdbs (dbr:dbstruct-locdbs dbstruct)))
;; (if (hash-table? locdbs)
;; (for-each (lambda (run-id)
;; (db:close-run-db dbstruct run-id))
;; (hash-table-keys locdbs)))))
;; (define (db:open-inmem-db)
;; (let* ((db (sqlite3:open-database ":memory:"))
;; (handler (make-busy-timeout 3600)))
;; (sqlite3:set-busy-handler! db handler)
;; (db:initialize-run-id-db db)
;; (cons db #f)))
;; use bunch of Unix commands to try to break the lock and recreate the db
;;
(define (db:move-and-recreate-db dbdat)
(let* ((dbpath (db:dbdat-get-path 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))))
(define (db:patch-schema-rundb frundb)
;;
;; remove this some time after September 2016 (added in version v1.6031
;;
(for-each
(lambda (table-name)
(handle-exceptions
exn
(if (string-match ".*duplicate.*" ((condition-property-accessor 'exn 'message) exn))
(debug:print 0 *default-log-port* "Column last_update already added to " table-name " table")
(db:general-sqlite-error-dump exn "alter table " table-name " ..." #f "none"))
(sqlite3:execute
frundb
(conc "ALTER TABLE " table-name " ADD COLUMN last_update INTEGER DEFAULT 0")))
(sqlite3:execute
frundb
(conc "DROP TRIGGER IF EXISTS update_" table-name "_trigger;"))
(sqlite3:execute
frundb
(conc "CREATE TRIGGER IF NOT EXISTS update_" table-name "_trigger AFTER UPDATE ON " table-name "
FOR EACH ROW
BEGIN
UPDATE " table-name " SET last_update=(strftime('%s','now'))
WHERE id=old.id;
END;"))
)
'("tests" "test_steps" "test_data")))
(define (db:patch-schema-maindb maindb)
;;
;; remove all these some time after september 2016 (added in v1.6031
;;
(for-each
(lambda (column type default)
(handle-exceptions
exn
(if (string-match ".*duplicate.*" ((condition-property-accessor 'exn 'message) exn))
(debug:print 0 *default-log-port* "Column " column " already added to runs table")
(db:general-sqlite-error-dump exn "alter table runs ..." #f "none"))
(sqlite3:execute
maindb
(conc "ALTER TABLE runs ADD COLUMN " column " " type " DEFAULT " default))))
(list "last_update" "contour")
(list "INTEGER" "TEXT" )
(list "0" "''" ))
;; these schema changes don't need exception handling
(sqlite3:execute
maindb
"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 maindb "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')))")
(sqlite3:execute maindb "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 maindb "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);"))
(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 (if (common:file-exists? target)
(file-modification-time target)
0))
(cache-db (or (hash-table-ref/default *global-db-store* target #f)
(db:open-megatest-db path: target)))
(source-db (db:open-megatest-db path: source))
(curr-time (current-seconds))
(res '())
(last-update (if use-last-update (cons "last_update" targ-db-last-mod) #f)))
(db:sync-tables (db:sync-main-list source-db) last-update source-db cache-db)
(db:sync-tables db:sync-tests-only last-update source-db cache-db)
(hash-table-set! *global-db-store* target cache-db)
cache-db)))
;; ;; call a proc with a cached db
;; ;;
;; (define (db:call-with-cached-db proc . params)
;; ;; first cache the db in /tmp
;; (let* ((cname-part (conc "megatest_cache/" (common:get-testsuite-name)))
;; (fname (conc (common:get-area-path-signature) ".db"))
;; (cache-dir (common:get-create-writeable-dir
;; (list (conc "/tmp/" (current-user-name) "/" cname-part)
;; (conc "/tmp/" (current-user-name) "-" cname-part)
;; (conc "/tmp/" (current-user-name) "_" cname-part))))
;; (megatest-db (conc *toppath* "/megatest.db")))
;; ;; (debug:print-info 0 *default-log-port* "Using cache dir " cache-dir)
;; (if (not cache-dir)
;; (begin
;; (debug:print 0 *default-log-port* "ERROR: Failed to find an area to write the cache db")
;; (exit 1))
;; (let* ((th1 (make-thread
;; (lambda ()
;; (if (and (common:file-exists? megatest-db)
;; (file-write-access? megatest-db))
;; (begin
;; (db:sync-to-megatest.db dbstruct 'timestamps) ;; internally mutexes on *db-local-sync*
;; (debug:print-info 2 *default-log-port* "Done syncing to megatest.db"))))
;; "call-with-cached-db sync-to-megatest.db"))
;; (cache-db (db:cache-for-read-only
;; megatest-db
;; (conc cache-dir "/" fname)
;; use-last-update: #t)))
;; (thread-start! th1)
;; (apply proc cache-db params)
;; ))))
;; options:
;;
;; 'killservers - kills all servers
;; 'dejunk - removes junk records
;; 'adj-testids - move test-ids into correct ranges
;; 'old2new - sync megatest.db 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)
;; (if (not (launch:setup))
;; (debug:print 0 *default-log-port* "ERROR: not able to setup up for megatest.")
(let* ((mtdb (dbr:dbstruct-mtdb dbstruct))
(tmpdb (db:get-db dbstruct))
(refndb (dbr:dbstruct-refndb dbstruct))
(allow-cleanup #t) ;; (if run-ids #f #t))
(servers (server:get-list *toppath*)) ;; (tasks:get-all-servers (db:delay-if-busy tdbdat)))
(data-synced 0)) ;; count of changed records (I hope)
(for-each
(lambda (option)
(case option
;; kill servers
((killservers)
(for-each
(lambda (server)
(match-let (((mod-time host port start-time pid) server))
(if (and host pid)
(tasks:kill-server host pid))))
servers)
;; /tmp/bjbarcla/megatest_localdb/fullrun/.nfs.pdx.disks.icf_env_disk001.bjbarcla.gwa.issues.mtdev.matt-bisect.megatest.ext-tests.runs.all.v1.65.1.6524.dev.bb-24-justrollup-f8.rollup.fullrun/megatest.db.lock
(delete-file* (common:get-sync-lock-filepath *alldat*))
)
;; clear out junk records
;;
((dejunk)
(db:delay-if-busy mtdb) ;; ok to delay on mtdb
(when (file-write-access? (db:dbdat-get-path mtdb)) (db:clean-up mtdb))
(db:clean-up tmpdb)
(db:clean-up refndb))
;; sync runs, test_meta etc.
;;
((old2new)
(set! data-synced
(+ (db:sync-tables (db:sync-all-tables-list dbstruct) #f mtdb tmpdb refndb)
data-synced)))
;; now ensure all newdb data are synced to megatest.db
;; do not use the run-ids list passed in to the function
;;
((new2old)
(set! data-synced
(+ (db:sync-tables (db:sync-all-tables-list dbstruct) #f tmpdb refndb mtdb)
data-synced)))
((adj-target)
(db:adj-target (db:dbdat-get-db mtdb))
(db:adj-target (db:dbdat-get-db tmpdb))
(db:adj-target (db:dbdat-get-db refndb)))
((schema)
(db:patch-schema-maindb (db:dbdat-get-db mtdb))
(db:patch-schema-maindb (db:dbdat-get-db tmpdb))
(db:patch-schema-maindb (db:dbdat-get-db refndb))
(db:patch-schema-rundb (db:dbdat-get-db mtdb))
(db:patch-schema-rundb (db:dbdat-get-db tmpdb))
(db:patch-schema-rundb (db:dbdat-get-db refndb))))
(stack-push! (dbr:dbstruct-dbstack dbstruct) tmpdb))
options)
data-synced))
(define (db:tmp->megatest.db-sync dbstruct last-update)
(let* ((mtdb (dbr:dbstruct-mtdb dbstruct))
(tmpdb (db:get-db dbstruct))
(refndb (dbr:dbstruct-refndb dbstruct))
(res (db:sync-tables (db:sync-all-tables-list dbstruct) last-update tmpdb refndb mtdb)))
(stack-push! (dbr:dbstruct-dbstack dbstruct) tmpdb)
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))
;; keeping it around for debugging purposes only
(define (open-run-close-no-exception-handling proc idb . params)
(debug:print-info 11 *default-log-port* "open-run-close-no-exception-handling START given a db=" (if idb "yes " "no ") ", params=" params)
(print "I don't work anymore. open-run-close-no-exception-handling needs fixing or removing...")
(exit)
(if (or *db-write-access*
(not #t)) ;; was: (member proc * db:all-write-procs *)))
(let* ((db (cond
((pair? idb) (db:dbdat-get-db idb))
((sqlite3:database? idb) idb)
((not idb) (debug:print-error 0 *default-log-port* "cannot open-run-close with #f anymore"))
((procedure? idb) (idb))
(else (debug:print-error 0 *default-log-port* "cannot open-run-close with #f anymore"))))
(res #f))
(set! res (apply proc db params))
(if (not idb)(sqlite3:finalize! dbstruct))
(debug:print-info 11 *default-log-port* "open-run-close-no-exception-handling END" )
res)
#f))
(define (open-run-close-exception-handling proc idb . params)
(handle-exceptions
exn
(let ((sleep-time (random 30))
(err-status ((condition-property-accessor 'sqlite3 'status #f) exn)))
(case err-status
((busy)
(thread-sleep! sleep-time))
(else
(debug:print 0 *default-log-port* "EXCEPTION: database probably overloaded or unreadable.")
(debug:print 0 *default-log-port* " message: " ((condition-property-accessor 'exn 'message) exn))
(debug:print 5 *default-log-port* "exn=" (condition->list exn))
(debug:print 0 *default-log-port* " status: " ((condition-property-accessor 'sqlite3 'status) exn))
(print-call-chain (current-error-port))
(thread-sleep! sleep-time)
(debug:print-info 0 *default-log-port* "trying db call one more time....this may never recover, if necessary kill process " (current-process-id) " on host " (get-host-name) " to clean up")))
(apply open-run-close-exception-handling proc idb params))
(apply open-run-close-no-exception-handling proc idb params)))
;; (define open-run-close
(define open-run-close open-run-close-exception-handling)
;; open-run-close-no-exception-handling
;; open-run-close-exception-handling)
;;)
;;======================================================================
;; 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-db dbstruct)) ;; archive tables are in main.db
(db (db:dbdat-get-db 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))
(stack-push! (dbr:dbstruct-dbstack dbstruct) 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-db dbstruct)) ;; archive tables are in main.db
(db (db:dbdat-get-db 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)
(stack-push! (dbr:dbstruct-dbstack dbstruct) 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)
(stack-push! (dbr:dbstruct-dbstack dbstruct) 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-db dbstruct)) ;; archive tables are in main.db
(db (db:dbdat-get-db 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
(begin
(if du (sqlite3:exectute 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))
res)
(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))
(db:archive-register-block-name dbstruct bdisk-id archive-path du: du)))
(stack-push! (dbr:dbstruct-dbstack dbstruct) 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
#f
(lambda (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 (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-db dbstruct #f)) ;; archive tables are in main.db
;; (db (db:dbdat-get-db dbdat))
;; (res '())
;; (blocks '())) ;; a block is an archive chunck that can be added too if there is space
;; (sqlite3:for-each-row #f)
;;======================================================================
;; L O G G I N G D B
;;======================================================================
(define (open-logging-db)
(let* ((dbpath (conc (if *toppath* (conc *toppath* "/") "") "logging.db")) ;; fname)
(dbexists (common:file-exists? dbpath))
(db (sqlite3:open-database dbpath))
(handler (make-busy-timeout (if (args:get-arg "-override-timeout")
(string->number (args:get-arg "-override-timeout"))
136000)))) ;; 136000)))
(sqlite3:set-busy-handler! db handler)
(if (not dbexists)
(begin
(sqlite3:execute db "CREATE TABLE IF NOT EXISTS log (id INTEGER PRIMARY KEY,event_time TIMESTAMP DEFAULT (strftime('%s','now')),logline TEXT,pwd TEXT,cmdline TEXT,pid INTEGER);")
(db:set-sync db) ;; (sqlite3:execute db (conc "PRAGMA synchronous = 0;"))
))
db))
(define (db:log-local-event . loglst)
(let ((logline (apply conc loglst)))
(db:log-event logline)))
(define (db:log-event logline)
(let ((db (open-logging-db)))
(sqlite3:execute db "INSERT INTO log (logline,pwd,cmdline,pid) VALUES (?,?,?,?);"
logline
(current-directory)
(string-intersperse (argv) " ")
(current-process-id))
(sqlite3:finalize! db)
logline))
;;======================================================================
;; 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 #f #f
(lambda (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
"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
"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)))))
;; given a launch delay (minimum time from last launch) return amount of time to wait
;;
;; (define (db:launch-delay-left dbstruct run-id launch-delay)
;; select end_time-now from
;; (select testname,item_path,event_time+run_duration as
;; end_time,strftime('%s','now') as now from tests where state in
;; ('RUNNING','REMOTEHOSTSTART','LAUNCHED'));
(define (db:find-and-mark-incomplete dbstruct run-id ovr-deadtime)
(let* ((incompleted '())
(oldlaunched '())
(toplevels '())
(deadtime-trim (or ovr-deadtime (configf:lookup-number *configdat* "setup" "deadtime")))
(server-start-allowance 200)
(server-overloaded-budget 200)
(launch-monitor-off-time (or (configf:lookup-number *configdat* "setup" "test-stats-update-period") 30))
(launch-monitor-on-time-budget 30)
(launch-monitor-period (+ launch-monitor-off-time launch-monitor-on-time-budget server-overloaded-budget))
(remotehoststart-deadtime-default (+ server-start-allowance server-overloaded-budget 30))
(remotehoststart-deadtime (or deadtime-trim remotehoststart-deadtime-default))
(running-deadtime-default (+ server-start-allowance (* 2 launch-monitor-period)))
(running-deadtime (or deadtime-trim running-deadtime-default)) ;; two minutes (30 seconds between updates, this leaves 3x grace period)
)
(db:with-db
dbstruct #f #f
(lambda (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 event-time run-duration)
(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))
(begin
(set! incompleted (cons (list test-id run-dir uname testname item-path run-id) incompleted))
(debug:print-info 0 *default-log-port* "Found old test in RUNNING state, test-id=" test-id" exceeded running-deadtime "running-deadtime" now="(current-seconds)" event-time="event-time" run-duration="run-duration))))
db
"SELECT id,rundir,uname,testname,item_path,event_time,run_duration FROM tests WHERE run_id=? AND (strftime('%s','now') - event_time) > (run_duration + ?) AND state IN ('RUNNING');"
run-id running-deadtime)
(sqlite3:for-each-row
(lambda (test-id run-dir uname testname item-path event-time run-duration)
(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))
(begin
(debug:print-info 0 *default-log-port* "Found old test in REMOTEHOSTSTART state, test-id=" test-id" exceeded running-deadtime "running-deadtime" now="(current-seconds)" event-time="event-time" run-duration="run-duration)
(set! incompleted (cons (list test-id run-dir uname testname item-path run-id) incompleted)))))
db
"SELECT id,rundir,uname,testname,item_path,event_time,run_duration FROM tests WHERE run_id=? AND (strftime('%s','now') - event_time) > (run_duration + ?) AND state IN ('REMOTEHOSTSTART');"
run-id remotehoststart-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))
(begin
(debug:print-info 0 *default-log-port* "Found old test in LAUNCHED state, test-id=" test-id" 1 day since event_time marked")
(set! oldlaunched (cons (list test-id run-dir uname testname item-path run-id) oldlaunched)))))
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.")
;; These are defunct tests, do not do all the overhead of set-state-status. Force them to INCOMPLETE.
;;
;; (db:delay-if-busy dbdat)
(let* (;; (min-incompleted (filter (lambda (x)
;; (let* ((testpath (cadr x))
;; (tdatpath (conc testpath "/testdat.db"))
;; (dbexists (common:file-exists? tdatpath)))
;; (or (not dbexists) ;; if no file then something wrong - mark as incomplete
;; (> (- (current-seconds)(file-modification-time tdatpath)) 600)))) ;; no change in 10 minutes to testdat.db - she's dead Jim
;; incompleted))
(min-incompleted-ids (map car incompleted)) ;; do 'em all
(all-ids (append min-incompleted-ids (map car oldlaunched))))
(if (> (length all-ids) 0)
(begin
(debug:print 0 *default-log-port* "WARNING: Marking test(s); " (string-intersperse (map conc all-ids) ", ") " as DEAD")
(for-each
(lambda (test-id)
(db:set-state-status-and-roll-up-items dbstruct run-id test-id 'foo "COMPLETED" "DEAD" "Test stopped responding while in RUNNING or REMOTEHOSTSTART; presumed dead."))
;;(db:test-set-state-status dbstruct run-id test-id "COMPLETED" "DEAD" "Test stopped responding while in RUNNING or REMOTEHOSTSTART; presumed dead.")) ;; fix for one aspect of Randy's ticket 1405717332 ;; TODO - fix problem where test goes to COMPLETED/DEAD while in progress, only later to go to COMPLETED/PASS. ref ticket 220546828
all-ids))))))))
;; ALL REPLACED BY THE BLOCK ABOVE
;;
;; (sqlite3:execute
;; db
;; (conc "UPDATE tests SET state='INCOMPLETE' WHERE run_id=? AND id IN ("
;; (string-intersperse (map conc all-ids) ",")
;; ");")
;; run-id))))
;;
;; ;; Now do rollups for the toplevel tests
;; ;;
;; ;; (db:delay-if-busy dbdat)
;; (for-each
;; (lambda (toptest)
;; (let ((test-name (list-ref toptest 3)))
;; ;; (run-id (list-ref toptest 5)))
;; (db:top-test-set-per-pf-counts dbstruct run-id test-name)))
;; toplevels)))
;; 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 '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 dbdat)
;; (debug:print 0 *default-log-port* "WARNING: db clean up not fully ported to v1.60, cleanup action will be on megatest.db")
(let* ((keep-record-age ( - (current-seconds) (common:hms-string->seconds (or (configf:lookup *configdat* "setup" "delete-record-age") "30d"))))
(db (db:dbdat-get-db dbdat))
(count-stmt (sqlite3:prepare db "SELECT (SELECT count(id) FROM tests)+(SELECT count(id) FROM runs);"))
(statements
(map (lambda (stmt)
(sqlite3:prepare db stmt))
(list
;; delete all tests that belong to runs that are 'deleted'
(conc "DELETE FROM tests WHERE run_id in (SELECT id FROM runs WHERE state='deleted') and last_update < " keep-record-age ";")
;; delete all tests that are 'DELETED'
(conc "DELETE FROM tests WHERE state='DELETED' and last_update < " keep-record-age " ;")
;; delete all tests that have no run
(conc "DELETE FROM tests WHERE run_id NOT IN (SELECT DISTINCT id FROM runs) and last_update < " keep-record-age "; ")
;; delete all runs that are state='deleted'
(conc "DELETE FROM runs WHERE state='deleted' and last_update < " keep-record-age ";")
;; delete empty runs
(conc "DELETE FROM runs WHERE id NOT IN (SELECT DISTINCT r.id FROM runs AS r INNER JOIN tests AS t ON t.run_id=r.id) and last_update < " keep-record-age ";")
;; remove orphaned test_rundat entries
(conc "DELETE FROM test_rundat where test_id NOT IN (SELECT id FROM tests);")
;; remove orphaned test_steps entries
(conc "DELETE FROM test_steps WHERE test_id NOT IN (SELECT id FROM tests);")
;; remove orphaned test_dat entries
(conc "DELETE FROM test_data WHERE test_id NOT IN (SELECT id FROM tests);")
))))
;; (db:delay-if-busy dbdat)
;(debug:print-info 0 *default-log-port* statements)
(sqlite3:with-transaction
db
(lambda ()
(sqlite3:for-each-row (lambda (tot)
(debug:print-info 0 *default-log-port* "Records count before clean: " tot))
count-stmt)
(map sqlite3:execute statements)
(sqlite3:for-each-row (lambda (tot)
(debug:print-info 0 *default-log-port* "Records count after clean: " tot))
count-stmt)))
(map sqlite3:finalize! statements)
(sqlite3:finalize! count-stmt)
;; (db:find-and-mark-incomplete db)
;; (db:delay-if-busy dbdat)
(sqlite3:execute db "VACUUM;")))
;; 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)
;; (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 (db:dbdat-get-db dbdat))
(count-stmt (sqlite3:prepare db "SELECT (SELECT count(id) FROM tests);"))
(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 tests 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* "Records count before clean: " tot))
count-stmt)
(map sqlite3:execute statements)
(sqlite3:for-each-row (lambda (tot)
(debug:print-info 0 *default-log-port* "Records count after clean: " tot))
count-stmt)))
(map sqlite3:finalize! statements)
(sqlite3:finalize! count-stmt)
;; (db:find-and-mark-incomplete db)
;; (db:delay-if-busy dbdat)
(sqlite3:execute db "VACUUM;")))
;; 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 (db:dbdat-get-db 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* "Records count before clean: " tot))
count-stmt)
(map sqlite3:execute statements)
(sqlite3:for-each-row (lambda (tot)
(debug:print-info 0 *default-log-port* "Records count after clean: " tot))
count-stmt)))
(map sqlite3:finalize! statements)
(sqlite3:finalize! count-stmt)
;; (db:find-and-mark-incomplete db)
;; (db:delay-if-busy dbdat)
(sqlite3:execute db "VACUUM;")
dead-runs))
;;======================================================================
;; M E T A G E T A N D S E T V A R S
;;======================================================================
;; returns number if string->number is successful, string otherwise
;; also updates *global-delta*
;;
(define (db:get-var dbstruct var)
(let* ((res #f))
(db:with-db
dbstruct #f #f
(lambda (db)
(sqlite3:for-each-row
(lambda (val)
(set! res val))
db
"SELECT val FROM metadat WHERE var=?;" var)
;; convert to number if can
(if (string? res)
(let ((valnum (string->number res)))
(if valnum (set! res valnum))))
res))))
;; This was part of db:get-var. It was used to estimate the load on
;; the database files.
;;
;; scale by 10, average with current value.
;; (set! *global-delta* (/ (+ *global-delta* (* (- (current-milliseconds) start-ms)
;; (if throttle throttle 0.01)))
;; 2))
;; (if (> (abs (- *last-global-delta-printed* *global-delta*)) 0.08) ;; don't print all the time, only if it changes a bit
;; (begin
;; (debug:print-info 4 *default-log-port* "launch throttle factor=" *global-delta*)
;; (set! *last-global-delta-printed* *global-delta*)))
(define (db:set-var dbstruct var val)
(db:with-db dbstruct #f #t
(lambda (db)
(sqlite3:execute db "INSERT OR REPLACE INTO metadat (var,val) VALUES (?,?);" var val))))
(define (db:del-var dbstruct var)
(db:with-db dbstruct #f #t
(lambda (db)
(sqlite3:execute db "DELETE FROM metadat WHERE var=?;" var))))
;;======================================================================
;; no-sync.db - small bits of data to be shared between servers
;;======================================================================
(define (db:open-no-sync-db)
(let* ((dbpath (common:get-db-tmp-area *alldat*))
(dbname (conc dbpath "/no-sync.db"))
(db-exists (common:file-exists? dbname))
(db (sqlite3:open-database dbname)))
(sqlite3:set-busy-handler! db (make-busy-timeout 136000))
(if (not db-exists)
(begin
(sqlite3:execute db "PRAGMA synchronous = 0;")
(sqlite3:execute db "CREATE TABLE IF NOT EXISTS no_sync_metadat (var TEXT,val TEXT, CONSTRAINT no_sync_metadat_constraint UNIQUE (var));")
(sqlite3:execute db "PRAGMA journal_mode=WAL;")))
db))
;; 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:no-sync-set db var val)
(sqlite3:execute (db:no-sync-db db) "INSERT OR REPLACE INTO no_sync_metadat (var,val) VALUES (?,?);" var val))
(define (db:no-sync-del! db var)
(sqlite3:execute (db:no-sync-db db) "DELETE FROM no_sync_metadat WHERE var=?;" var))
(define (db:no-sync-get/default db var default)
(let ((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)))
(define (db:no-sync-close-db db)
(db:safely-close-sqlite3-db db))
;; transaction protected lock aquisition
;; either:
;; fails returns (#f . lock-creation-time)
;; succeeds (returns (#t . lock-creation-time)
;; use (db:no-sync-del! db keyname) to release the lock
;;
(define (db:no-sync-get-lock db-in keyname)
(let ((db (db:no-sync-db db-in)))
(sqlite3:with-transaction
db
(lambda ()
(handle-exceptions
exn
(let ((lock-time (current-seconds)))
(sqlite3:execute db "INSERT INTO no_sync_metadat (var,val) VALUES(?,?);" keyname lock-time)
`(#t . ,lock-time))
`(#f . ,(sqlite3:first-result db "SELECT val FROM no_sync_metadat WHERE var=?;" keyname)))))))
;; use a global for some primitive caching, it is just silly to
;; re-read the db over and over again for the keys since they never
;; change
;; look up values in a header/data structure
(define (db:get-value-by-header row header field)
(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 0 *default-log-port* "WARNING: attempt to read non-existant field, row=" row " header=" header " field=" field)
#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 (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 (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 (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 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 #f
(lambda (db)
(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))))
;; 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 (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)))
(define-record simple-run target id runname state status owner event_time)
(define-record-printer (simple-run x out)
(fprintf out "#,(simple-run ~S ~S ~S ~S)"
(simple-run-target x) (simple-run-id x) (simple-run-runname x) (time->string (seconds->local-time (simple-run-event_time x) ))))
;; simple get-runs
;;
(define (db:simple-get-runs dbstruct runpatt count offset target)
(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' 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 (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 inmem db)
;;
(define (db:get-changed-run-ids since-time)
(let* ((dbdir (common:get-db-tmp-area *alldat*)) ;; (configf:lookup *configdat* "setup" "dbdir"))
(alldbs (glob (conc dbdir "/[0-9]*.db")))
(changed (filter (lambda (dbfile)
(> (file-modification-time dbfile) since-time))
alldbs)))
(delete-duplicates
(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 (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 (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 (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 (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)
;; (mutex-lock! *db-transaction-mutex*)
(db:with-db
dbstruct
#f
#f
(lambda (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 (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 (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 (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 (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 (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 (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 (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 #f
(lambda (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 (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 (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 #f
(lambda (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 dbstruct run-id state status )
(db:with-db
dbstruct #f #f
(lambda (db)
(sqlite3:execute db "UPDATE runs SET status=?,state=? WHERE id=?;" status state run-id))))
(define (db:get-run-status dbstruct run-id)
(let ((res "n/a"))
(db:with-db
dbstruct #f #f
(lambda (db)
(sqlite3:for-each-row
(lambda (status)
(set! res status))
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 (db)
(sqlite3:for-each-row
(lambda (status)
(set! res status))
db
"SELECT state 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 (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 (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 (rmt:get-keys))
(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 (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)
(db:with-db dbstruct run-id #f
(lambda (db)
(sqlite3:for-each-row
(lambda (a . b) ;; id run-id testname state status event-time host cpuload diskfree uname rundir item-path run-duration final-logf comment)
(set! res (cons (apply vector a b) res))) ;; id run-id testname state status event-time host cpuload diskfree uname rundir item-path run-duration final-logf comment) res)))
db
qry
(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 "-" "-"))
(define (db:get-tests-for-run-state-status dbstruct run-id testpatt)
(let* ((res '())
(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 ") ") ""))))
(debug:print-info 8 *default-log-port* "db:get-tests-for-run qry=" qry)
(db:with-db dbstruct run-id #f
(lambda (db)
(sqlite3:for-each-row
(lambda (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 (cons (vector id run-id testname state status -1 "" -1 -1 "" "-" item-path -1 "-" "-") res)))
db
qry
run-id)))
res))
(define (db:get-testinfo-state-status dbstruct run-id test-id)
(let ((res #f))
(db:with-db dbstruct run-id #f
(lambda (db)
(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=?;"
test-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 'delete-test-step-records (list test-id))
(db:general-call dbstruct 'delete-test-data-records (list test-id))
(db:with-db
dbstruct #f #f
(lambda (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)
(let (;; (run-ids (db:get-all-run-ids dbstruct))
(targtime (- (current-seconds)(* 30 24 60 60)))) ;; one month in the past
(db:with-db
dbstruct
0
#t
(lambda (db)
(sqlite3:with-transaction
db
(lambda ()
(sqlite3:execute db "DELETE FROM test_steps WHERE test_id IN (SELECT id FROM tests WHERE state='DELETED' AND event_time<?);" targtime)
(sqlite3:execute db "DELETE FROM test_data WHERE test_id IN (SELECT id FROM tests WHERE state='DELETED' AND event_time<?);" targtime)
(sqlite3:execute db "DELETE FROM tests WHERE state='DELETED' AND event_time<?;" targtime)))))))
;; 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 (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
#f
#t
(lambda (db)
(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))
;; NEW BEHAVIOR: Count tests running in all runs!
;;
(define (db:get-count-tests-running dbstruct run-id)
(db:with-db
dbstruct
run-id
#f
(lambda (db)
(sqlite3:first-result
db
;; WARNING BUG EDIT ME - merged from v1.55 - not sure what is right here ...
;; AND run_id NOT IN (SELECT id FROM runs WHERE state='deleted')
"SELECT count(id) FROM tests WHERE state in ('RUNNING','LAUNCHED','REMOTEHOSTSTART') AND NOT (uname = 'n/a' AND item_path = '');"
;; "SELECT count(id) FROM tests WHERE state in ('RUNNING','LAUNCHED','REMOTEHOSTSTART') AND run_id=?;"
))))
;; 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 (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)
(db:with-db
dbstruct
run-id
#f
(lambda (db)
(sqlite3:first-result
db
"SELECT count(id) FROM tests WHERE state in ('RUNNING','LAUNCHED','REMOTEHOSTSTART') AND run_id=?;" 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 (db)
(sqlite3:first-result
db
"SELECT count(id) FROM tests WHERE state in ('RUNNING','LAUNCHED','REMOTEHOSTSTART') AND run_id=? AND NOT (uname = 'n/a' AND item_path = '') AND testname=?;" run-id testname))))
(define (db:get-not-completed-cnt dbstruct run-id)
(db:with-db
dbstruct
run-id
#f
(lambda (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 (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 (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 (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 (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
#f
(lambda (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 (db)
(db:first-result-default
db
"SELECT attemptnum FROM tests WHERE id=?;"
#f
test-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 ","))
;; 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 (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 (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))
(db:dbdat-get-db 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 (db:dbdat-get-db 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 (db:dbdat-get-db mtdb) run-id testrecs)))
run-ids)))
;; Get test data using test_id, run-id is not used
;;
(define (db:get-test-info-by-id dbstruct run-id test-id)
(db:with-db
dbstruct
#f ;; run-id
#f
(lambda (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
(conc "SELECT " db:test-record-qry-selector " FROM tests WHERE id=?;")
test-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 (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))))
(define (db:get-test-info dbstruct run-id test-name item-path)
(db:with-db
dbstruct
run-id
#f
(lambda (db)
(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 (db)
(db:first-result-default
db
"SELECT rundir FROM tests WHERE id=?;"
#f ;; default result
test-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 (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))))
(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 (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 (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 (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 (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 test-step-id)
(db:with-db
dbstruct
#f
#f
(lambda (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 (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 test-data-id)
(db:with-db
dbstruct
#f
#f
(lambda (db)
(let* ((res (vector #f #f #f #f #f #f #f #f #f #f #f #f)))
(sqlite3:for-each-row
(lambda (id test-id category variable value expected tol units comment status type last-update)
(set! res (vector id test-id category variable value expected tol units comment status type last-update)))
db
"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;
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 #f #f
(lambda (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 '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 '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 #f
(lambda (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 (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* dbstruct run-id test-id categorypatt varpatt)
(let* ((res '()))
(db:with-db
dbstruct #f #f
(lambda (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 (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 (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 (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-db 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 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:get-test-info dbstruct run-id test-name item-path)))
(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)))
(if (member state '("LAUNCHED" "REMOTEHOSTSTART"))
(db:general-call dbstruct 'set-test-start-time (list test-id)))
(mutex-lock! *db-transaction-mutex*)
(db:with-db
dbstruct #f #f
(lambda (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 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 dbstruct run-id test-name item-path state status)) ;; item-path is used to exclude current state/status of THIS test
(state-stauses (db:roll-up-rules state-status-counts state status))
(newstate (car state-stauses))
(newstatus (cadr state-stauses)))
(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 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))
tr-res)))))
(define (db:roll-up-rules state-status-counts state status)
(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 #f #f
(lambda (db)
(let ((tr-res
(sqlite3:with-transaction
db
(lambda ()
(let* ((state-status-counts (db:get-all-state-status-counts-for-run dbstruct run-id))
(state-stauses (db:roll-up-rules state-status-counts #f #f ))
(newstate (car state-stauses))
(newstatus (cadr state-stauses)))
(if (or (not (eq? newstate curr-state)) (not (eq? newstatus curr-status)))
(db:set-run-state-status dbstruct run-id newstate newstatus )))))))
(mutex-unlock! *db-transaction-mutex*)
tr-res))))
(define (db:get-all-state-status-counts-for-run dbstruct run-id)
(let* ((test-count-recs (db:with-db
dbstruct #f #f
(lambda (db)
(sqlite3:map-row
(lambda (state status count)
(make-dbr:counts state: state status: status count: count))
db
"SELECT state,status,count(id) FROM tests WHERE run_id=? GROUP BY state,status;"
run-id )))))
test-count-recs))
;; 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*
(define (db:get-all-state-status-counts-for-test dbstruct run-id test-name item-path item-state-in item-status-in)
(let* ((test-info (db:get-test-info dbstruct 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 (db:with-db
dbstruct #f #f
(lambda (db)
(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 (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"))))
(define (db:general-call dbstruct stmtname params)
(let ((query (let ((q (alist-ref (if (string? stmtname)
(string->symbol stmtname)
stmtname)
db:queries)))
(if q (car q) #f))))
(db:with-db
dbstruct #f #f
(lambda (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 #f #f
(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 (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 (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 (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 (db:dbdat-get-db dbdat))
(if dbdat
(let* ((dbpath (db:dbdat-get-path dbdat))
(db (db:dbdat-get-db 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)
(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 (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 (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)))))
;; read the record given a testname
(define (db:testmeta-get-record dbstruct testname)
(let ((res #f))
(db:with-db
dbstruct
#f
#f
(lambda (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)
res))))
;; create a new record for a given testname
(define (db:testmeta-add-record dbstruct testname)
(db:with-db dbstruct #f #f
(lambda (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 #f
(lambda (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 (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)
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 COMPLETED and PASS, WARN, CHECK, or WAIVED 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
(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 test-patt)
(let ((backcons (lambda (lst item)(cons item lst))))
(db:with-db
dbstruct #f #f
(lambda (db)
(let* ((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 "'")))
(print run-qry)
(print test-qry)
`((runs . ,(fold-row backcons '() db run-qry))
(tests . ,(fold-row backcons '() db test-qry))
(test_steps . ,(fold-row backcons '() db (conc "SELECT id FROM test_steps WHERE test_id in (" test-qry ")")))
(test_data . ,(fold-row backcons '() db (conc "SELECT id FROM test_data WHERE test_id in (" test-qry ")" )))
))))))
;;======================================================================
;; Just for sync, procedures to make sync easy
;;======================================================================
;; get an alist of record ids changed since time since-time
;; '((runs . (1 2 3 ...))(steps . (5 6 7 ...) ...))
;;
(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))))
(db:with-db
dbstruct #f #f
(lambda (db)
`((runs . ,(fold-row backcons '() db "SELECT id FROM runs WHERE last_update>=?" since-time))
(tests . ,(fold-row backcons '() db "SELECT id FROM tests WHERE last_update>=?" since-time))
(test_steps . ,(fold-row backcons '() db "SELECT id FROM test_steps WHERE last_update>=?" since-time))
(test_data . ,(fold-row backcons '() db "SELECT id FROM test_data WHERE last_update>=?" since-time))
;; (test_meta . ,(fold-row backcons '() db "SELECT id FROM test_meta WHERE last_update>?" since-time))
(run_stats . ,(fold-row backcons '() db "SELECT id FROM run_stats WHERE last_update>=?" since-time))
)))))
;;======================================================================
;; 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)
(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-db dbstruct))
(db (db:dbdat-get-db 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
(stack-push! (dbr:dbstruct-dbstack dbstruct) dbdat)
(system "rm -rf tempdir")))
;; (db:extract-ods-file db "outputfile.ods" '(("sysname" "%")("fsname" "%")("datapath" "%")) "%")
;; tiresome setup for rmtmod (and other mods) goes here
;; (set-fn 'db:dbfile-path common:get-db-tmp-area)
(set-fn 'db:setup dbmod#db:setup)