Index: Makefile
==================================================================
--- Makefile
+++ Makefile
@@ -38,11 +38,11 @@
# module source files
MSRCFILES = dbfile.scm debugprint.scm mtargs.scm commonmod.scm dbmod.scm \
tcp-transportmod.scm rmtmod.scm portlogger.scm apimod.scm \
configfmod.scm processmod.scm servermod.scm megatestmod.scm \
- stml2.scm
+ stml2.scm fsmod.scm cpumod.scm mtmod.scm
transport-mode.scm : transport-mode.scm.template
cp transport-mode.scm.template transport-mode.scm
dashboard-transport-mode.scm : dashboard-transport-mode.scm.template
@@ -55,10 +55,11 @@
mofiles/portlogger.o : mofiles/dbmod.o
process.o : mofiles/processmod.o
mofiles/configfmod.o : mofiles/processmod.o
mofiles/processmod.o : mofiles/commonmod.o
mofiles/servermod.o : mofiles/commonmod.o
+mofiles/rmtmod.o : mofiles/mtmod.o
mofiles/dbfile.o : \
mofiles/debugprint.o mofiles/commonmod.o mofiles/configfmod.o
mofiles/apimod.o : mofiles/commonmod.o mofiles/tcp-transportmod.o mofiles/configfmod.o
mofiles/dbmod.o : mofiles/dbfile.o
ADDED cpumod.scm
Index: cpumod.scm
==================================================================
--- /dev/null
+++ cpumod.scm
@@ -0,0 +1,105 @@
+;;======================================================================
+;; Copyright 2017, 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 .
+
+;;======================================================================
+
+;;======================================================================
+;; Cpumod:
+;;
+;; Put things here don't fit anywhere else
+;;======================================================================
+
+(declare (unit cpumod))
+(declare (uses debugprint))
+(declare (uses mtargs))
+
+(use srfi-69)
+
+(module cpumod
+ *
+
+(import scheme)
+(cond-expand
+ (chicken-4
+
+ (import chicken
+ ports
+ (prefix base64 base64:)
+
+ (prefix sqlite3 sqlite3:)
+ data-structures
+ extras
+ files
+ matchable
+ md5
+ message-digest
+ pathname-expand
+ posix
+ posix-extras
+ regex
+ regex-case
+ sparse-vectors
+ srfi-1
+ srfi-18
+ srfi-69
+ typed-records
+ z3
+
+ debugprint
+ (prefix mtargs args:)
+ )
+ (use srfi-69))
+ (chicken-5
+ (import (prefix sqlite3 sqlite3:)
+ ;; data-structures
+ ;; extras
+ ;; files
+ ;; posix
+ ;; posix-extras
+ chicken.base
+ chicken.condition
+ chicken.file
+ chicken.file.posix
+ chicken.io
+ chicken.pathname
+ chicken.port
+ chicken.process
+ chicken.process-context
+ chicken.process-context.posix
+ chicken.sort
+ chicken.string
+ chicken.time
+ chicken.time.posix
+
+ matchable
+ md5
+ message-digest
+ pathname-expand
+ regex
+ regex-case
+ srfi-1
+ srfi-18
+ srfi-69
+ typed-records
+ system-information
+
+ debugprint
+ )))
+
+
+)
Index: db.scm
==================================================================
--- db.scm
+++ db.scm
@@ -61,4627 +61,10 @@
z3
typed-records
matchable
files)
-(include "common_records.scm")
-(include "db_records.scm")
-(include "key_records.scm")
-(include "run_records.scm")
-
-(define *number-of-writes* 0)
-(define *number-non-write-queries* 0)
-
(import debugprint)
(import dbfile)
(import dbmod)
(import rmtmod)
-;; record for keeping state,status and count for doing roll-ups in
-;; iterated tests
-;;
-(defstruct dbr:counts
- (state #f)
- (status #f)
- (count 0))
-
-;; (define (db:with-db dbstruct run-id r/w proc . params)
-;; (case (rmt:transport-mode)
-;; ((http)(dbfile:with-db dbstruct run-id r/w proc params))
-;; ((tcp) (dbmod:with-db dbstruct run-id r/w proc params))
-;; ((nfs) (dbmod:with-db dbstruct run-id r/w proc params))
-;; (else (assert #f "FATAL: db:with-db called with non-existant transport mode"))))
-
-;;======================================================================
-;; hash of hashs
-;;======================================================================
-
-
-(define (db:hoh-set! dat key1 key2 val)
- (let* ((subhash (hash-table-ref/default dat key1 #f)))
- (if subhash
- (hash-table-set! subhash key2 val)
- (begin
- (hash-table-set! dat key1 (make-hash-table))
- (db:hoh-set! dat key1 key2 val)))))
-
-(define (db:hoh-get dat key1 key2)
- (let* ((subhash (hash-table-ref/default dat key1 #f)))
- (and subhash
- (hash-table-ref/default subhash key2 #f))))
-
-;;======================================================================
-;; SQLITE3 HELPERS
-;;======================================================================
-
-(define (db:general-sqlite-error-dump exn stmt . params)
- (let ((err-status ((condition-property-accessor 'sqlite3 'status #f) exn))) ;; RADT ... how does this work?
- ;; check for (exn sqlite3) ((condition-property-accessor 'exn 'message) exn)
- ;; (print "err-status: " err-status)
- (debug:print-error 0 *default-log-port* " query " stmt " failed, params: " params ", error: " ((condition-property-accessor 'exn 'message) exn))
- (print-call-chain (current-error-port))))
-
-;; convert to -inline
-;;
-(define (db:first-result-default db stmt default . params)
- (handle-exceptions
- exn
- (let ((err-status ((condition-property-accessor 'sqlite3 'status #f) exn)))
- ;; check for (exn sqlite3) ((condition-property-accessor 'exn 'message) exn)
- (if (eq? err-status 'done)
- default
- (begin
- (debug:print-error 0 *default-log-port* " query " stmt " failed, params: " params ", error: " ((condition-property-accessor 'exn 'message) exn) ", exn=" exn)
- (print-call-chain (current-error-port))
- default)))
- (apply sqlite3:first-result db stmt params)))
-
-(define (db:setup)
- (assert *toppath* "FATAL: db:setup called before launch:setup has been run.")
- (let* ((tmpdir (common:make-tmpdir-name *toppath* "")))
- (if (not *dbstruct-dbs*)
- (dbfile:setup (conc *toppath* "/.mtdb") tmpdir)
- *dbstruct-dbs*)))
-
-;; moved from dbfile
-;;
-;; ADD run-id SUPPORT
-;;
-(define (db:create-all-triggers dbstruct)
- (db:with-db
- dbstruct #f #t
- (lambda (dbdat db)
- (db:create-triggers db))))
-
-(define (db:create-triggers db)
- (for-each (lambda (key)
- (sqlite3:execute db (cadr key)))
- db:trigger-list))
-
-(define (db:drop-all-triggers dbstruct)
- (db:with-db
- dbstruct #f #t
- (lambda (dbdat db)
- (db:drop-triggers db))))
-
-(define (db:have-incompletes? dbstruct run-id ovr-deadtime)
- (let* ((incompleted '())
- (oldlaunched '())
- (toplevels '())
- ;; (deadtime-str (configf:lookup *configdat* "setup" "deadtime"))
- (deadtime (or ovr-deadtime 72000))) ;; twenty hours
- (db:with-db
- dbstruct run-id #f
- (lambda (dbdat db)
-
- ;; in RUNNING or REMOTEHOSTSTART for more than 10 minutes
- ;;
- ;; HOWEVER: this code in run:test seems to work fine
- ;; (> (- (current-seconds)(+ (db:test-get-event_time testdat)
- ;; (db:test-get-run_duration testdat)))
- ;; 600)
- ;; (db:delay-if-busy dbdat)
- (sqlite3:for-each-row
- (lambda (test-id run-dir uname testname item-path)
- (if (and (equal? uname "n/a")
- (equal? item-path "")) ;; this is a toplevel test
- ;; what to do with toplevel? call rollup?
- (begin
- (set! toplevels (cons (list test-id run-dir uname testname item-path run-id) toplevels)))
- ;; (print-info "Found old toplevel test in RUNNING state, test-id=" test-id))
- (set! incompleted (cons (list test-id run-dir uname testname item-path run-id) incompleted))))
- (db:get-cache-stmth dbdat db
- "SELECT id,rundir,uname,testname,item_path FROM tests WHERE run_id=? AND (strftime('%s','now') - event_time) > (run_duration + ?) AND state IN ('RUNNING','REMOTEHOSTSTART');")
- run-id deadtime)
-
- ;; in LAUNCHED for more than one day. Could be long due to job queues TODO/BUG: Need override for this in config
- ;;
- ;; (db:delay-if-busy dbdat)
- (sqlite3:for-each-row
- (lambda (test-id run-dir uname testname item-path)
- (if (and (equal? uname "n/a")
- (equal? item-path "")) ;; this is a toplevel test
- ;; what to do with toplevel? call rollup?
- (set! toplevels (cons (list test-id run-dir uname testname item-path run-id) toplevels))
- (set! oldlaunched (cons (list test-id run-dir uname testname item-path run-id) oldlaunched))))
- (db:get-cache-stmth dbdat db
- "SELECT id,rundir,uname,testname,item_path FROM tests WHERE run_id=? AND (strftime('%s','now') - event_time) > 86400 AND state IN ('LAUNCHED');")
- run-id)
-
- ;; (print-info "Found " (length oldlaunched) " old LAUNCHED items, " (length toplevels) " old LAUNCHED toplevel tests and " (length incompleted) " tests marked RUNNING but apparently dead.")
- (if (and (null? incompleted)
- (null? oldlaunched)
- (null? toplevels))
- #f
- #t)))))
-
-
-;; looks up subdb and returns it, if not found then set up
-;; and then return it.
-;;
-#;(define (db:get-db dbstruct run-id)
- (let* ((res (dbfile:get-subdb dbstruct run-id)))
- (if res
- res
- (let* ((newsubdb (make-dbr:subdb)))
- (dbfile:set-subdb dbstruct run-id newsubdb)
- (db:open-db dbstruct run-id areapath: (dbr:dbstruct-areapath dbstruct) do-sync: #t)
- newsubdb))))
-
-;; Get/open a database
-;; if run-id => get run specific db
-;; if #f => get main db
-;; if run-id is a string treat it as a filename
-;; if db already open - return cachedb
-;; if db not open, open cachedb, rundb and sync then return cachedb
-;; inuse gets set automatically for rundb's
-;;
-;; (define db:get-db db:get-subdb)
-
-;; (define (db:get-db subdb #;dbstruct run-id) ;; RENAME TO db:get-dbh
-;; ;; (let* ((subdb (dbfile:get-subdb dbstruct run-id)))
-;; (if (stack? (dbr:subdb-dbstack subdb))
-;; (if (stack-empty? (dbr:subdb-dbstack subdb))
-;; (let* ((dbname (db:run-id->dbname run-id))
-;; (newdb (db:open-megatest-db path: (db:dbfile-path)
-;; name: dbname)))
-;; ;; NOTE: pushing on the stack only happens AFTER the handle has been used
-;; ;; (stack-push! (dbr:dbstruct-dbstack dbstruct) newdb)
-;; newdb)
-;; (stack-pop! (dbr:subdb-dbstack subdb)))
-;; (db:open-db subdb run-id))) ;; )
-
-
-#;(define (db:get-db dbstruct run-id)
- (let* ((subdb (dbfile:get-subdb dbstruct run-id))
- (dbdat (dbfile:get-dbdat dbstruct run-id)))
- (if (dbr:dbdat? dbdat)
- dbdat
- (dbfile:open-db *dbstruct-dbs* #f db:initialize-main-db)
- )
- )
-)
-
-(define-inline (db:generic-error-printout exn . message)
- (print-call-chain (current-error-port))
- (apply debug:print-error 0 *default-log-port* message)
- (debug:print-error 0 *default-log-port* " params: " params
- ", error: " ((condition-property-accessor 'exn 'message) exn)
- ", arguments: " ((condition-property-accessor 'exn 'arguments) exn)
- ", location: " ((condition-property-accessor 'exn 'location) exn)
- ))
-
-
-(define (db:set-sync db)
- (let ((syncprag (configf:lookup *configdat* "setup" "sychronous")))
- (sqlite3:execute db (conc "PRAGMA synchronous = " (or syncprag 0) ";"))))
-
-
-(define (db:get-last-update-time db)
- (let ((last-update-time #f))
- (sqlite3:for-each-row
- (lambda (lup)
- (set! last-update-time lup))
- db
- "select max(lup) from ( select max(last_update) as lup from tests union select max(last_update) as lup from runs);")
- last-update-time))
-
-
-;; Open the classic megatest.db file (defaults to open in toppath)
-;;
-;; NOTE: returns a dbdat not a dbstruct!
-;;
-(define (db:open-megatest-db dbpath)
- (let* ((dbexists (file-exists? dbpath))
- (db (db:lock-create-open dbpath
- (lambda (db)
- (db:initialize-main-db db))))
- (write-access (file-write-access? dbpath)))
- (debug:print-info 13 *default-log-port* "db:open-megatest-db "dbpath)
- (if (and dbexists (not write-access))
- (set! *db-write-access* #f))
- ;; (cons db dbpath)))
- (make-dbr:dbdat dbfile: dbpath dbh: db read-only: (not write-access))))
-
-
-;; use bunch of Unix commands to try to break the lock and recreate the db
-;;
-(define (db:move-and-recreate-db dbdat)
- (let* ((dbpath (dbr:dbdat-dbfile dbdat))
- (dbdir (pathname-directory dbpath))
- (fname (pathname-strip-directory dbpath))
- (fnamejnl (conc fname "-journal"))
- (tmpname (conc fname "." (current-process-id)))
- (tmpjnl (conc fnamejnl "." (current-process-id))))
- (debug:print-error 0 *default-log-port* "" fname " appears corrupted. Making backup \"old/" fname "\"")
- (system (conc "cd " dbdir ";mkdir -p old;cat " fname " > old/" tmpname))
- (system (conc "rm -f " dbpath))
- (if (common:file-exists? fnamejnl)
- (begin
- (debug:print-error 0 *default-log-port* "" fnamejnl " found, moving it to old dir as " tmpjnl)
- (system (conc "cd " dbdir ";mkdir -p old;cat " fnamejnl " > old/" tmpjnl))
- (system (conc "rm -f " dbdir "/" fnamejnl))))
- ;; attempt to recreate database
- (system (conc "cd " dbdir ";sqlite3 old/" tmpname " .dump | sqlite3 " fname))))
-
-;; return #f to indicate the dbdat should be closed/reopened
-;; else return dbdat
-;;
-(define (db:repair-db dbdat #!key (numtries 1))
- (let* ((dbpath (dbr:dbdat-dbfile dbdat))
- (dbdir (pathname-directory dbpath))
- (fname (pathname-strip-directory dbpath)))
- (debug:print-info 0 *default-log-port* "Checking db " dbpath " for errors.")
- (cond
- ((not (file-write-access? dbdir))
- (debug:print 0 *default-log-port* "WARNING: can't write to " dbdir ", can't fix " fname)
- #f)
-
- ;; handle special cases, megatest.db and monitor.db
- ;;
- ;; NOPE: apply this same approach to all db files
- ;;
- (else ;; ((equal? fname "megatest.db") ;; this file can be regenerated if needed
- (handle-exceptions
- exn
- (begin
- (debug:print 0 *default-debug-port* "Problems trying to repair the db, exn=" exn)
- ;; (db:move-and-recreate-db dbdat)
- (if (> numtries 0)
- (db:repair-db dbdat numtries: (- numtries 1))
- #f)
- (debug:print 0 *default-log-port* "FATAL: file " dbpath " was found corrupted, an attempt to fix has been made but you must start over.")
- (debug:print 0 *default-log-port*
- " check the following:\n"
- " 1. full directories, look in ~/ /tmp and " dbdir "\n"
- " 2. write access to " dbdir "\n\n"
- " if the automatic recovery failed you may be able to recover data by doing \""
- (if (member fname '("megatest.db" "monitor.db"))
- "megatest -cleanup-db"
- "megatest -import-megatest.db;megatest -cleanup-db")
- "\"\n")
- (exit) ;; we can not safely continue when a db was corrupted - even if fixed.
- )
- ;; test read/write access to the database
- (let ((db (sqlite3:open-database dbpath)))
- (sqlite3:set-busy-handler! db (sqlite3:make-busy-timeout 136000))
- (sqlite3:execute db "PRAGMA synchronous = 0;")
- (cond
- ((equal? fname "megatest.db")
- (sqlite3:execute db "DELETE FROM tests WHERE state='DELETED';"))
- ((equal? fname "main.db")
- (sqlite3:execute db "DELETE FROM runs WHERE state='deleted';"))
- ((string-match "\\d.db" fname)
- (sqlite3:execute db "UPDATE tests SET state='DELETED' WHERE state='DELETED';"))
- ((equal? fname "monitor.db")
- (sqlite3:execute "DELETE FROM servers WHERE state LIKE 'defunct%';"))
- (else
- (sqlite3:execute db "vacuum;")))
-
- (sqlite3:finalize! db)
- #t))))))
-
-
-
-(define (db:adj-target db)
- (let ((fields (configf:get-section *configdat* "fields"))
- (field-num 0))
- ;; because we will be refreshing the keys table it is best to clear it here
- (sqlite3:execute db "DELETE FROM keys;")
- (for-each
- (lambda (field)
- (let ((column (car field))
- (spec (cadr field)))
- (handle-exceptions
- exn
- (if (string-match ".*duplicate.*" ((condition-property-accessor 'exn 'message) exn))
- (debug:print 0 *default-log-port* "Target field " column " already exists in the runs table")
- (db:general-sqlite-error-dump exn "alter table runs ..." #f "none"))
- ;; Add the column if needed
- (sqlite3:execute
- db
- (conc "ALTER TABLE runs ADD COLUMN " column " " spec)))
- ;; correct the entry in the keys column
- (sqlite3:execute
- db
- "INSERT INTO keys (id,fieldname,fieldtype) VALUES (?,?,?);"
- field-num column spec)
- ;; fill in blanks (not allowed as it would be part of the path
- (sqlite3:execute
- db
- (conc "UPDATE runs SET " column "='x' WHERE " column "='';"))
- (set! field-num (+ field-num 1))))
- fields)))
-
-(define *global-db-store* (make-hash-table))
-
-(define (db:get-access-mode)
- (if (args:get-arg "-use-db-cache") 'cached 'rmt))
-
-;; Add db direct
-;;
-(define (db:dispatch-query access-mode rmt-cmd db-cmd . params)
- (if (eq? access-mode 'cached)
- (debug:print 2 *default-log-port* "not doing cached calls right now"))
-;; (apply db:call-with-cached-db db-cmd params)
- (apply rmt-cmd params))
-;;)
-
-;; return the target db handle so it can be used
-;;
-(define (db:cache-for-read-only source target #!key (use-last-update #f))
- (if (and (hash-table-ref/default *global-db-store* target #f)
- (>= (file-modification-time target)(file-modification-time source)))
- (hash-table-ref *global-db-store* target)
- (let* ((toppath (launch:setup))
- (targ-db-last-mod (db:get-sqlite3-mod-time target))
-;; (if (common:file-exists? target)
-;; BUG: This needs to include wal mode stuff .shm etc.
-;; (file-modification-time target)
-;; 0))
- (cache-db (or (hash-table-ref/default *global-db-store* target #f)
- (db:open-megatest-db path: target)))
- (source-db (db:open-megatest-db path: source))
- (curr-time (current-seconds))
- (res '())
- (last-update (if use-last-update (cons "last_update" targ-db-last-mod) #f)))
- (db:sync-tables (db:sync-main-list source-db) last-update source-db cache-db)
- (db:sync-tables db:sync-tests-only last-update source-db cache-db)
- (hash-table-set! *global-db-store* target cache-db)
- cache-db)))
-
-(define (db:get-sqlite3-mod-time fname)
- (let* ((wal-file (conc fname "-wal"))
- (shm-file (conc fname "-shm"))
- (get-mtime (lambda (f)
- (if (and (file-exists? f)
- (file-read-access? f))
- (file-modification-time f)
- 0))))
- (max (get-mtime fname)
- (get-mtime wal-file)
- (get-mtime shm-file))))
-
-;; (define (db:all-db-sync dbstruct)
-;; (let* ((dbdat (db:open-db dbstruct #f db:initialize-main-db))
-;; (data-synced 0) ;; count of changed records
-;; (tmp-area (common:make-tmpdir-name *toppath*))
-;; (dbfiles (glob (conc tmp-area"/.mtdb/*.db")))
-;; (sync-durations (make-hash-table))
-;; (no-sync-db (db:open-no-sync-db)))
-;; (for-each
-;; (lambda (file) ;; tmp db file
-;; (debug:print-info 3 *default-log-port* "file: " file)
-;; (let* ((fname (conc (pathname-file file) ".db")) ;; fname is tmp db file
-;; (wal-file (conc fname "-wal"))
-;; (shm-file (conc fname "-shm"))
-;; (fulln (conc *toppath*"/,mtdb/"fname)) ;; fulln is nfs db name
-;; (wal-time (if (file-exists? wal-file)
-;; (file-modification-time wal-file)
-;; 0))
-;; (shm-time (if (file-exists? shm-file)
-;; (file-modification-time shm-file)
-;; 0))
-;; (time1 (db:get-sqlite3-mod-time file))
-;; ;; (if (file-exists? file) ;; time1 is the max itime of the tmp db, -wal and -shm files.
-;; ;; (max (file-modification-time file) wal-time shm-time)
-;; ;; (begin
-;; ;; (debug:print-info 2 *default-log-port* "Sync - I do not see file "file)
-;; ;; 1)))
-;; (time2 (db:get-sqlite3-mod-time fulln))
-;; ;; (if (file-exists? fulln) ;; time2 is nfs file time
-;; ;; (file-modification-time fulln)
-;; ;; (begin
-;; ;; (debug:print-info 2 *default-log-port* "Sync - I do not see file "fulln)
-;; ;; 0)))
-;; (changed (> (- time1 time2) (+ (random 5) 1))) ;; it has been at some few seconds since last synced
-;; (changed10 (> (- time1 time2) 10)) ;; it has been at least ten seconds since sync'd
-;; (jfile-exists (file-exists? (conc file"-journal"))) ;; i.e. are we busy?
-;; (do-cp (cond
-;; ((not (file-exists? fulln)) ;; shouldn't happen, but this might recover
-;; (cons #t (conc "File "fulln" not found! Copying "fname" to "fulln)))
-;; ((and (not jfile-exists) changed)
-;; (cons #t "not busy, changed")) ;; not busy and changed
-;; ((and jfile-exists changed10)
-;; (cons #t "busy but not synced in a while")) ;; busy but not sync'd in over 10 seconds
-;; ((and changed *time-to-exit*)
-;; (cons #t "Time to exit, forced final sync")) ;; last sync
-;; (else
-;; (cons #f "No sync needed")))))
-;; (if (car do-cp)
-;; (let* ((start-time (current-milliseconds))
-;; (fname (pathname-file file))
-;; (runid (if (string= fname "main") #f (string->number fname))))
-;; (debug:print-info 3 *default-log-port* "db:all-db-sync: fname: "
-;; fname", delta: " (- time1 time2) " seconds, reason: "(cdr do-cp))
-;; (db:lock-and-delta-sync no-sync-db dbstruct fname runid (db:get-keys dbstruct) db:initialize-main-db)
-;; (hash-table-set! sync-durations (conc fname".db")
-;; (- (current-milliseconds) start-time)))
-;; (debug:print-info 3 *default-log-port* "skipping sync. " file " is up to date")
-;; )))
-;; dbfiles)
-;; ;; WHY does the dbdat need to be added back?
-;; (if dbdat (dbfile:add-dbdat dbstruct #f dbdat))
-;; )
-;; #t)
-
-(define (db:kill-servers)
- (let* ((tl (launch:setup)) ;; need this to initialize *toppath*
- (servdir (conc *toppath* "/.servinfo"))
- (servfiles (glob (conc servdir "/*:*.db")))
- (fmtstr "~10a~22a~10a~25a~25a~8a\n")
- (dbfiles (append (glob (conc *toppath* "/.mtdb/main.db")) (glob (conc *toppath* "/.mtdb/?.db"))(glob (conc *toppath* "/.mtdb/??.db"))))
- (ttdat (make-tt areapath: *toppath*))
- )
- (format #t fmtstr "DB" "host:port" "PID" "age" "last mod" "state")
- (for-each
- (lambda (dbfile)
- (let* (
- (dbfname (conc (pathname-file dbfile) ".db"))
- (sfiles (tt:find-server *toppath* dbfname))
- )
- (for-each
- (lambda (sfile)
- (let (
- (sinfos (tt:get-server-info-sorted ttdat dbfname))
- )
- (for-each
- (lambda (sinfo)
- (let* (
- (db (list-ref sinfo 5))
- (pid (list-ref sinfo 4))
- (host (list-ref sinfo 0))
- (port (list-ref sinfo 1))
- (server-id (list-ref sinfo 3))
- (age (seconds->hr-min-sec (- (current-seconds) (list-ref sinfo 2))))
- (last-mod (seconds->string (list-ref sinfo 2)))
- (killed (system (conc "ssh " host " kill " pid " > /dev/null")))
- (dummy2 (sleep 1))
- (state (if (> (system (conc "ssh " host " ps " pid " > /dev/null")) 0) "dead" "alive"))
- )
- (format #t fmtstr db (conc host ":" port) pid age last-mod state)
- (system (conc "rm " sfile))
- )
- )
- sinfos
- )
- )
- )
- sfiles
- )
- )
- )
- dbfiles
- )
- ;; remove this db, because otherwise metadata contains records for old servers, and this causes a problem with db:no-sync-get-lock-with-id.
- (if (file-exists? (conc *toppath* "/.mtdb/no-sync.db"))
- (delete-file (conc *toppath* "/.mtdb/no-sync.db"))
- )
- )
-)
-
-;; options:
-;;
-;; 'killservers - kills all servers
-;; 'dejunk - removes junk records
-;; 'adj-testids - move test-ids into correct ranges
-;; 'old2new - sync megatest.db to /tmp/.../megatest.db and /tmp/.../megatest_ref.db
-;; 'new2old - sync /tmp/.../megatest.db to megatest.db and /tmp/.../megatest_ref.db (and update data_synced)
-;; 'closeall - close all opened dbs
-;; 'schema - attempt to apply schema changes
-;; run-ids: '(1 2 3 ...) or #f (for all)
-;;
-(define (db:multi-db-sync dbstruct . options)
- (let* (;; (dbdat (db:open-db dbstruct #f dbfile:db-init-proc))
- (data-synced 0) ;; count of changed records
- (tmp-area (common:make-tmpdir-name *toppath* ""))
- (old2new (member 'old2new options))
- (dejunk (member 'dejunk options))
- (killservers (member 'killservers options))
- (src-area (if old2new *toppath* tmp-area))
- (dest-area (if old2new tmp-area (conc *toppath* "/.mtdb")))
- (dbfiles (if old2new (glob (conc *toppath* "/.mtdb/*.db"))
- (glob (conc tmp-area "/*.db"))))
- (keys (db:get-keys dbstruct))
- (sync-durations (make-hash-table)))
-
- ;; kill servers
- ;; (if killservers (db:kill-servers))
-
- (if (not dbfiles)
- (debug:print-error 0 *default-log-port* "no dbfiles found in " (conc *toppath* "/.mtdb"))
- (for-each
- (lambda (srcfile)
- (debug:print-info 3 *default-log-port* "file: " srcfile)
- (let* ((fname (conc (pathname-file srcfile) ".db"))
- (basename (pathname-file srcfile))
- (run-id (if (string= basename "main") #f (string->number basename)))
- (destfile (conc dest-area "/" fname))
- (dest-directory dest-area)
- (time1 (file-modification-time srcfile))
- (time2 (if (file-exists? destfile)
- (begin
- (debug:print-info 2 *default-log-port* "destfile " destfile " exists")
- (file-modification-time destfile))
- (begin
- (debug:print-info 0 *default-log-port* "Sync - I do not see file " destfile)
- 0)))
- (changed ( < (- time2 time1) 6.0)) ;; dest db not updated within last 6 seconds
-
- (do-cp (cond
- ((not (file-exists? destfile)) ;; shouldn't happen, but this might recover
- (debug:print-info 2 *default-log-port* "File " destfile " not found. Copying "srcfile" to "destfile)
- ;; TODO: Need to fix this for WAL mod. Can't just copy.
- (system (conc "/bin/mkdir -p " dest-directory))
- (system (conc "/bin/cp " srcfile " " destfile))
- #t)
- (changed ;; (and changed
- #t)
- ((and changed *time-to-exit*) ;; last sync
- #t)
- (else
- #f))))
-
- (if (or dejunk do-cp)
- (let* ((start-time (current-milliseconds))
- (subdb (or (dbfile:get-subdb dbstruct run-id) (dbfile:init-subdb dbstruct run-id dbfile:db-init-proc)))
- (dbdat (or (dbfile:get-dbdat dbstruct run-id) (dbfile:open-db dbstruct run-id dbfile:db-init-proc)))
- (mtdb (dbr:subdb-mtdbdat subdb))
- ;;
- ;; BUG: -mrw- I think this next line is wrong. run-id should be the path to .mtdb/.db
- ;;
- (tmpdb (dbfile:open-db dbstruct run-id dbfile:db-init-proc)))
-
- (if dejunk
- (begin
- (debug:print 0 *default-log-port* "Cleaning tmp DB")
- (db:clean-up run-id tmpdb)
- (debug:print 0 *default-log-port* "Cleaning nfs DB")
- (db:clean-up run-id mtdb)
- )
- )
- (debug:print-info 2 *default-log-port* "delta syncing file: " srcfile ", time diff: " (- time1 time2) " seconds")
- (if old2new
- (begin
- (db:sync-tables (db:sync-all-tables-list
- (db:get-keys dbstruct))
- #f mtdb tmpdb))
- (begin
- (db:sync-tables (db:sync-all-tables-list (db:get-keys dbstruct)) #f tmpdb mtdb)))
- (hash-table-set! sync-durations (conc srcfile ".db") (- (current-milliseconds) start-time)))
- (debug:print-info 2 *default-log-port* "skipping delta sync. " srcfile " is up to date"))))
- dbfiles))
- data-synced))
-
-;; Sync all changed db's
-;;
-(define (db:tmp->megatest.db-sync dbstruct run-id last-update)
- (let* ((subdbs (hash-table-values (dbr:dbstruct-subdbs dbstruct)))
- (res '()))
- (for-each
- (lambda (subdb)
- (let* ((mtdb (dbr:subdb-mtdb subdb))
- (tmpdb (db:get-subdb dbstruct run-id))
- (refndb (dbr:subdb-refndb subdb))
- (newres (db:sync-tables (db:sync-all-tables-list (db:get-keys dbstruct)) last-update tmpdb refndb mtdb)))
- ;; (stack-push! (dbr:subdb-dbstack subdb) tmpdb)
- ;; BUG: verify this is really needed
- (dbfile:add-dbdat dbstruct run-id tmpdb)
- (set! res (cons newres res))))
- subdbs)
- res))
-
-;;;; run-ids
-;; if #f use *db-local-sync* : or 'local-sync-flags
-;; if #t use timestamps : or 'timestamps
-;;
-;; NB// no-sync-db is the db handle, not a flag!
-;;
-(define (db:sync-to-megatest.db dbstruct #!key (no-sync-db #f))
- (let* ((start-time (current-seconds))
- (last-full-update (if no-sync-db
- (db:no-sync-get/default no-sync-db "LAST_FULL_UPDATE" 0)
- 0))
- (full-sync-needed (> (- start-time last-full-update) 3600)) ;; every hour do a full sync
- (last-update (if full-sync-needed
- 0
- (if no-sync-db
- (db:no-sync-get/default no-sync-db "LAST_UPDATE" 0)
- 0))) ;; (or (db:get-var dbstruct "LAST_UPDATE") 0))
- (sync-needed (> (- start-time last-update) 6))
- (res (if (or sync-needed ;; don't sync if a sync already occurred in the past 6 seconds
- full-sync-needed)
- (begin
- (if no-sync-db
- (begin
- (if full-sync-needed (db:no-sync-set no-sync-db "LAST_FULL_UPDATE" start-time))
- (db:no-sync-set no-sync-db "LAST_UPDATE" start-time)))
- (db:tmp->megatest.db-sync dbstruct last-update))
- 0))
- (sync-time (- (current-seconds) start-time)))
- (debug:print-info 3 *default-log-port* "Sync of newdb to olddb completed in " sync-time " seconds pid="(current-process-id))
- (if (common:low-noise-print 30 "sync new to old")
- (if sync-needed
- (debug:print-info 0 *default-log-port* "Sync of " res " records from newdb to olddb completed in " sync-time " seconds pid="(current-process-id))
- (debug:print-info 0 *default-log-port* "No sync needed, last updated " (- start-time last-update) " seconds ago")))
- res))
-
-
-(define (db:initialize-main-db db)
- (when (not *configinfo*)
- (launch:setup)) ;; added because Elena was getting stack dump because *configinfo* below was #f.
- (let* ((configdat (car *configinfo*)) ;; tut tut, global warning...
- (keys (keys:config-get-fields configdat))
- (havekeys (> (length keys) 0))
- (keystr (keys->keystr keys))
- (fieldstr (keys:make-key/field-string configdat))
- #;(db (dbr:dbdat-dbh dbdat)))
- (for-each (lambda (key)
- (let ((keyn key))
- (if (member (string-downcase keyn)
- (list "runname" "state" "status" "owner" "event_time" "comment" "fail_count"
- "pass_count" "contour"))
- (begin
- (debug:print 0 *default-log-port* "ERROR: your key cannot be named " keyn " as this conflicts with the same named field in the runs table, you must remove your megatest.db and /.db before trying again.")
- (exit 1)))))
- keys)
- (sqlite3:with-transaction
- db
- (lambda ()
- ;; handle-exceptions
- ;; exn
- ;; (begin
- ;; (debug:print 0 "ERROR: Failed to create tables. Look at your [fields] section, should be: fieldname TEXT DEFAULT 'yourdefault'")
- ;; (exit))
- (sqlite3:execute db "CREATE TABLE IF NOT EXISTS keys (id INTEGER PRIMARY KEY, fieldname TEXT, fieldtype TEXT, CONSTRAINT keyconstraint UNIQUE (fieldname));")
- (for-each
- (lambda (key)
- (let* ((fieldname #f)
- (fieldtype #f))
- (sqlite3:for-each-row
- (lambda (fn ft)
- (set! fieldname fn)
- (set! fieldtype ft))
- db
- "SELECT fieldname,fieldtype FROM keys WHERE fieldname=?" key)
- (if (not fieldname)
- (sqlite3:execute db "INSERT INTO keys (fieldname,fieldtype) VALUES (?,?);" key "TEXT"))))
- keys)
- (sqlite3:execute db (conc
- "CREATE TABLE IF NOT EXISTS runs (id INTEGER PRIMARY KEY, \n "
- fieldstr (if havekeys "," "") "
- runname TEXT DEFAULT 'norun',
- contour TEXT DEFAULT '',
- state TEXT DEFAULT '',
- status TEXT DEFAULT '',
- owner TEXT DEFAULT '',
- event_time TIMESTAMP DEFAULT (strftime('%s','now')),
- comment TEXT DEFAULT '',
- fail_count INTEGER DEFAULT 0,
- pass_count INTEGER DEFAULT 0,
- last_update INTEGER DEFAULT (strftime('%s','now')),
- CONSTRAINT runsconstraint UNIQUE (runname" (if havekeys "," "") keystr "));"))
- ;; All triggers created at once in end
- ;;(sqlite3:execute db "CREATE TRIGGER IF NOT EXISTS update_runs_trigger AFTER UPDATE ON runs
- ;; FOR EACH ROW
- ;; BEGIN
- ;; UPDATE runs SET last_update=(strftime('%s','now'))
- ;; WHERE id=old.id;
- ;; END;")
- (sqlite3:execute db "CREATE TABLE IF NOT EXISTS run_stats (
- id INTEGER PRIMARY KEY,
- run_id INTEGER,
- state TEXT,
- status TEXT,
- count INTEGER,
- last_update INTEGER DEFAULT (strftime('%s','now')))")
- ;; All triggers created at once in end
- ;; (sqlite3:execute db "CREATE TRIGGER IF NOT EXISTS update_run_stats_trigger AFTER UPDATE ON run_stats
- ;; FOR EACH ROW
- ;; BEGIN
- ;; UPDATE run_stats SET last_update=(strftime('%s','now'))
- ;; WHERE id=old.id;
- ;; END;")
- (sqlite3:execute db "CREATE TABLE IF NOT EXISTS test_meta (
- id INTEGER PRIMARY KEY,
- testname TEXT DEFAULT '',
- author TEXT DEFAULT '',
- owner TEXT DEFAULT '',
- description TEXT DEFAULT '',
- reviewed TIMESTAMP,
- iterated TEXT DEFAULT '',
- avg_runtime REAL,
- avg_disk REAL,
- tags TEXT DEFAULT '',
- jobgroup TEXT DEFAULT 'default',
- CONSTRAINT test_meta_constraint UNIQUE (testname));")
- (sqlite3:execute db "CREATE TABLE IF NOT EXISTS tasks_queue (id INTEGER PRIMARY KEY,
- action TEXT DEFAULT '',
- owner TEXT,
- state TEXT DEFAULT 'new',
- target TEXT DEFAULT '',
- name TEXT DEFAULT '',
- testpatt TEXT DEFAULT '',
- keylock TEXT,
- params TEXT,
- creation_time TIMESTAMP DEFAULT (strftime('%s','now')),
- execution_time TIMESTAMP);")
- ;; archive disk areas, cached info from [archive-disks]
- (sqlite3:execute db "CREATE TABLE IF NOT EXISTS archive_disks (
- id INTEGER PRIMARY KEY,
- archive_area_name TEXT,
- disk_path TEXT,
- last_df INTEGER DEFAULT -1,
- last_df_time TIMESTAMP DEFAULT (strftime('%s','now')),
- creation_time TIMESTAMP DEFAULT (strftime('%s','now')));")
- ;; individual bup (or tar) data chunks
- (sqlite3:execute db "CREATE TABLE IF NOT EXISTS archive_blocks (
- id INTEGER PRIMARY KEY,
- archive_disk_id INTEGER,
- disk_path TEXT,
- last_du INTEGER DEFAULT -1,
- last_du_time TIMESTAMP DEFAULT (strftime('%s','now')),
- creation_time TIMESTAMP DEFAULT (strftime('%s','now')));")
- ;; tests allocated to what chunks. reusing a chunk for a test/item_path is very efficient
- ;; NB// the per run/test recording of where the archive is stored is done in the test
- ;; record.
- (sqlite3:execute db "CREATE TABLE IF NOT EXISTS archive_allocations (
- id INTEGER PRIMARY KEY,
- archive_block_id INTEGER,
- testname TEXT,
- item_path TEXT,
- creation_time TIMESTAMP DEFAULT (strftime('%s','now')));")
- ;; move this clean up call somewhere else
- (sqlite3:execute db "DELETE FROM tasks_queue WHERE state='done' AND creation_time < ?;" (- (current-seconds)(* 24 60 60))) ;; remove older than 24 hrs
- (sqlite3:execute db (conc "CREATE INDEX IF NOT EXISTS runs_index ON runs (runname" (if havekeys "," "") keystr ");"))
- ;; (sqlite3:execute db "CREATE VIEW runs_tests AS SELECT * FROM runs INNER JOIN tests ON runs.id=tests.run_id;")
- (sqlite3:execute db "CREATE TABLE IF NOT EXISTS extradat (id INTEGER PRIMARY KEY, run_id INTEGER, key TEXT, val TEXT);")
- (sqlite3:execute db "CREATE TABLE IF NOT EXISTS metadat (id INTEGER PRIMARY KEY, var TEXT, val TEXT,
- CONSTRAINT metadat_constraint UNIQUE (var));")
- (sqlite3:execute db "CREATE TABLE IF NOT EXISTS access_log (id INTEGER PRIMARY KEY, user TEXT, accessed TIMESTAMP, args TEXT);")
- ;; Must do this *after* running patch db !! No more.
- ;; cannot use db:set-var since it will deadlock, hardwire the code here
- (let* ((prev-version #f)
- (curr-version (common:version-signature)))
- (sqlite3:for-each-row
- (lambda (ver)
- (set! prev-version ver))
- db
- "SELECT val FROM metadat WHERE var='MEGATEST_VERSION';")
- (if prev-version
- (if (not (equal? prev-version curr-version))
- (sqlite3:execute db "UPDATE metadat SET val=? WHERE var=?;" curr-version "MEGATEST_VERSION"))
- (sqlite3:execute db "INSERT OR REPLACE INTO metadat (var,val) VALUES (?,?);" "MEGATEST_VERSION" curr-version) ))
- (debug:print-info 11 *default-log-port* "db:initialize END") ;; ))))
-
- ;;======================================================================
- ;; R U N S P E C I F I C D B
- ;;======================================================================
-
- ;; (define (db:initialize-run-id-db db)
- ;; (sqlite3:with-transaction
- ;; db
- ;; (lambda ()
- (sqlite3:execute db "CREATE TABLE IF NOT EXISTS tests
- (id INTEGER PRIMARY KEY,
- run_id INTEGER DEFAULT -1,
- testname TEXT DEFAULT 'noname',
- host TEXT DEFAULT 'n/a',
- cpuload REAL DEFAULT -1,
- diskfree INTEGER DEFAULT -1,
- uname TEXT DEFAULT 'n/a',
- rundir TEXT DEFAULT '/tmp/badname',
- shortdir TEXT DEFAULT '/tmp/badname',
- item_path TEXT DEFAULT '',
- state TEXT DEFAULT 'NOT_STARTED',
- status TEXT DEFAULT 'FAIL',
- attemptnum INTEGER DEFAULT 0,
- final_logf TEXT DEFAULT 'logs/final.log',
- logdat TEXT DEFAULT '',
- run_duration INTEGER DEFAULT 0,
- comment TEXT DEFAULT '',
- event_time TIMESTAMP DEFAULT (strftime('%s','now')),
- fail_count INTEGER DEFAULT 0,
- pass_count INTEGER DEFAULT 0,
- archived INTEGER DEFAULT 0, -- 0=no, > 1=archive block id where test data can be found
- last_update INTEGER DEFAULT (strftime('%s','now')),
- CONSTRAINT testsconstraint UNIQUE (run_id, testname, item_path));")
- ;; deprecated -- (sqlite3:execute db "CREATE INDEX IF NOT EXISTS tests_index ON tests (run_id, testname, item_path, uname);")
-
- (sqlite3:execute db "CREATE INDEX IF NOT EXISTS tests_run_id_index ON tests (run_id);") ;; new
- (sqlite3:execute db "CREATE INDEX IF NOT EXISTS tests_testname_index ON tests (testname,item_path);") ;; new
- (sqlite3:execute db "CREATE INDEX IF NOT EXISTS tests_state_status_index ON tests (state, status); ") ;; new
-
- ;; All triggers created at once in end
- ;;(sqlite3:execute db "CREATE TRIGGER IF NOT EXISTS update_tests_trigger AFTER UPDATE ON tests
- ;; FOR EACH ROW
- ;; BEGIN
- ;; UPDATE tests SET last_update=(strftime('%s','now'))
- ;; WHERE id=old.id;
- ;; END;")
- (sqlite3:execute db "CREATE TABLE IF NOT EXISTS test_steps
- (id INTEGER PRIMARY KEY,
- test_id INTEGER,
- stepname TEXT,
- state TEXT DEFAULT 'NOT_STARTED',
- status TEXT DEFAULT 'n/a',
- event_time TIMESTAMP,
- comment TEXT DEFAULT '',
- logfile TEXT DEFAULT '',
- last_update INTEGER DEFAULT (strftime('%s','now')),
- CONSTRAINT test_steps_constraint UNIQUE (test_id,stepname,state));")
- (sqlite3:execute db "CREATE INDEX IF NOT EXISTS teststeps_index ON test_steps (test_id, stepname, state);")
- ;; All triggers created at once in end
- ;;(sqlite3:execute db "CREATE TRIGGER IF NOT EXISTS update_teststeps_trigger AFTER UPDATE ON test_steps
- ;; FOR EACH ROW
- ;; BEGIN
- ;; UPDATE test_steps SET last_update=(strftime('%s','now'))
- ;; WHERE id=old.id;
- ;; END;")
- (sqlite3:execute db "CREATE TABLE IF NOT EXISTS test_data (id INTEGER PRIMARY KEY,
- test_id INTEGER,
- category TEXT DEFAULT '',
- variable TEXT,
- value REAL,
- expected REAL,
- tol REAL,
- units TEXT,
- comment TEXT DEFAULT '',
- status TEXT DEFAULT 'n/a',
- type TEXT DEFAULT '',
- last_update INTEGER DEFAULT (strftime('%s','now')),
- CONSTRAINT test_data_constraint UNIQUE (test_id,category,variable));")
- (sqlite3:execute db "CREATE INDEX IF NOT EXISTS test_data_index ON test_data (test_id);")
- ;; All triggers created at once in end
- ;;(sqlite3:execute db "CREATE TRIGGER IF NOT EXISTS update_test_data_trigger AFTER UPDATE ON test_data
- ;; FOR EACH ROW
- ;; BEGIN
- ;; UPDATE test_data SET last_update=(strftime('%s','now'))
- ;; WHERE id=old.id;
- ;; END;")
- (sqlite3:execute db "CREATE TABLE IF NOT EXISTS test_rundat (
- id INTEGER PRIMARY KEY,
- test_id INTEGER,
- update_time TIMESTAMP,
- cpuload INTEGER DEFAULT -1,
- diskfree INTEGER DEFAULT -1,
- diskusage INTGER DEFAULT -1,
- run_duration INTEGER DEFAULT 0,
- last_update INTEGER DEFAULT (strftime('%s','now')));")
- (sqlite3:execute db "CREATE TABLE IF NOT EXISTS archives (
- id INTEGER PRIMARY KEY,
- test_id INTEGER,
- state TEXT DEFAULT 'new',
- status TEXT DEFAULT 'n/a',
- archive_type TEXT DEFAULT 'bup',
- du INTEGER,
- archive_path TEXT,
- last_update INTEGER DEFAULT (strftime('%s','now')));")))
- (db:create-triggers db)
- db)) ;; )
-
-;;======================================================================
-;; A R C H I V E S
-;;======================================================================
-
-;; dneeded is minimum space needed, scan for existing archives that
-;; are on disks with adequate space and already have this test/itempath
-;; archived
-;;
-(define (db:archive-get-allocations dbstruct testname itempath dneeded)
- (let* ((dbdat (db:get-subdb dbstruct #f)) ;; archive tables are in main.db
- (db (dbr:dbdat-dbh dbdat))
- (res '())
- (blocks '())) ;; a block is an archive chunck that can be added too if there is space
- (sqlite3:for-each-row
- (lambda (id archive-disk-id disk-path last-du last-du-time)
- (set! res (cons (vector id archive-disk-id disk-path last-du last-du-time) res)))
- db
- "SELECT b.id,b.archive_disk_id,b.disk_path,b.last_du,b.last_du_time FROM archive_blocks AS b
- INNER JOIN archive_allocations AS a ON a.archive_block_id=b.id
- WHERE a.testname=? AND a.item_path=?;"
- testname itempath)
- ;; Now res has list of candidate paths, look in archive_disks for candidate with potential free space
- (if (null? res)
- '()
- (sqlite3:for-each-row
- (lambda (id archive-area-name disk-path last-df last-df-time)
- (set! blocks (cons (vector id archive-area-name disk-path last-df last-df-time) blocks)))
- db
- (conc
- "SELECT d.id,d.archive_area_name,disk_path,last_df,last_df_time FROM archive_disks AS d
- INNER JOIN archive_blocks AS b ON d.id=b.archive_disk_id
- WHERE b.id IN (" (string-intersperse (map conc res) ",") ") AND
- last_df > ?;")
- dneeded))
- ;; BUG: Verfify this is really needed
- (dbfile:add-dbdat dbstruct #f dbdat)
- blocks))
-
-;; returns id of the record, register a disk allocated to archiving and record it's last known
-;; available space
-;;
-(define (db:archive-register-disk dbstruct bdisk-name bdisk-path df)
- (let* ((dbdat (db:get-subdb dbstruct #f)) ;; archive tables are in main.db
- (db (dbr:dbdat-dbh dbdat))
- (res #f))
- (sqlite3:for-each-row
- (lambda (id)
- (set! res id))
- db
- "SELECT id FROM archive_disks WHERE archive_area_name=? AND disk_path=?;"
- bdisk-name bdisk-path)
- (if res ;; record exists, update df and return id
- (begin
- (sqlite3:execute db "UPDATE archive_disks SET last_df=?,last_df_time=(strftime('%s','now'))
- WHERE archive_area_name=? AND disk_path=?;"
- df bdisk-name bdisk-path)
- (dbfile:add-dbdat dbstruct #f dbdat)
- res)
- (begin
- (sqlite3:execute
- db
- "INSERT OR REPLACE INTO archive_disks (archive_area_name,disk_path,last_df)
- VALUES (?,?,?);"
- bdisk-name bdisk-path df)
- (dbfile:add-dbdat dbstruct #f dbdat)
- (db:archive-register-disk dbstruct bdisk-name bdisk-path df)))))
-
-;; record an archive path created on a given archive disk (identified by it's bdisk-id)
-;; if path starts with / then it is full, otherwise it is relative to the archive disk
-;; preference is to store the relative path.
-;;
-(define (db:archive-register-block-name dbstruct bdisk-id archive-path #!key (du #f))
- (let* ((dbdat (db:get-subdb dbstruct #f)) ;; archive tables are in main.db
- (db (dbr:dbdat-dbh dbdat))
- (res #f))
- ;; first look to see if this path is already registered
- (sqlite3:for-each-row
- (lambda (id)
- (set! res id))
- db
- "SELECT id FROM archive_blocks WHERE archive_disk_id=? AND disk_path=?;"
- bdisk-id archive-path)
- (if res ;; record exists, update du if applicable and return res
- (if du (sqlite3:execute db "UPDATE archive_blocks SET last_du=?,last_du_time=(strftime('%s','now'))
- WHERE archive_disk_id=? AND disk_path=?;"
- bdisk-id archive-path du))
- (begin
- (sqlite3:execute db "INSERT OR REPLACE INTO archive_blocks (archive_disk_id,disk_path,last_du)
- VALUES (?,?,?);"
- bdisk-id archive-path (or du 0))
- (set! res (db:archive-register-block-name dbstruct bdisk-id archive-path du: du))))
- (dbfile:add-dbdat dbstruct #f dbdat)
- res))
-
-
-;; The "archived" field in tests is overloaded; 0 = not archived, > 0 archived in block with given id
-;;
-(define (db:test-set-archive-block-id dbstruct run-id test-id archive-block-id)
- (db:with-db
- dbstruct
- run-id
- #t
- (lambda (dbdat db)
- (sqlite3:execute db "UPDATE tests SET archived=? WHERE id=?;"
- archive-block-id test-id))))
-
-;; Look up the archive block info given a block-id
-;;
-(define (db:test-get-archive-block-info dbstruct archive-block-id)
- (db:with-db
- dbstruct
- #f
- #f
- (lambda (dbdat db)
- (let ((res #f))
- (sqlite3:for-each-row
- ;; 0 1 2 3 4 5
- (lambda (id archive-disk-id disk-path last-du last-du-time creation-time)
- (set! res (vector id archive-disk-id disk-path last-du last-du-time creation-time)))
- db
- "SELECT id,archive_disk_id,disk_path,last_du,last_du_time,creation_time FROM archive_blocks WHERE id=?;"
- archive-block-id)
- res))))
-
-;; (define (db:archive-allocate-testsuite/area-to-block block-id testsuite-name areakey)
-;; (let* ((dbdat (db:get-subdb dbstruct #f)) ;; archive tables are in main.db
-;; (db (dbr:dbdat-dbh dbdat))
-;; (res '())
-;; (blocks '())) ;; a block is an archive chunck that can be added too if there is space
-;; (sqlite3:for-each-row #f)
-
-;;======================================================================
-;; D B U T I L S
-;;======================================================================
-
-;;======================================================================
-;; M A I N T E N A N C E
-;;======================================================================
-
-;; (define (db:have-incompletes? dbstruct run-id ovr-deadtime)
-;; (let* ((incompleted '())
-;; (oldlaunched '())
-;; (toplevels '())
-;; (deadtime-str (configf:lookup *configdat* "setup" "deadtime"))
-;; (deadtime (if (and deadtime-str
-;; (string->number deadtime-str))
-;; (string->number deadtime-str)
-;; 72000))) ;; twenty hours
-;; (db:with-db
-;; dbstruct run-id #f
-;; (lambda (dbdat db)
-;; (if (number? ovr-deadtime)(set! deadtime ovr-deadtime))
-;;
-;; ;; in RUNNING or REMOTEHOSTSTART for more than 10 minutes
-;; ;;
-;; ;; HOWEVER: this code in run:test seems to work fine
-;; ;; (> (- (current-seconds)(+ (db:test-get-event_time testdat)
-;; ;; (db:test-get-run_duration testdat)))
-;; ;; 600)
-;; ;; (db:delay-if-busy dbdat)
-;; (sqlite3:for-each-row
-;; (lambda (test-id run-dir uname testname item-path)
-;; (if (and (equal? uname "n/a")
-;; (equal? item-path "")) ;; this is a toplevel test
-;; ;; what to do with toplevel? call rollup?
-;; (begin
-;; (set! toplevels (cons (list test-id run-dir uname testname item-path run-id) toplevels))
-;; (debug:print-info 0 *default-log-port* "Found old toplevel test in RUNNING state, test-id=" test-id))
-;; (set! incompleted (cons (list test-id run-dir uname testname item-path run-id) incompleted))))
-;; (db:get-cache-stmth dbdat db
-;; "SELECT id,rundir,uname,testname,item_path FROM tests WHERE run_id=? AND (strftime('%s','now') - event_time) > (run_duration + ?) AND state IN ('RUNNING','REMOTEHOSTSTART');")
-;; run-id deadtime)
-;;
-;; ;; in LAUNCHED for more than one day. Could be long due to job queues TODO/BUG: Need override for this in config
-;; ;;
-;; ;; (db:delay-if-busy dbdat)
-;; (sqlite3:for-each-row
-;; (lambda (test-id run-dir uname testname item-path)
-;; (if (and (equal? uname "n/a")
-;; (equal? item-path "")) ;; this is a toplevel test
-;; ;; what to do with toplevel? call rollup?
-;; (set! toplevels (cons (list test-id run-dir uname testname item-path run-id) toplevels))
-;; (set! oldlaunched (cons (list test-id run-dir uname testname item-path run-id) oldlaunched))))
-;; (db:get-cache-stmth dbdat db
-;; "SELECT id,rundir,uname,testname,item_path FROM tests WHERE run_id=? AND (strftime('%s','now') - event_time) > 86400 AND state IN ('LAUNCHED');")
-;; run-id)
-;;
-;; (debug:print-info 18 *default-log-port* "Found " (length oldlaunched) " old LAUNCHED items, " (length toplevels) " old LAUNCHED toplevel tests and " (length incompleted) " tests marked RUNNING but apparently dead.")
-;; (if (and (null? incompleted)
-;; (null? oldlaunched)
-;; (null? toplevels))
-;; #f
-;; #t)))))
-
-;; BUG: Probably broken - does not explicitly use run-id in the query
-;;
-(define (db:top-test-set-per-pf-counts dbstruct run-id test-name)
- (db:general-call dbstruct run-id 'top-test-set-per-pf-counts (list test-name test-name test-name test-name test-name test-name test-name test-name test-name test-name test-name test-name test-name test-name test-name test-name test-name)))
-
-;; Clean out old junk and vacuum the database
-;;
-;; Ultimately do something like this:
-;;
-;; 1. Look at test records either deleted or part of deleted run:
-;; a. If test dir exists, set the the test to state='UNKNOWN', Set the run to 'unknown'
-;; b. If test dir gone, delete the test record
-;; 2. Look at run records
-;; a. If have tests that are not deleted, set state='unknown'
-;; b. ....
-;;
-(define (db:clean-up run-id dbdat)
- (if run-id
- (begin
- (debug:print 0 *default-log-port* "Cleaning run DB " run-id)
- (db:clean-up-rundb dbdat run-id)
- )
- (begin
- (debug:print 0 *default-log-port* "Cleaning main DB ")
- (db:clean-up-maindb dbdat)
- )
- )
-)
-
-
-;; Clean out old junk and vacuum the database
-;;
-;; Ultimately do something like this:
-;;
-;; 1. Look at test records either deleted or part of deleted run:
-;; a. If test dir exists, set the the test to state='UNKNOWN', Set the run to 'unknown'
-;; b. If test dir gone, delete the test record
-;; 2. Look at run records
-;; a. If have tests that are not deleted, set state='unknown'
-;; b. ....
-;;
-(define (db:clean-up-rundb dbdat run-id)
- ;; (debug:print 0 *default-log-port* "WARNING: db clean up not fully ported to v1.60, cleanup action will be on megatest.db")
- (let* ((db (dbr:dbdat-dbh dbdat))
- (test-count-stmt (sqlite3:prepare db "SELECT (SELECT count(id) FROM tests);"))
- (step-count-stmt (sqlite3:prepare db "SELECT (SELECT count(id) FROM test_steps);"))
- (statements
- (map (lambda (stmt)
- (sqlite3:prepare db stmt))
- (list
- "DELETE FROM tests WHERE state='DELETED';"
- "DELETE FROM test_steps WHERE status = 'DELETED';"
- "DELETE FROM tests WHERE run_id IN (SELECT id FROM runs WHERE state = 'deleted');"
- ))))
- (sqlite3:with-transaction
- db
- (lambda ()
- (sqlite3:for-each-row (lambda (tot)
- (debug:print-info 0 *default-log-port* "Test records count before clean: " tot))
- test-count-stmt)
- (sqlite3:for-each-row (lambda (tot)
- (debug:print-info 0 *default-log-port* "Test_step records count before clean: " tot))
- step-count-stmt)
- (map sqlite3:execute statements)
- (sqlite3:for-each-row (lambda (tot)
- (debug:print-info 0 *default-log-port* "Test records count after clean: " tot))
- test-count-stmt)
- (sqlite3:for-each-row (lambda (tot)
- (debug:print-info 0 *default-log-port* "Test_step records count after clean: " tot))
- step-count-stmt)))
- (map sqlite3:finalize! statements)
- (sqlite3:finalize! test-count-stmt)
- (sqlite3:finalize! step-count-stmt)
- (sqlite3:execute db "VACUUM;")))
-
-;; Clean out old junk and vacuum the database
-;;
-;; Ultimately do something like this:
-;;
-;; 1. Look at test records either deleted or part of deleted run:
-;; a. If test dir exists, set the the test to state='UNKNOWN', Set the run to 'unknown'
-;; b. If test dir gone, delete the test record
-;; 2. Look at run records
-;; a. If have tests that are not deleted, set state='unknown'
-;; b. ....
-;;
-(define (db:clean-up-maindb dbdat)
- ;; (debug:print 0 *default-log-port* "WARNING: db clean up not fully ported to v1.60, cleanup action will be on megatest.db")
- (let* ((db (dbr:dbdat-dbh dbdat))
- (count-stmt (sqlite3:prepare db "SELECT (SELECT count(id) FROM runs);"))
- (statements
- (map (lambda (stmt)
- (sqlite3:prepare db stmt))
- (list
- ;; delete all tests that belong to runs that are 'deleted'
- ;; (conc "DELETE FROM tests WHERE run_id NOT IN (" (string-intersperse (map conc valid-runs) ",") ");")
- ;; delete all tests that are 'DELETED'
- "DELETE FROM runs WHERE state='deleted';"
- )))
- (dead-runs '()))
- (sqlite3:for-each-row
- (lambda (run-id)
- (set! dead-runs (cons run-id dead-runs)))
- db
- "SELECT id FROM runs WHERE state='deleted';")
- ;; (db:delay-if-busy dbdat)
- (sqlite3:with-transaction
- db
- (lambda ()
- (sqlite3:for-each-row (lambda (tot)
- (debug:print-info 0 *default-log-port* "Run records count before clean: " tot))
- count-stmt)
- (map sqlite3:execute statements)
- (sqlite3:for-each-row (lambda (tot)
- (debug:print-info 0 *default-log-port* "Run records count after clean: " tot))
- count-stmt)))
- (map sqlite3:finalize! statements)
- (sqlite3:finalize! count-stmt)
- ;; (db:find-and-mark-incomplete db)
- ;; (db:delay-if-busy dbdat)
- (sqlite3:execute db "VACUUM;")
- dead-runs))
-
-;;======================================================================
-;; no-sync.db - small bits of data to be shared between servers
-;;======================================================================
-
-(define (db:get-dbsync-path)
- (case (rmt:transport-mode)
- ((http)(common:make-tmpdir-name *toppath* ""))
- ((tcp) (conc *toppath*"/.mtdb"))
- ((nfs) (conc *toppath*"/.mtdb"))
- (else "/tmp/dunno-this-gonna-exist")))
-
-;; This is needed for api.scm
-(define (db:open-no-sync-db)
- (dbfile:open-no-sync-db (db:get-dbsync-path)))
-
-;; why get the keys from the db? why not get from the *configdat*
-;; using keys:config-get-fields?
-
-(define (db:get-keys dbstruct)
- (keys:config-get-fields *configdat*))
-
-;; extract index number given a header/data structure
-(define (db:get-index-by-header header field)
- (list-index (lambda (x)(equal? x field)) header))
-
-;; look up values in a header/data structure
-(define (db:get-value-by-header row header field)
- (let ((len (if (vector? row)
- (vector-length row)
- 0)))
- (if (or (null? header) (not row))
- #f
- (let loop ((hed (car header))
- (tal (cdr header))
- (n 0))
- (if (equal? hed field)
- (handle-exceptions
- exn
- (begin
- (debug:print 4 *default-log-port* "WARNING: attempt to read non-existant field, row="
- row " header=" header " field=" field ", exn=" exn)
- #f)
- (if (>= n len)
- #f
- (vector-ref row n)))
- (if (null? tal) #f (loop (car tal)(cdr tal)(+ n 1))))))))
-
-;; Accessors for the header/data structure
-;; get rows and header from
-(define (db:get-header vec)(vector-ref vec 0))
-(define (db:get-rows vec)(vector-ref vec 1))
-
-;;======================================================================
-;; R U N S
-;;======================================================================
-
-(define (db:get-run-times dbstruct run-patt target-patt)
-(let ((res `())
- (qry (conc "select runname, (max(end_time)-min(event_time))/60 as runtime, target from (select runname, run_id,tests.event_time,tests.event_time+run_duration AS end_time, " (string-join (db:get-keys dbstruct) " || '/' || ") " as target from tests inner join runs on tests.run_id = runs.id where runs.runname like ? and target like ?) group by run_id ;")))
- ;(print qry)
- (db:with-db
- dbstruct
- #f ;; this is for the main runs db
- #f ;; does not modify db
- (lambda (dbdat db)
- (sqlite3:for-each-row
- (lambda (runname runtime target )
- (set! res (cons (vector runname runtime target) res)))
- db
- qry
- run-patt target-patt)
- res))))
-
-(define (db:get-run-name-from-id dbstruct run-id)
- (db:with-db
- dbstruct
- #f ;; this is for the main runs db
- #f ;; does not modify db
- (lambda (dbdat db)
- (let ((res #f))
- (sqlite3:for-each-row
- (lambda (runname)
- (set! res runname))
- db
- "SELECT runname FROM runs WHERE id=?;"
- run-id)
- res))))
-
-(define (db:get-run-key-val dbstruct run-id key)
- (db:with-db
- dbstruct
- #f
- #f
- (lambda (dbdat db)
- (let ((res #f))
- (sqlite3:for-each-row
- (lambda (val)
- (set! res val))
- db
- (conc "SELECT " key " FROM runs WHERE id=?;")
- run-id)
- res))))
-
-;; keys list to key1,key2,key3 ...
-(define (runs:get-std-run-fields keys remfields)
- (let* ((header (append keys remfields))
- (keystr (conc (keys->keystr keys) ","
- (string-intersperse remfields ","))))
- (list keystr header)))
-
-;; make a query (fieldname like 'patt1' OR fieldname
-(define (db:patt->like fieldname pattstr #!key (comparator " OR "))
- (let ((patts (if (string? pattstr)
- (string-split pattstr ",")
- '("%"))))
- (string-intersperse (map (lambda (patt)
- (let ((wildtype (if (substring-index "%" patt) "LIKE" "GLOB")))
- (conc fieldname " " wildtype " '" patt "'")))
- (if (null? patts)
- '("")
- patts))
- comparator)))
-
-
-;; register a test run with the db, this accesses the main.db and does NOT
-;; use server api
-;;
-(define (db:register-run dbstruct keyvals runname state status user contour-in)
- (let* ((keys (map car keyvals))
- (keystr (keys->keystr keys))
- (contour (or contour-in "")) ;; empty string to force no hierarcy and be backwards compatible.
- (comma (if (> (length keys) 0) "," ""))
- (andstr (if (> (length keys) 0) " AND " ""))
- (valslots (keys->valslots keys)) ;; ?,?,? ...
- (allvals (append (list runname state status user contour) (map cadr keyvals)))
- (qryvals (append (list runname) (map cadr keyvals)))
- (key=?str (string-intersperse (map (lambda (k)(conc k "=?")) keys) " AND ")))
- ;; (debug:print 0 *default-log-port* "Got here 0.")
- (debug:print 3 *default-log-port* "keys: " keys " allvals: " allvals " keyvals: " keyvals " key=?str is " key=?str)
- (debug:print 2 *default-log-port* "NOTE: using target " (string-intersperse (map cadr keyvals) "/") " for this run")
- (if (and runname (null? (filter (lambda (x)(not x)) keyvals))) ;; there must be a better way to "apply and"
- (db:with-db
- dbstruct #f #t
- (lambda (dbdat db)
- ;; (debug:print 0 *default-log-port* "Got here 1.")
- (let ((res #f))
- (apply sqlite3:execute db
- (conc "INSERT OR IGNORE INTO runs (runname,state,status,owner,event_time,contour"
- comma keystr ") VALUES (?,?,?,?,strftime('%s','now'),?" comma valslots ");")
- allvals)
- (apply sqlite3:for-each-row
- (lambda (id)
- (set! res id))
- db
- (let ((qry (conc "SELECT id FROM runs WHERE (runname=? " andstr key=?str ");")))
- qry)
- qryvals)
- (sqlite3:execute db "UPDATE runs SET state=?,status=?,event_time=strftime('%s','now') WHERE id=? AND state='deleted';" state status res)
- res)))
- (begin
- (debug:print-error 0 *default-log-port* "Called without all necessary keys")
- #f))))
-
-(define (db:get-run-id dbstruct runname target)
- (let ((runs (db:simple-get-runs dbstruct runname #f #f target #f))) ;; runpatt count offset target last-update
- (if (null? runs)
- #f
- (simple-run-id (car runs)))))
-
-;; called with run-id=#f so will operate on main.db
-;;
-(define (db:insert-run dbstruct run-id target runname run-meta)
- (let* ((keys (db:get-keys dbstruct))
- (runs (db:simple-get-runs dbstruct runname #f #f target #f))) ;; runpatt count offset target last-update
- ;; need to insert run based on target and runname
- (let* ((targvals (string-split target "/"))
- (keystr (string-intersperse keys ","))
- (key?str (string-intersperse (make-list (length targvals) "?") ","))
- (qrystr (conc "INSERT INTO runs (id,runname,"keystr") VALUES (?,?,"key?str")"))
- (get-var (lambda (db qrystr)
- (let* ((res #f))
- (sqlite3:for-each-row
- (lambda row
- (set res (car row)))
- db qrystr run-id runname)
- res))))
- (if (null? runs)
- (begin
- (db:create-initial-run-record dbstruct run-id runname target)
- )
- )
- (let* ()
- ;;(debug:print 0 *default-log-port* "db:insert-run: Calling db:with-db to update the run record")
- (debug:print 0 *default-log-port* "db:insert-run: runid = " run-id)
-#; (db:with-db
- dbstruct
- #f #t
- (lambda (dbdat db)
- (debug:print 0 *default-log-port* "In the lambda proc for " dbdat " " db)
- (for-each
- (lambda (keyval)
- (debug:print 0 *default-log-port* "In the lambda proc for " keyval)
- (let* ((fieldname (car keyval))
- (getqry (conc "SELECT "fieldname" FROM runs WHERE id=?;"))
- (setqry (conc "UPDATE runs SET "fieldname"=? WHERE id=?;"))
- (val (cdr keyval))
- (valnum (if (number? val)
- val
- (if (string? val)
- (string->number val)
- #f))))
- (debug:print 0 *default-log-port* "fieldname " fieldname " val " val " valnum " valnum)
- (if (not (member fieldname (cons "runname" keys))) ;; don't attempt to tweak these
- (let* ((curr-val (get-var db getqry))
- (have-it (or (equal? curr-val val)
- (equal? curr-val valnum))))
- (debug:print 0 *default-log-port* "have-it = " have-it)
- (if (not have-it)
- (begin
- (debug:print 0 *default-log-port* "Do sqlite3:execute")
- ;; (sqlite3:execute db setqry (or valnum val) run-id)
- )
- )
- )
- )
- (debug:print 0 *default-log-port* "Done with update")
- )
- (debug:print 0 *default-log-port* "next keyval")
- )
- run-meta)))
- run-id))))
-
-(define (db:create-initial-run-record dbstruct run-id runname target)
- (let* ((keys (db:get-keys dbstruct))
- (targvals (string-split target "/"))
- (keystr (string-intersperse keys ","))
- (key?str (string-intersperse (make-list (length targvals) "?") ",")) ;; a string with the same length as targvals, where each element is "?" and interspersed with commas.
- (qrystr (conc "INSERT INTO runs (id,runname,"keystr") VALUES (?,?,"key?str")")))
- (debug:print 0 *default-log-port* "db:create-initial-run-record")
- (debug:print 0 *default-log-port* "qrystr = " qrystr)
-
- (db:with-db
- dbstruct #f #t ;; run-id writable
- (lambda (dbdat db)
- (debug:print 0 *default-log-port* "lambda proc: dbdat: " dbdat " db: " db)
- (apply sqlite3:execute db qrystr run-id runname targvals)))))
-
-(define (db:insert-test dbstruct run-id test-rec)
- (let* ((testname (alist-ref "testname" test-rec equal?))
- (item-path (alist-ref "item_path" test-rec equal?))
- (id (db:get-test-id dbstruct run-id testname item-path))
- (fieldvals (filter (lambda (x)(not (member (car x) '("id" "last_update")))) test-rec))
- (setqry (conc "UPDATE tests SET "(string-intersperse
- (map (lambda (dat)
- (conc (car dat)"=?"))
- fieldvals)
- ",")" WHERE id=?;"))
- (insqry (conc "INSERT INTO tests ("(string-intersperse (map (lambda (x) (car x)) fieldvals) ",")
- ") VALUES ("(string-intersperse (make-list (length fieldvals) "?") ",")");")))
- ;; (debug:print 0 *default-log-port* "id: "id"\nset: "setqry"\ninsqry: "insqry)
- (db:with-db
- dbstruct
- run-id #t
- (lambda (dbdat db)
- (if id
- (apply sqlite3:execute db setqry (append (map cdr fieldvals) (list id)))
- (apply sqlite3:execute db insqry (map cdr fieldvals)))))))
-
-;; replace header and keystr with a call to runs:get-std-run-fields
-;;
-;; keypatts: ( (KEY1 "abc%def")(KEY2 "%") )
-;; runpatts: patt1,patt2 ...
-;;
-(define (db:get-runs dbstruct runpatt count offset keypatts)
- (let* ((res '())
- (keys (db:get-keys dbstruct))
- (runpattstr (db:patt->like "runname" runpatt))
- (remfields (list "id" "runname" "state" "status" "owner" "event_time"))
- (header (append keys remfields))
- (keystr (conc (keys->keystr keys) ","
- (string-intersperse remfields ",")))
- (qrystr (conc "SELECT " keystr " FROM runs WHERE (" runpattstr ") " ;; runname LIKE ? "
- ;; Generate: " AND x LIKE 'keypatt' ..."
- (if (null? keypatts) ""
- (conc " AND "
- (string-join
- (map (lambda (keypatt)
- (let ((key (car keypatt))
- (patt (cadr keypatt)))
- (db:patt->like key patt)))
- keypatts)
- " AND ")))
- " AND state != 'deleted' ORDER BY event_time DESC "
- (if (number? count)
- (conc " LIMIT " count)
- "")
- (if (number? offset)
- (conc " OFFSET " offset)
- ""))))
- (debug:print-info 11 *default-log-port* "db:get-runs START qrystr: " qrystr " keypatts: " keypatts " offset: " offset " limit: " count)
- (db:with-db dbstruct #f #f
- (lambda (dbdat db)
- (sqlite3:for-each-row
- (lambda (a . x)
- (set! res (cons (apply vector a x) res)))
- db
- qrystr
- )))
- (debug:print-info 11 *default-log-port* "db:get-runs END qrystr: " qrystr " keypatts: " keypatts " offset: " offset " limit: " count)
- (vector header res)))
-
-;; simple get-runs
-;;
-;; records used defined in dbfile
-;;
-(define (db:simple-get-runs dbstruct runpatt count offset target last-update)
- (let* ((res '())
- (keys (db:get-keys dbstruct))
- (runpattstr (db:patt->like "runname" runpatt))
- (remfields (list "id" "runname" "state" "status" "owner" "event_time"))
- (targstr (string-intersperse keys "||'/'||"))
- (keystr (conc targstr " AS target,"
- (string-intersperse remfields ",")))
- (qrystr (conc "SELECT " keystr " FROM runs WHERE (" runpattstr ") " ;; runname LIKE ? "
- ;; Generate: " AND x LIKE 'keypatt' ..."
- " AND target LIKE '" target "'"
- " AND state != 'deleted' "
- (if (number? last-update)
- (conc " AND last_update >= " last-update)
- "")
- " ORDER BY event_time DESC "
- (if (number? count)
- (conc " LIMIT " count)
- "")
- (if (number? offset)
- (conc " OFFSET " offset)
- "")))
- )
- (debug:print-info 11 *default-log-port* "db:get-runs START qrystr: " qrystr " target: " target " offset: " offset " limit: " count)
- (db:with-db dbstruct #f #f
- (lambda (dbdat db)
- (sqlite3:for-each-row
- (lambda (target id runname state status owner event_time)
- (set! res (cons (make-simple-run target id runname state status owner event_time) res)))
- db
- qrystr
- )))
- (debug:print-info 11 *default-log-port* "db:get-runs END qrystr: " qrystr " target: " target " offset: " offset " limit: " count)
- res))
-
-;; TODO: Switch this to use max(update_time) from each run db? Then if using a server there is no disk traffic (using cachedb db) ???
-;;
-;; NOTE: This DOESN'T (necessarily) get the real run ids, but the number of the .db!!
-
-(define (db:get-changed-run-ids since-time)
- (let* ((dbdir (common:make-tmpdir-name *toppath* "")) ;; (configf:lookup *configdat* "setup" "dbdir"))
- (alldbs (glob (conc *toppath* "/.mtdb/[0-9]*.db*")))
- (changed (filter (lambda (dbfile)
- (> (file-modification-time dbfile) since-time))
- alldbs)))
- (delete-duplicates
- (map (lambda (dbfile)
- (let* ((res (string-match ".*\\/(\\d+)\\.db*" dbfile)))
- (if res
- (string->number (cadr res))
- (begin
- (debug:print 2 *default-log-port* "WARNING: Failed to process " dbfile " for run-id")
- 0))))
- changed))))
-
-;; Get all targets from the db
-;;
-(define (db:get-targets dbstruct)
- (let* ((res '())
- (keys (db:get-keys dbstruct))
- (header keys) ;; (map key:get-fieldname keys))
- (keystr (keys->keystr keys))
- (qrystr (conc "SELECT " keystr " FROM runs WHERE state != 'deleted';"))
- (seen (make-hash-table)))
- (db:with-db
- dbstruct
- #f
- #f
- (lambda (dbdat db)
- (sqlite3:for-each-row
- (lambda (a . x)
- (let ((targ (cons a x)))
- (if (not (hash-table-ref/default seen targ #f))
- (begin
- (hash-table-set! seen targ #t)
- (set! res (cons (apply vector targ) res))))))
- db
- qrystr)
- (debug:print-info 11 *default-log-port* "db:get-targets END qrystr: " qrystr )
- (vector header res)))))
-
-;; just get count of runs
-(define (db:get-num-runs dbstruct runpatt)
- (db:with-db
- dbstruct
- #f
- #f
- (lambda (dbdat db)
- (let ((numruns 0))
- (debug:print-info 11 *default-log-port* "db:get-num-runs START " runpatt)
- (sqlite3:for-each-row
- (lambda (count)
- (set! numruns count))
- db
- "SELECT COUNT(id) FROM runs WHERE runname LIKE ? AND state != 'deleted';" runpatt)
- (debug:print-info 11 *default-log-port* "db:get-num-runs END " runpatt)
- numruns))))
-
-;; just get count of runs
-(define (db:get-runs-cnt-by-patt dbstruct runpatt targetpatt keys)
- (db:with-db
- dbstruct
- #f
- #f
- (lambda (dbdat db)
- (let ((numruns 0)
- (qry-str #f)
- (key-patt "")
- (keyvals (if targetpatt (keys:target->keyval keys targetpatt) '())))
-
- (for-each (lambda (keyval)
- (let* ((key (car keyval))
- (patt (cadr keyval))
- (fulkey (conc ":" key))
- (wildtype (if (substring-index "%" patt) "like" "glob")))
-
- (if patt
- (set! key-patt (conc key-patt " AND " key " " wildtype " '" patt "'"))
- (begin
- (debug:print-error 0 *default-log-port* "searching for runs with no pattern set for " fulkey)
- (exit 6)))))
- keyvals)
- ;(print runpatt " -- " key-patt)
- (set! qry-str (conc "SELECT COUNT(id) FROM runs WHERE state != 'deleted' AND runname like '" runpatt "'" key-patt))
- ;(print qry-str )
-
- (sqlite3:for-each-row
- (lambda (count)
- (set! numruns count))
- db
- qry-str)
- (debug:print-info 11 *default-log-port* "db:get-num-runs END " runpatt)
- numruns))))
-
-
-;; (sqlite3#fold-row proc3670 init3671 db-or-stmt3672 . params3673)>
-;;
-(define (db:get-raw-run-stats dbstruct run-id)
- (db:with-db
- dbstruct
- run-id
- #f
- (lambda (dbdat db)
- (sqlite3:fold-row
- (lambda (res state status count)
- (cons (list state status count) res))
- '()
- db
- "SELECT state,status,count(id) AS count FROM tests WHERE run_id=? AND NOT(uname='n/a' AND item_path='') GROUP BY state,status;"
- run-id))))
-
-;; Update run_stats for given run_id
-;; input data is a list (state status count)
-;;
-(define (db:update-run-stats dbstruct run-id stats)
- (mutex-lock! *db-transaction-mutex*)
- (db:with-db
- dbstruct
- #f
- #t
- (lambda (dbdat db)
- ;; remove previous data
-
- (let* ((stmt1 (sqlite3:prepare db "DELETE FROM run_stats WHERE run_id=? AND state=? AND status=?;"))
- (stmt2 (sqlite3:prepare db "INSERT INTO run_stats (run_id,state,status,count) VALUES (?,?,?,?);"))
- (res
- (sqlite3:with-transaction
- db
- (lambda ()
- (for-each
- (lambda (dat)
- (sqlite3:execute stmt1 run-id (car dat)(cadr dat))
- (apply sqlite3:execute stmt2 run-id dat))
- stats)))))
- (sqlite3:finalize! stmt1)
- (sqlite3:finalize! stmt2)
- (mutex-unlock! *db-transaction-mutex*)
- res))))
-
-(define (db:get-main-run-stats dbstruct run-id)
- (db:with-db
- dbstruct
- #f ;; this data comes from main
- #f
- (lambda (dbdat db)
- (sqlite3:fold-row
- (lambda (res state status count)
- (cons (list state status count) res))
- '()
- db
- "SELECT state,status,count FROM run_stats WHERE run_id=? AND run_id IN (SELECT id FROM runs WHERE state NOT IN ('DELETED','deleted'));"
- run-id))))
-
-(define (db:print-current-query-stats)
- ;; generate stats from *db-api-call-time*
- (let ((ordered-keys (sort (hash-table-keys *db-api-call-time*)
- (lambda (a b)
- (let ((sum-a (common:sum (hash-table-ref *db-api-call-time* a)))
- (sum-b (common:sum (hash-table-ref *db-api-call-time* b))))
- (> sum-a sum-b)))))
- (total 0))
- (for-each
- (lambda (cmd-key)
- (let* ((dat (hash-table-ref *db-api-call-time* cmd-key))
- (num (length dat))
- (avg (if (> num 0)
- (/ (common:sum dat)(length dat)))))
- (set! total (+ total num))
- (debug:print-info 0 *default-log-port* cmd-key "\tavg: " avg " max: " (common:max dat) " min: " (common:min-max < dat) " num: " (length dat))))
- ordered-keys)
- (debug:print-info 0 *default-log-port* "TOTAL: " total " api calls since start.")))
-
-(define (db:get-all-run-ids dbstruct)
- (db:with-db
- dbstruct
- #f
- #f
- (lambda (dbdat db)
- (let ((run-ids '()))
- (sqlite3:for-each-row
- (lambda (run-id)
- (set! run-ids (cons run-id run-ids)))
- db
- "SELECT id FROM runs WHERE state != 'deleted' ORDER BY event_time DESC;")
- (reverse run-ids)))))
-
-;; get some basic run stats
-;;
-;; data structure:
-;;
-;; ( (runname (( state count ) ... ))
-;; ( ...
-;;
-(define (db:get-run-stats dbstruct)
- (let* ((totals (make-hash-table))
- (curr (make-hash-table))
- (res '())
- (runs-info '()))
- ;; First get all the runname/run-ids
- (db:with-db
- dbstruct #f #f
- (lambda (dbdat db)
- (sqlite3:for-each-row
- (lambda (run-id runname)
- (set! runs-info (cons (list run-id runname) runs-info)))
- db
- "SELECT id,runname FROM runs WHERE state != 'deleted' ORDER BY event_time DESC;"))) ;; If you change this to the more logical ASC please adjust calls to db:get-run-stats
- ;; for each run get stats data
- (for-each
- (lambda (run-info)
- ;; get the net state/status counts for this run
- (let* ((run-id (car run-info))
- (run-name (cadr run-info)))
- (db:with-db
- dbstruct
- run-id
- #f
- (lambda (dbdat db)
- (sqlite3:for-each-row
- (lambda (state status count)
- (let ((netstate (if (equal? state "COMPLETED") status state)))
- (if (string? netstate)
- (begin
- (hash-table-set! totals netstate (+ (hash-table-ref/default totals netstate 0) count))
- (hash-table-set! curr netstate (+ (hash-table-ref/default curr netstate 0) count))))))
- db
- "SELECT state,status,count(id) FROM tests AS t WHERE run_id=? GROUP BY state,status ORDER BY state,status DESC;"
- run-id)
- ;; add the per run counts to res
- (for-each (lambda (state)
- (set! res (cons (list run-name state (hash-table-ref curr state)) res)))
- (sort (hash-table-keys curr) string>=))
- (set! curr (make-hash-table))))))
- runs-info)
- (for-each (lambda (state)
- (set! res (cons (list "Totals" state (hash-table-ref totals state)) res)))
- (sort (hash-table-keys totals) string>=))
- res))
-
-;; db:get-runs-by-patt
-;; get runs by list of criteria
-;; register a test run with the db
-;;
-;; Use: (db:get-value-by-header (db:get-header runinfo)(db:get-rows runinfo))
-;; to extract info from the structure returned
-;;
-(define (db:get-runs-by-patt dbstruct keys runnamepatt targpatt offset limit fields last-update sort-order ) ;; test-name)
- (let* ((tmp (runs:get-std-run-fields keys (or fields '("id" "runname" "state" "status" "owner" "event_time"))))
- (keystr (car tmp))
- (header (cadr tmp))
- (key-patt "")
- (runwildtype (if (substring-index "%" runnamepatt) "like" "glob"))
- (qry-str #f)
- (keyvals (if targpatt (keys:target->keyval keys targpatt) '())))
- (for-each (lambda (keyval)
- (let* ((key (car keyval))
- (patt (cadr keyval))
- (fulkey (conc ":" key))
- (wildtype (if (substring-index "%" patt) "like" "glob")))
- (if patt
- (set! key-patt (conc key-patt " AND " key " " wildtype " '" patt "'"))
- (begin
- (debug:print-error 0 *default-log-port* "searching for runs with no pattern set for " fulkey)
- (exit 6)))))
- keyvals)
- (set! qry-str (conc "SELECT " keystr " FROM runs WHERE state != 'deleted' AND runname " runwildtype " ? " key-patt
- (if last-update
- (conc " AND last_update >= " last-update " ")
- " ")
- " ORDER BY event_time " sort-order " "
- (if limit (conc " LIMIT " limit) "")
- (if offset (conc " OFFSET " offset) "")
- ";"))
- (debug:print-info 4 *default-log-port* "runs:get-runs-by-patt qry=" qry-str " " runnamepatt)
- ;(print "runs:get-runs-by-patt qry=" qry-str " " runnamepatt)
-
- (vector header
- (reverse
- (db:with-db
- dbstruct #f #f ;; reads db, does not write to it.
- (lambda (dbdat db)
- (sqlite3:fold-row
- (lambda (res . r)
- (cons (list->vector r) res))
- '()
- db
- qry-str
- runnamepatt)))))))
-
-;; use (get-value-by-header (db:get-header runinfo)(db:get-rows runinfo))
-;; NOTE: Does NOT return a list of rows (or one row) for the first slot of the vector
-;; this is inconsistent with get-runs but it makes some sense.
-;;
-(define (db:get-run-info dbstruct run-id)
- ;;(if (hash-table-ref/default *run-info-cache* run-id #f)
- ;; (hash-table-ref *run-info-cache* run-id)
- (let* ((res (vector #f #f #f #f))
- (keys (db:get-keys dbstruct))
- (remfields (list "id" "runname" "state" "status" "owner" "event_time" "comment" "fail_count" "pass_count" "contour" "last_update")) ;; "area_id"))
- (header (append keys remfields))
- (keystr (conc (keys->keystr keys) ","
- (string-intersperse remfields ","))))
- (debug:print-info 11 *default-log-port* "db:get-run-info run-id: " run-id " header: " header " keystr: " keystr)
-
- (db:with-db
- dbstruct #f #f
- (lambda (dbdat db)
- (sqlite3:for-each-row
- (lambda (a . x)
- (set! res (apply vector a x)))
- db
- (conc "SELECT " keystr " FROM runs WHERE id=?;")
- run-id)))
- (debug:print-info 11 *default-log-port* "db:get-run-info run-id: " run-id " header: " header " keystr: " keystr)
- (let ((finalres (vector header res)))
- ;; (hash-table-set! *run-info-cache* run-id finalres)
- finalres)))
-
-(define (db:set-comment-for-run dbstruct run-id comment)
- (db:with-db
- dbstruct #f #f
- (lambda (dbdat db)
- (sqlite3:execute db "UPDATE runs SET comment=? WHERE id=?;" comment ;; (sdb:qry 'getid comment)
- run-id))))
-
-;; does not (obviously!) removed dependent data. But why not!!?
-(define (db:delete-run dbstruct run-id)
- (db:with-db
- dbstruct #f #t
- (lambda (dbdat db)
- (sqlite3:with-transaction
- db
- (lambda ()
- (sqlite3:execute db "DELETE FROM test_steps WHERE test_id IN (SELECT id FROM tests WHERE run_id=?);" run-id)
- (sqlite3:execute db "DELETE FROM test_data WHERE test_id IN (SELECT id FROM tests WHERE run_id=?);" run-id)
- (sqlite3:execute db "UPDATE tests SET state='DELETED',comment='' WHERE run_id=?;" run-id)
- ;; (db:delay-if-busy dbdat)
- (sqlite3:execute db "UPDATE runs SET state='deleted',comment='' WHERE id=?;" run-id))))))
-
-(define (db:update-run-event_time dbstruct run-id)
- (db:with-db
- dbstruct #f #t
- (lambda (dbdat db)
- (sqlite3:execute db "UPDATE runs SET event_time=strftime('%s','now') WHERE id=?;" run-id))))
-
-(define (db:lock/unlock-run dbstruct run-id lock unlock user)
- (db:with-db
- dbstruct #f #t
- (lambda (dbdat db)
- (let ((newlockval (if lock "locked"
- (if unlock
- "unlocked"
- "locked")))) ;; semi-failsafe
- (sqlite3:execute db "UPDATE runs SET state=? WHERE id=?;" newlockval run-id)
- (sqlite3:execute db "INSERT INTO access_log (user,accessed,args) VALUES(?,strftime('%s','now'),?);"
- user (conc newlockval " " run-id))
- (debug:print-info 1 *default-log-port* "" newlockval " run number " run-id)))))
-
-(define (db:set-run-status dbstruct run-id status msg)
- (db:with-db
- dbstruct #f #t
- (lambda (dbdat db)
- (if msg
- (sqlite3:execute db "UPDATE runs SET status=?,comment=? WHERE id=?;" status msg run-id)
- (sqlite3:execute db "UPDATE runs SET status=? WHERE id=?;" status run-id)))))
-
-(define (db:set-run-state-status-db dbdat db run-id state status )
- (sqlite3:execute
- (db:get-cache-stmth
- dbdat db "UPDATE runs SET status=?,state=? WHERE id=?;") status state run-id))
-
-(define (db:set-run-state-status dbstruct run-id state status )
- (db:with-db
- dbstruct #f #t
- (lambda (dbdat db)
- (db:set-run-state-status-db dbdat db run-id state status))))
-
-(define (db:get-run-status dbstruct run-id)
- (let ((res "n/a"))
- (db:with-db
- dbstruct #f #f
- (lambda (dbdat db)
- (sqlite3:for-each-row
- (lambda (status)
- (set! res status))
- (db:get-cache-stmth
- dbdat db
- "SELECT status FROM runs WHERE id=?;" )
- run-id)
- res))))
-
-(define (db:get-run-state dbstruct run-id)
- (let ((res "n/a"))
- (db:with-db
- dbstruct #f #f
- (lambda (dbdat db)
- (sqlite3:for-each-row
- (lambda (status)
- (set! res status))
- (db:get-cache-stmth
- dbdat db
- "SELECT state FROM runs WHERE id=?;" )
- run-id)
- res))))
-
-(define (db:get-run-state-status dbstruct run-id)
- (let ((res (cons "n/a" "n/a")))
- (db:with-db
- dbstruct #f #f
- (lambda (dbdat db)
- (sqlite3:for-each-row
- (lambda (state status)
- (set! res (cons state status)))
- (db:get-cache-stmth
- dbdat db
- "SELECT state,status FROM runs WHERE id=?;" )
- run-id)
- res))))
-
-
-;;======================================================================
-;; K E Y S
-;;======================================================================
-
-;; get key val pairs for a given run-id
-;; ( (FIELDNAME1 keyval1) (FIELDNAME2 keyval2) ... )
-(define (db:get-key-val-pairs dbstruct run-id)
- (let* ((keys (db:get-keys dbstruct))
- (res '()))
- (db:with-db
- dbstruct #f #f
- (lambda (dbdat db)
- (for-each
- (lambda (key)
- (let ((qry (conc "SELECT " key " FROM runs WHERE id=?;")))
- (sqlite3:for-each-row
- (lambda (key-val)
- (set! res (cons (list key (if (string? key-val) key-val "")) res))) ;; replace non-string bad values with empty string to prevent crashes. This scenario can happen when Megatest is killed on updating the db
- db qry run-id)))
- keys)))
- (reverse res)))
-
-;; get key vals for a given run-id
-(define (db:get-key-vals dbstruct run-id)
- (let* ((keys (db:get-keys dbstruct))
- (res '()))
- (db:with-db
- dbstruct #f #f
- (lambda (dbdat db)
- (for-each
- (lambda (key)
- (let ((qry (conc "SELECT " key " FROM runs WHERE id=?;")))
- ;; (db:delay-if-busy dbdat)
- (sqlite3:for-each-row
- (lambda (key-val)
- (set! res (cons (if (string? key-val) key-val "") res))) ;; check that the key-val is a string for cases where a crash injected bad data in the megatest.db
- db qry run-id)))
- keys)))
- (let ((final-res (reverse res)))
- (hash-table-set! *keyvals* run-id final-res)
- final-res)))
-
-;; The target is keyval1/keyval2..., cached in *target* as it is used often
-(define (db:get-target dbstruct run-id)
- (let* ((keyvals (db:get-key-vals dbstruct run-id))
- (thekey (string-intersperse (map (lambda (x)(if x x "-na-")) keyvals) "/")))
- thekey))
-
-;; Get run-ids for runs with same target but different runnames and NOT run-id
-;;
-(define (db:get-prev-run-ids dbstruct run-id)
- (let* ((keyvals (db:get-key-val-pairs dbstruct run-id))
- (kvalues (map cadr keyvals))
- (keys (db:get-keys dbstruct))
- (qrystr (string-intersperse (map (lambda (x)(conc x "=?")) keys) " AND ")))
- (let ((prev-run-ids '()))
- (if (null? keyvals)
- '()
- (begin
- (db:with-db dbstruct #f #f ;; #f means work with the zeroth db - i.e. the runs db
- (lambda (dbdat db)
- (apply sqlite3:for-each-row
- (lambda (id)
- (set! prev-run-ids (cons id prev-run-ids)))
- db
- (conc "SELECT id FROM runs WHERE " qrystr " AND state != 'deleted' AND id != ?;")
- (append kvalues (list run-id)))))
- prev-run-ids)))))
-
-;;======================================================================
-;; T E S T S
-;;======================================================================
-
-;; states and statuses are lists, turn them into ("PASS","FAIL"...) and use NOT IN
-;; i.e. these lists define what to NOT show.
-;; states and statuses are required to be lists, empty is ok
-;; not-in #t = above behaviour, #f = must match
-;; mode:
-;; 'dashboard - use state = 'COMPLETED' AND status in ( statuses ) OR state in ( states )
-;;
-(define (db:get-tests-for-run dbstruct run-id testpatt states statuses offset limit not-in sort-by sort-order qryvals last-update mode)
- (let* ((qryvalstr (case qryvals
- ((shortlist) "id,run_id,testname,item_path,state,status")
- ((#f) db:test-record-qry-selector) ;; "id,run_id,testname,state,status,event_time,host,cpuload,diskfree,uname,rundir,item_path,run_duration,final_logf,comment")
- (else qryvals)))
- (res '())
- ;; if states or statuses are null then assume match all when not-in is false
- (states-qry (if (null? states)
- #f
- (conc " state "
- (if (eq? mode 'dashboard)
- " IN ('"
- (if not-in
- " NOT IN ('"
- " IN ('"))
- (string-intersperse states "','")
- "')")))
- (statuses-qry (if (null? statuses)
- #f
- (conc " status "
- (if (eq? mode 'dashboard)
- " IN ('"
- (if not-in
- " NOT IN ('"
- " IN ('") )
- (string-intersperse statuses "','")
- "')")))
- (interim-qry (conc " AND " (if not-in "NOT " "") "( state='COMPLETED' " (if statuses-qry (conc " AND " statuses-qry " ) ") " ) ")
- (if states-qry
- (conc (if not-in " AND " " OR ") states-qry ) ;; " ) ")
- "")))
- (states-statuses-qry
- (cond
- ((and states-qry statuses-qry)
- (case mode
- ((dashboard)
- (if not-in
- (conc " AND (state='COMPLETED' AND status NOT IN ('" (string-intersperse statuses "','") "')) "
- " OR (state != 'COMPLETED' AND state NOT IN ('" (string-intersperse states "','") "')) ")
- (conc " AND (state='COMPLETED' AND status IN ('" (string-intersperse statuses "','") "')) "
- " OR (state NOT IN ('COMPLETED','DELETED') AND state IN ('" (string-intersperse states "','") "')) ")))
- (else (conc " AND ( " states-qry " AND " statuses-qry " ) "))))
- (states-qry
- (case mode
- ((dashboard) (conc " AND " (if not-in "NOT " "") " state IN ('" (string-intersperse states "','") "') ")) ;; interim-qry)
- (else (conc " AND " states-qry))))
- (statuses-qry
- (case mode
- ((dashboard) (conc " AND " (if not-in "NOT " "") " status IN ('" (string-intersperse statuses "','") "') ")) ;; interim-qry)
- (else (conc " AND " statuses-qry))))
- (else "")))
- (tests-match-qry (tests:match->sqlqry testpatt))
- (qry (conc "SELECT " qryvalstr
- (if run-id
- " FROM tests WHERE run_id=? "
- " FROM tests WHERE ? > 0 ") ;; should work?
- (if last-update " " " AND state != 'DELETED' ") ;; if using last-update we want deleted tests?
- states-statuses-qry
- (if tests-match-qry (conc " AND (" tests-match-qry ") ") "")
- (if last-update (conc " AND last_update >= " last-update " ") "")
- (case sort-by
- ((rundir) " ORDER BY length(rundir) ")
- ((testname) (conc " ORDER BY testname " (if sort-order (conc sort-order ",") "") " item_path "))
- ((statestatus) (conc " ORDER BY state " (if sort-order (conc sort-order ",") "") " status "))
- ((event_time) " ORDER BY event_time ")
- (else (if (string? sort-by)
- (conc " ORDER BY " sort-by " ")
- " ")))
- (if sort-order sort-order " ")
- (if limit (conc " LIMIT " limit) " ")
- (if offset (conc " OFFSET " offset) " ")
- ";"
- )))
- (debug:print-info 8 *default-log-port* "db:get-tests-for-run run-id=" run-id ", qry=" qry)
- (let* ((res (db:with-db dbstruct run-id #f
- (lambda (dbdat db)
- ;; (let* ((stmth (db:get-cache-stmth dbstruct db qry))) ;; due to use of last-update we can't efficiently cache this query
- (reverse
- (sqlite3:fold-row
- (lambda (res . row)
- ;; id run-id testname state status event-time host cpuload
- ;; diskfree uname rundir item-path run-duration final-logf comment)
- (cons (list->vector row) res))
- '()
- db qry ;; stmth
- (or run-id 1) ;; 1 > 0 , for the case where we are seeking tests matching criteral for all runs
- ))))))
- (case qryvals
- ((shortlist)(map db:test-short-record->norm res))
- ((#f) res)
- (else res)))))
-
-(define (db:test-short-record->norm inrec)
- ;; "id,run_id,testname,item_path,state,status"
- ;; "id,run_id,testname,state,status,event_time,host,cpuload,diskfree,uname,rundir,item_path,run_duration,final_logf,comment
- (vector (vector-ref inrec 0) ;; id
- (vector-ref inrec 1) ;; run_id
- (vector-ref inrec 2) ;; testname
- (vector-ref inrec 4) ;; state
- (vector-ref inrec 5) ;; status
- -1 "" -1 -1 "" "-"
- (vector-ref inrec 3) ;; item-path
- -1 "-" "-"))
-
-;;
-;; 1. cache tests-match-qry
-;; 2. compile qry and store in hash
-;; 3. convert for-each-row to fold
-;;
-;; (define (db:get-tests-for-run-state-status dbstruct run-id testpatt)
-;; (db:with-db
-;; dbstruct run-id #f
-;; (lambda (dbdat db)
-;; (let* ((res '())
-;; (stmt-cache (dbr:dbstruct-stmt-cache dbstruct))
-;; (stmth (let* ((sh (db:hoh-get stmt-cache db testpatt)))
-;; (or sh
-;; (let* ((tests-match-qry (tests:match->sqlqry testpatt))
-;; (qry (conc "SELECT id,testname,item_path,state,status FROM tests WHERE run_id=? "
-;; (if tests-match-qry (conc " AND (" tests-match-qry ") ") "")))
-;; (newsh (sqlite3:prepare db qry)))
-;; (debug:print-info 8 *default-log-port* "db:get-tests-for-run qry=" qry)
-;; (db:hoh-set! stmt-cache db testpatt newsh)
-;; newsh)))))
-;; (reverse
-;; (sqlite3:fold-row
-;; (lambda (res id testname item-path state status)
-;; ;; id,run_id,testname,state,status,event_time,host,cpuload,diskfree,uname,rundir,item_path,run_duration,final_logf,comment
-;; (cons (vector id run-id testname state status -1 "" -1 -1 "" "-" item-path -1 "-" "-") res))
-;; '()
-;; stmth
-;; run-id))))))
-
-(define (db:get-tests-for-run-state-status dbstruct run-id testpatt #!optional (last-update 0))
- (let* ((res '())
- (tests-match-qry (tests:match->sqlqry testpatt))
- (qry (conc "SELECT id,testname,item_path,state,status,event_time,run_duration FROM tests WHERE run_id=? "
- " AND last_update > ? "
- (if tests-match-qry (conc " AND (" tests-match-qry ") ") "")
- )))
- (debug:print-info 8 *default-log-port* "db:get-tests-for-run qry=" qry)
- (db:with-db dbstruct run-id #f
- (lambda (dbdat db)
- (sqlite3:fold-row
- (lambda (res id testname item-path state status event-time run-duration)
- ;; id,run_id,testname,state,status,event_time,host,cpuload,diskfree,uname,rundir,item_path,run_duration,final_logf,comment
- (cons (vector id run-id testname state status event-time "" -1 -1 "" "-" item-path run-duration "-" "-") res))
- '()
- db
- qry
- run-id
- (or last-update 0))))))
-
-(define (db:get-testinfo-state-status dbstruct run-id test-id)
- (db:with-db
- dbstruct run-id #f
- (lambda (dbdat db)
- (let* ((res #f)
- (stmth (db:get-cache-stmth dbdat db "SELECT run_id,testname,item_path,state,status FROM tests WHERE id=? and run_id=?;")))
- (sqlite3:for-each-row
- (lambda (run-id testname item-path state status)
- ;; id,run_id,testname,state,status,event_time,host,cpuload,diskfree,uname,rundir,item_path,run_duration,final_logf,comment
- (set! res (vector test-id run-id testname state status -1 "" -1 -1 "" "-" item-path -1 "-" "-")))
- ;; db
- ;; "SELECT run_id,testname,item_path,state,status FROM tests WHERE id=? and run_id=?;"
- stmth
- test-id run-id)
- res))))
-
-;; get a useful subset of the tests data (used in dashboard
-;; use db:mintest-get-{id ,run_id,testname ...}
-;;
-(define (db:get-tests-for-run-mindata dbstruct run-id testpatt states statuses not-in)
- (db:get-tests-for-run dbstruct run-id testpatt states statuses #f #f not-in #f #f "id,run_id,testname,state,status,event_time,item_path" 0 #f))
-
-;; do not use.
-;;
-(define (db:get-tests-for-runs dbstruct run-ids testpatt states statuses #!key (not-in #f)(qryvals #f))
- ;; (db:delay-if-busy)
- (let ((res '()))
- (for-each
- (lambda (run-id)
- (set! res (append
- res
- (db:get-tests-for-run dbstruct run-id testpatt states statuses #f #f not-in #f #f qryvals #f 'normal))))
- (if run-ids
- run-ids
- (db:get-all-run-ids dbstruct)))
- res))
-
-;; Convert calling routines to get list of run-ids and loop, do not use the get-tests-for-runs
-;;
-
-(define (db:delete-test-records dbstruct run-id test-id)
- (db:general-call dbstruct run-id 'delete-test-step-records (list test-id))
- (db:general-call dbstruct run-id 'delete-test-data-records (list test-id))
- (db:with-db
- dbstruct run-id #t
- (lambda (dbdat db)
- (sqlite3:execute db "UPDATE tests SET state='DELETED',status='n/a',comment='' WHERE id=?;" test-id))))
-
-;;
-(define (db:delete-old-deleted-test-records dbstruct run-id)
- (let* ((targtime (- (current-seconds)
- (or (configf:lookup-number *configdat* "setup" "keep-deleted-records")
- (* 7 24 60 60)))) ;; cleanup if over one week old
- (mtdbfile (dbmod:run-id->full-dbfname dbstruct run-id))
- (qry1 "DELETE FROM test_steps WHERE test_id IN (SELECT id FROM tests WHERE state='DELETED' AND event_timenumber fieldname fields)
- (if (null? fields)
- #f
- (let loop ((hed (car fields))
- (tal (cdr fields))
- (indx 0))
- (if (equal? fieldname hed)
- indx
- (if (null? tal)
- #f
- (loop (car tal)(cdr tal)(+ indx 1)))))))
-
-(define db:test-record-qry-selector (string-intersperse db:test-record-fields ","))
-
-(define (db:update-tesdata-on-repilcate-db dbstruct old-lt new-lt)
- (db:with-db
- dbstruct #f #t
- (lambda (dbdat db)
- (sqlite3:execute db "UPDATE tests SET rundir= replace(rundir,?,?), shortdir=replace(shortdir,?,?);"
- old-lt new-lt old-lt new-lt))))
-
-;; NOTE: Use db:test-get* to access records
-;; NOTE: This needs rundir decoding? Decide, decode here or where used? For the moment decode where used.
-(define (db:get-all-tests-info-by-run-id dbstruct run-id)
- (let* ((res '()))
- (db:with-db
- dbstruct #f #f
- (lambda (dbdat db)
- (sqlite3:for-each-row
- (lambda (id run-id testname state status event-time host cpuload diskfree uname rundir item-path run-duration final-logf comment shortdir attemptnum archived)
- ;; 0 1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16
- (set! res (cons (vector id run-id testname state status event-time host cpuload diskfree uname rundir item-path run-duration final-logf comment shortdir attemptnum archived)
- res)))
- db
- (conc "SELECT " db:test-record-qry-selector " FROM tests WHERE state != 'DELETED' AND run_id=?;")
- run-id)))
- res))
-
-(define (db:replace-test-records dbstruct run-id testrecs)
- (db:with-db dbstruct run-id #t
- (lambda (dbdat db)
- (let* ((qmarks (string-intersperse (make-list (length db:test-record-fields) "?") ","))
- (qrystr (conc "INSERT OR REPLACE INTO tests (" db:test-record-qry-selector ") VALUES (" qmarks ") WHERE run_id=?;"))
- (qry (sqlite3:prepare db qrystr)))
- (debug:print 0 *default-log-port* "INFO: migrating test records for run with id " run-id)
- (sqlite3:with-transaction
- db
- (lambda ()
- (for-each
- (lambda (rec)
- ;; (debug:print 0 *default-log-port* "INFO: Inserting values: " (string-intersperse (map conc (vector->list rec)) ",") "\n")
- (apply sqlite3:execute qry (append (vector->list rec)(list run-id))))
- testrecs)))
- (sqlite3:finalize! qry)))))
-
-;; map a test-id into the proper range
-;;
-(define (db:adj-test-id mtdb min-test-id test-id)
- (if (>= test-id min-test-id)
- test-id
- (let loop ((new-id min-test-id))
- (let ((test-id-found #f))
- (sqlite3:for-each-row
- (lambda (id)
- (set! test-id-found id))
- (dbr:dbdat-dbh mtdb)
- "SELECT id FROM tests WHERE id=?;"
- new-id)
- ;; if test-id-found then need to try again
- (if test-id-found
- (loop (+ new-id 1))
- (begin
- (debug:print-info 0 *default-log-port* "New test id " new-id " selected for test with id " test-id)
- (sqlite3:execute mtdb "UPDATE tests SET id=? WHERE id=?;" new-id test-id)))))))
-
-;; move test ids into the 30k * run_id range
-;;
-(define (db:prep-megatest.db-adj-test-ids mtdb run-id testrecs)
- (debug:print-info 0 *default-log-port* "Adjusting test ids in megatest.db for run " run-id)
- (let ((min-test-id (* run-id 30000)))
- (for-each
- (lambda (testrec)
- (let* ((test-id (vector-ref testrec (db:field->number "id" db:test-record-fields))))
- (db:adj-test-id (dbr:dbdat-dbh mtdb) min-test-id test-id)))
- testrecs)))
-
-;; 1. move test ids into the 30k * run_id range
-;; 2. move step ids into the 30k * run_id range
-;;
-(define (db:prep-megatest.db-for-migration mtdb)
- (let* ((run-ids (db:get-all-run-ids mtdb)))
- (for-each
- (lambda (run-id)
- (let ((testrecs (db:get-all-tests-info-by-run-id mtdb run-id)))
- (db:prep-megatest.db-adj-test-ids (dbr:dbdat-dbh mtdb) run-id testrecs)))
- run-ids)))
-
-;; Get test data using test_id
-;;
-(define (db:get-test-info-by-id dbstruct run-id test-id)
- (db:with-db
- dbstruct
- run-id
- #f
- (lambda (dbdat db)
- (let ((res #f))
- (sqlite3:for-each-row ;; attemptnum added to hold pid of top process (not Megatest) controlling a test
- (lambda (id run-id testname state status event-time host cpuload diskfree uname rundir-id item-path run_duration final-logf-id comment short-dir-id attemptnum archived last-update)
- ;; 0 1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16
- (set! res (vector id run-id testname state status event-time host cpuload diskfree uname rundir-id item-path run_duration final-logf-id comment short-dir-id attemptnum archived last-update)))
- db
- ;; (db:get-cache-stmth dbdat db
- ;; (conc "SELECT " db:test-record-qry-selector " FROM tests WHERE id=? AND run_id=?;"))
- (conc "SELECT " db:test-record-qry-selector " FROM tests WHERE id=? AND run_id=?;")
- test-id run-id)
- res))))
-
-;; Get test state, status using test_id
-;;
-(define (db:get-test-state-status-by-id dbstruct run-id test-id)
- (db:with-db
- dbstruct
- run-id
- #f
- (lambda (dbdat db)
- (let ((res (cons #f #f))
- (stmth (db:get-cache-stmth dbdat db "SELECT state,status FROM tests WHERE id=? AND run_id=?;")))
- (sqlite3:for-each-row ;; attemptnum added to hold pid of top process (not Megatest) controlling a test
- (lambda (state status)
- (cons state status))
- ;; db
- stmth ;;"SELECT state,status FROM tests WHERE id=? AND run_id=?;" ;; stmth try not compiling this one - yes, this fixed the bind issue
- test-id run-id)
- res))))
-
-;; Use db:test-get* to access
-;; Get test data using test_ids. NB// Only works within a single run!!
-;;
-(define (db:get-test-info-by-ids dbstruct run-id test-ids)
- (db:with-db
- dbstruct
- run-id
- #f
- (lambda (dbdat db)
- (let ((res '()))
- (sqlite3:for-each-row
- (lambda (a . b)
- ;; 0 1 2 3 4 5 6 7 8 9 10 11 12 13 14
- (set! res (cons (apply vector a b) res)))
- db
- (conc "SELECT " db:test-record-qry-selector " FROM tests WHERE id in ("
- (string-intersperse (map conc test-ids) ",") ");"))
- res))))
-
-;; try every second until tries times proc
-;;
-(define (db:keep-trying-until-true proc params tries)
- (let* ((res (apply proc params)))
- (if res
- res
- (if (> tries 0)
- (begin
- (thread-sleep! 1)
- (db:keep-trying-until-true proc params (- tries 1)))
- (begin
- ;; (debug:print-info 0 *default-log-port* "proc never returned true, params="params)
- (print"db:keep-trying-until-true proc never returned true, proc = " proc " params =" params " tries = " tries)
- #f)))))
-
-(define (db:get-test-info dbstruct run-id test-name item-path)
- (db:with-db
- dbstruct
- run-id
- #f
- (lambda (dbdat db)
- (db:get-test-info-db db run-id test-name item-path))))
-
-(define (db:get-test-info-db db run-id test-name item-path)
- (let ((res #f))
- (sqlite3:for-each-row
- (lambda (a . b)
- (set! res (apply vector a b)))
- db
- (conc "SELECT " db:test-record-qry-selector " FROM tests WHERE testname=? AND item_path=? AND run_id=?;")
- test-name item-path run-id)
- res))
-
-(define (db:test-get-rundir-from-test-id dbstruct run-id test-id)
- (db:with-db
- dbstruct
- run-id
- #f
- (lambda (dbdat db)
- (db:first-result-default
- db
- "SELECT rundir FROM tests WHERE id=? AND run_id=?;"
- #f ;; default result
- test-id run-id))))
-
-(define (db:get-test-times dbstruct run-name target)
- (let ((res `())
- (qry (conc "select testname, item_path, run_duration, "
- (string-join (db:get-keys dbstruct) " || '/' || ")
- " as target from tests inner join runs on tests.run_id = runs.id where runs.runname = ? and target = ? ;")))
- (db:with-db
- dbstruct
- #f ;; this is for the main runs db
- #f ;; does not modify db
- (lambda (dbdat db)
- (sqlite3:for-each-row
- (lambda (test-name item-path test-time target )
- (set! res (cons (vector test-name item-path test-time) res)))
- db
- qry
- run-name target)
- res))))
-
-;;======================================================================
-;; S T E P S
-;;======================================================================
-
-(define (db:teststep-set-status! dbstruct run-id test-id teststep-name state-in status-in comment logfile)
- (db:with-db
- dbstruct
- run-id
- #t
- (lambda (dbdat db)
- (sqlite3:execute
- db
- "INSERT OR REPLACE into test_steps (test_id,stepname,state,status,event_time,comment,logfile) VALUES(?,?,?,?,?,?,?);"
- test-id teststep-name state-in status-in (current-seconds)
- (if comment comment "")
- (if logfile logfile "")))))
-
-
-
-(define (db:delete-steps-for-test! dbstruct run-id test-id)
- ;; TODO: figure out why status is the key field rather than state (note: CONSTRAINT test_steps_constraint UNIQUE (test_id,stepname,state) )
- (db:with-db
- dbstruct
- run-id
- #t
- (lambda (dbdat db)
- (sqlite3:execute
- db
- "UPDATE test_steps set status='DELETED' where test_id=?" ;; and run_id=? !! - run_id not in table (bummer) TODO: get run_id into schema for test_steps
- test-id))))
-
-
-;; db-get-test-steps-for-run
-(define (db:get-steps-for-test dbstruct run-id test-id)
- (db:with-db
- dbstruct
- run-id
- #f
- (lambda (dbdat db)
- (let* ((res '()))
- (sqlite3:for-each-row
- (lambda (id test-id stepname state status event-time logfile comment)
- (set! res (cons (vector id test-id stepname state status event-time (if (string? logfile) logfile "") comment) res)))
- db
- "SELECT id,test_id,stepname,state,status,event_time,logfile,comment FROM test_steps WHERE status != 'DELETED' AND test_id=? ORDER BY id ASC;" ;; event_time DESC,id ASC;
- test-id)
- (reverse res)))))
-
- (define (db:get-steps-info-by-id dbstruct run-id test-step-id)
- (db:with-db
- dbstruct
- run-id
- #f
- (lambda (dbdat db)
- (let* ((res (vector #f #f #f #f #f #f #f #f #f)))
- (sqlite3:for-each-row
- (lambda (id test-id stepname state status event-time logfile comment last-update)
- (set! res (vector id test-id stepname state status event-time (if (string? logfile) logfile "") comment last-update)))
- db
- "SELECT id,test_id,stepname,state,status,event_time,logfile,comment,last_update FROM test_steps WHERE id=? ORDER BY id ASC;" ;; event_time DESC,id ASC;
- test-step-id)
- res))))
-
-(define (db:get-steps-data dbstruct run-id test-id)
- (db:with-db
- dbstruct
- run-id
- #f
- (lambda (dbdat db)
- (let ((res '()))
- (sqlite3:for-each-row
- (lambda (id test-id stepname state status event-time logfile)
- (set! res (cons (vector id test-id stepname state status event-time (if (string? logfile) logfile "")) res)))
- db
- "SELECT id,test_id,stepname,state,status,event_time,logfile FROM test_steps WHERE status != 'DELETED' AND test_id=? ORDER BY id ASC;" ;; event_time DESC,id ASC;
- test-id)
- (reverse res)))))
-
-;;======================================================================
-;; T E S T D A T A
-;;======================================================================
-
-(define (db:get-data-info-by-id dbstruct run-id test-data-id)
- (let* ((stmt "SELECT id,test_id, category, variable, value, expected, tol, units, comment, status, type, last_update FROM test_data WHERE id=? ORDER BY id ASC;")) ;; event_time DESC,id ASC;
- (db:with-db
- dbstruct
- run-id
- #f
- (lambda (dbdat db)
- (let* ((stmth (db:get-cache-stmth dbdat db stmt))
- (res (sqlite3:fold-row
- (lambda (res id test-id category variable value expected tol units comment status type last-update)
- (vector id test-id category variable value expected tol units comment status type last-update))
- (vector #f #f #f #f #f #f #f #f #f #f #f #f)
- stmth
- test-data-id)))
- res)))))
-
-;; WARNING: Do NOT call this for the parent test on an iterated test
-;; Roll up test_data pass/fail results
-;; look at the test_data status field,
-;; if all are pass (any case) and the test status is PASS or NULL or '' then set test status to PASS.
-;; if one or more are fail (any case) then set test status to PASS, non "pass" or "fail" are ignored
-(define (db:test-data-rollup dbstruct run-id test-id status)
- (let* ((fail-count 0)
- (pass-count 0))
- (db:with-db
- dbstruct run-id #t
- (lambda (dbdat db)
- (sqlite3:for-each-row
- (lambda (fcount pcount)
- (set! fail-count fcount)
- (set! pass-count pcount))
- db
- "SELECT (SELECT count(id) FROM test_data WHERE test_id=? AND status like 'fail') AS fail_count,
- (SELECT count(id) FROM test_data WHERE test_id=? AND status like 'pass') AS pass_count;"
- test-id test-id)
- ;; Now rollup the counts to the central megatest.db
- (db:general-call dbstruct run-id 'pass-fail-counts (list pass-count fail-count test-id))
- ;; if the test is not FAIL then set status based on the fail and pass counts.
- (db:general-call dbstruct run-id 'test_data-pf-rollup (list test-id test-id test-id test-id))))))
-
-;; each section is a rule except "final" which is the final result
-;;
-;; [rule-5]
-;; operator in
-;; section LogFileBody
-;; desc Output voltage
-;; status OK
-;; expected 1.9
-;; measured 1.8
-;; type +/-
-;; tolerance 0.1
-;; pass 1
-;; fail 0
-;;
-;; [final]
-;; exit-code 6
-;; exit-status SKIP
-;; message If flagged we are asking for this to exit with code 6
-;;
-;; recorded in steps table:
-;; category: stepname
-;; variable: rule-N
-;; value: measured
-;; expected: expected
-;; tol: tolerance
-;; units: -
-;; comment: desc or message
-;; status: status
-;; type: type
-;;
-(define (db:logpro-dat->csv dat stepname)
- (let ((res '()))
- (for-each
- (lambda (entry-name)
- (if (equal? entry-name "final")
- (set! res (append
- res
- (list
- (list stepname
- entry-name
- (configf:lookup dat entry-name "exit-code") ;; 0 ;; Value
- 0 ;; 1 ;; Expected
- 0 ;; 2 ;; Tolerance
- "n/a" ;; 3 ;; Units
- (configf:lookup dat entry-name "message") ;; 4 ;; Comment
- (configf:lookup dat entry-name "exit-status") ;; 5 ;; Status
- "logpro" ;; 6 ;; Type
- ))))
- (let* ((value (or (configf:lookup dat entry-name "measured") "n/a"))
- (expected (or (configf:lookup dat entry-name "expected") 0.0))
- (tolerance (or (configf:lookup dat entry-name "tolerance") 0.0))
- (comment (or (configf:lookup dat entry-name "comment")
- (configf:lookup dat entry-name "desc") "n/a"))
- (status (or (configf:lookup dat entry-name "status") "n/a"))
- (type (or (configf:lookup dat entry-name "expected") "n/a")))
- (set! res (append
- res
- (list (list stepname
- entry-name
- value ;; 0
- expected ;; 1
- tolerance ;; 2
- "n/a" ;; 3 Units
- comment ;; 4
- status ;; 5
- type ;; 6
- )))))))
- (hash-table-keys dat))
- res))
-
-;; $MT_MEGATEST -load-test-data << EOF
-;; foo,bar, 1.2, 1.9, >
-;; foo,rab, 1.0e9, 10e9, 1e9
-;; foo,bla, 1.2, 1.9, <
-;; foo,bal, 1.2, 1.2, < , ,Check for overload
-;; foo,alb, 1.2, 1.2, <= , Amps,This is the high power circuit test
-;; foo,abl, 1.2, 1.3, 0.1
-;; foo,bra, 1.2, pass, silly stuff
-;; faz,bar, 10, 8mA, , ,"this is a comment"
-;; EOF
-
-(define (db:csv->test-data dbstruct run-id test-id csvdata)
- (debug:print 4 *default-log-port* "test-id " test-id ", csvdata: " csvdata)
- (db:with-db
- dbstruct #f #t
- (lambda (dbdat db)
- (let* ((csvlist (csv->list (make-csv-reader
- (open-input-string csvdata)
- '((strip-leading-whitespace? #t)
- (strip-trailing-whitespace? #t)))))) ;; (csv->list csvdata)))
- (for-each
- (lambda (csvrow)
- (let* ((padded-row (take (append csvrow (list #f #f #f #f #f #f #f #f #f)) 9))
- (category (list-ref padded-row 0))
- (variable (list-ref padded-row 1))
- (value (any->number-if-possible (list-ref padded-row 2)))
- (expected (any->number-if-possible (list-ref padded-row 3)))
- (tol (any->number-if-possible (list-ref padded-row 4))) ;; >, <, >=, <=, or a number
- (units (list-ref padded-row 5))
- (comment (list-ref padded-row 6))
- (status (let ((s (list-ref padded-row 7)))
- (if (and (string? s)(or (string-match (regexp "^\\s*$") s)
- (string-match (regexp "^n/a$") s)))
- #f
- s))) ;; if specified on the input then use, else calculate
- (type (list-ref padded-row 8)))
- ;; look up expected,tol,units from previous best fit test if they are all either #f or ''
- (debug:print 4 *default-log-port* "BEFORE: category: " category " variable: " variable " value: " value
- ", expected: " expected " tol: " tol " units: " units " status: " status " comment: " comment " type: " type)
-
- (if (and (or (not expected)(equal? expected ""))
- (or (not tol) (equal? expected ""))
- (or (not units) (equal? expected "")))
- (let-values (((new-expected new-tol new-units)(tdb:get-prev-tol-for-test #f test-id category variable)))
- (set! expected new-expected)
- (set! tol new-tol)
- (set! units new-units)))
-
- (debug:print 4 *default-log-port* "AFTER: category: " category " variable: " variable " value: " value
- ", expected: " expected " tol: " tol " units: " units " status: " status " comment: " comment)
- ;; calculate status if NOT specified
- (if (and (not status)(number? expected)(number? value)) ;; need expected and value to be numbers
- (if (number? tol) ;; if tol is a number then we do the standard comparison
- (let* ((max-val (+ expected tol))
- (min-val (- expected tol))
- (result (and (>= value min-val)(<= value max-val))))
- (debug:print 4 *default-log-port* "max-val: " max-val " min-val: " min-val " result: " result)
- (set! status (if result "pass" "fail")))
- (set! status ;; NB// need to assess each one (i.e. not return operator since need to act if not valid op.
- (case (string->symbol tol) ;; tol should be >, <, >=, <=
- ((>) (if (> value expected) "pass" "fail"))
- ((<) (if (< value expected) "pass" "fail"))
- ((>=) (if (>= value expected) "pass" "fail"))
- ((<=) (if (<= value expected) "pass" "fail"))
- (else (conc "ERROR: bad tol comparator " tol))))))
- (debug:print 4 *default-log-port* "AFTER2: category: " category " variable: " variable " value: " value
- ", expected: " expected " tol: " tol " units: " units " status: " status " comment: " comment)
- ;; (db:delay-if-busy dbdat)
- (sqlite3:execute db "INSERT OR REPLACE INTO test_data (test_id,category,variable,value,expected,tol,units,comment,status,type) VALUES (?,?,?,?,?,?,?,?,?,?);"
- test-id category variable value expected tol units (if comment comment "") status type)))
- csvlist)))))
-
-;; This routine moved from tdb.scm, tdb:read-test-data
-;;
-(define (db:read-test-data dbstruct run-id test-id categorypatt)
- (let* ((res '()))
- (db:with-db
- dbstruct #f #f
- (lambda (dbdat db)
- (sqlite3:for-each-row
- (lambda (id test_id category variable value expected tol units comment status type)
- (set! res (cons (vector id test_id category variable value expected tol units comment status type) res)))
- db
- "SELECT id,test_id,category,variable,value,expected,tol,units,comment,status,type FROM test_data WHERE test_id=? AND category LIKE ? ORDER BY category,variable;" test-id categorypatt)
- (reverse res)))))
-
-;; This routine moved from tdb.scm, :read-test-data
-;;
-(define (db:read-test-data-varpatt dbstruct run-id test-id categorypatt varpatt)
- (let* ((res '()))
- (db:with-db
- dbstruct #f #f
- (lambda (dbdat db)
- (sqlite3:for-each-row
- (lambda (id test_id category variable value expected tol units comment status type)
- (set! res (cons (vector id test_id category variable value expected tol units comment status type) res)))
- db
- "SELECT id,test_id,category,variable,value,expected,tol,units,comment,status,type FROM test_data WHERE test_id=? AND category LIKE ? AND variable LIKE ? ORDER BY category,variable;" test-id categorypatt varpatt)
- (reverse res)))))
-
-
-;;======================================================================
-;; Misc. test related queries
-;;======================================================================
-
-(define (db:get-run-ids-matching-target dbstruct keynames target res runname testpatt statepatt statuspatt)
- (db:with-db
- dbstruct #f #f
- (lambda (dbdat db)
- (let* ((row-ids '())
- (keystr (string-intersperse
- (map (lambda (key val)
- (conc key " like '" val "'"))
- keynames
- (string-split target "/"))
- " AND "))
- ;; (testqry (tests:match->sqlqry testpatt))
- (runsqry (sqlite3:prepare db (conc "SELECT id FROM runs WHERE " keystr " AND runname LIKE '" runname "';"))))
- ;; (debug:print 8 *default-log-port* "db:test-get-paths-matching-keynames-target-new\n runsqry=" runsqry "\n tstsqry=" testqry)
- (sqlite3:for-each-row
- (lambda (rid)
- (set! row-ids (cons rid row-ids)))
- runsqry)
- (sqlite3:finalize! runsqry)
- row-ids))))
-
-;; finds latest matching all patts for given run-id
-;;
-(define (db:test-get-paths-matching-keynames-target-new dbstruct run-id keynames target res testpatt statepatt statuspatt runname)
- (let* ((testqry (tests:match->sqlqry testpatt))
- (tstsqry (conc "SELECT rundir FROM tests WHERE run_id=? AND " testqry " AND state LIKE '" statepatt "' AND status LIKE '" statuspatt "' ORDER BY event_time ASC;")))
- (db:with-db
- dbstruct
- run-id
- #f
- (lambda (dbdat db)
- (sqlite3:for-each-row
- (lambda (p)
- (set! res (cons p res)))
- db
- tstsqry
- run-id)
- res))))
-
-(define (db:test-toplevel-num-items dbstruct run-id testname)
- (db:with-db
- dbstruct
- run-id
- #f
- (lambda (dbdat db)
- (let ((res 0))
- (sqlite3:for-each-row
- (lambda (num-items)
- (set! res num-items))
- db
- "SELECT count(id) FROM tests WHERE run_id=? AND testname=? AND item_path != '' AND state NOT IN ('DELETED');"
- run-id
- testname)
- res))))
-
-;;======================================================================
-;; QUEUE UP META, TEST STATUS AND STEPS REMOTE ACCESS
-;;======================================================================
-
-;; NOTE: Can remove the regex and base64 encoding for zmq
-(define (db:obj->string obj #!key (transport 'http))
- (case transport
- ;; ((fs) obj)
- ((http fs)
- (string-substitute
- (regexp "=") "_"
- (base64:base64-encode
- (z3:encode-buffer
- (with-output-to-string
- (lambda ()(serialize obj))))) ;; BB: serialize - this is what causes problems between different builds of megatest communicating. serialize is sensitive to binary image of mtest.
- #t))
- ((zmq nmsg)(with-output-to-string (lambda ()(serialize obj))))
- (else obj))) ;; rpc
-
-(define (db:string->obj msg #!key (transport 'http))
- (case transport
- ;; ((fs) msg)
- ((http fs)
- (if (string? msg)
- (with-input-from-string
- (z3:decode-buffer
- (base64:base64-decode
- (string-substitute
- (regexp "_") "=" msg #t)))
- (lambda ()(deserialize)))
- (begin
- (debug:print-error 0 *default-log-port* "reception failed. Received \"" msg "\" but cannot translate it.")
- (print-call-chain (current-error-port))
- msg))) ;; crude reply for when things go awry
- ((zmq nmsg)(with-input-from-string msg (lambda ()(deserialize))))
- (else msg))) ;; rpc
-
-;; ; This is to be the big daddy call NOPE: Replaced by db:set-state-status-and-roll-up-items
-;; ;
-;; define (db:test-set-state-status dbstruct run-id test-id state status msg)
-;; (let ((dbdat (db:get-subdb dbstruct run-id)))
-;; (if (member state '("LAUNCHED" "REMOTEHOSTSTART"))
-;; (db:general-call dbdat 'set-test-start-time (list test-id)))
-;; ;; (if msg
-;; ;; (db:general-call dbdat 'state-status-msg (list state status msg test-id))
-;; ;; (db:general-call dbdat 'state-status (list state status test-id)))
-;; (db:set-state-status-and-roll-up-items dbstruct run-id test-id #f state status msg)
-;; ;; process the test_data table
-;; (if (and test-id state status (equal? status "AUTO"))
-;; (db:test-data-rollup dbstruct run-id test-id status))
-;; (mt:process-triggers dbstruct run-id test-id state status)))
-
-;; state is the priority rollup of all states
-;; status is the priority rollup of all completed statesfu
-;;
-;; if test-name is an integer work off that as test-id instead of test-name test-path
-;;
-(define (db:set-state-status-and-roll-up-items dbstruct run-id test-name item-path state status comment)
- ;; establish info on incoming test followed by info on top level test
- ;; BBnote - for mode itemwait, linkage between upstream test & matching item status is propagated to run queue in db:prereqs-not-met
- (let* ((testdat (if (number? test-name)
- (db:get-test-info-by-id dbstruct run-id test-name) ;; test-name is actually a test-id
- (db:keep-trying-until-true ;; in our threaded stuff this call could happen before the test is registered (maybe?)
- db:get-test-info
- (list dbstruct run-id test-name item-path)
- 10)))
- (test-id (db:test-get-id testdat))
- (test-name (if (number? test-name)
- (db:test-get-testname testdat)
- test-name))
- (item-path (db:test-get-item-path testdat))
- (tl-testdat (db:get-test-info dbstruct run-id test-name ""))
- (tl-test-id (if tl-testdat
- (db:test-get-id tl-testdat)
- #f))
- (new-state-eh #f)
- (new-status-eh #f))
- (if (member state '("LAUNCHED" "REMOTEHOSTSTART"))
- (db:general-call dbstruct run-id 'set-test-start-time (list test-id)))
- (mutex-lock! *db-transaction-mutex*)
- (db:with-db
- dbstruct run-id #t
- (lambda (dbdat db)
- (let ((tr-res
- (sqlite3:with-transaction
- db
- (lambda ()
- ;; NB// Pass the db so it is part fo the transaction
- (db:test-set-state-status-db db run-id test-id state status comment) ;; this call sets the item state/status
- (if (not (equal? item-path "")) ;; only roll up IF incoming test is an item
- (let* ((state-status-counts (db:get-all-state-status-counts-for-test db run-id test-name item-path state status)) ;; item-path is used to exclude current state/status of THIS test
- (state-statuses (db:roll-up-rules state-status-counts state status))
- (newstate (car state-statuses))
- (newstatus (cadr state-statuses)))
- (set! new-state-eh newstate)
- (set! new-status-eh newstatus)
- (debug:print 4 *default-log-port* "BB> tl-test-id="tl-test-id" ; "test-name":"item-path" newstate="newstate" newstatus="newstatus" len(sscs)="(length state-status-counts) " state-status-counts: "
- (apply conc
- (map (lambda (x)
- (conc
- (with-output-to-string (lambda () (pp (dbr:counts->alist x)))) " | "))
- state-status-counts))); end debug:print
- (if tl-test-id
- (db:test-set-state-status-db db run-id tl-test-id newstate newstatus #f)) ;; we are still in the transaction - must access the db and not the dbstruct
- ))))))
- (mutex-unlock! *db-transaction-mutex*)
- (if (and test-id state status (equal? status "AUTO"))
- (db:test-data-rollup dbstruct run-id test-id status))
- (if new-state-eh ;; moved from db:test-set-state-status
- (mt:process-triggers dbstruct run-id test-id new-state-eh new-status-eh))
- tr-res)))))
-
-(define (db:roll-up-rules state-status-counts state status)
- (if (null? state-status-counts)
- '(#f #f)
- (let* ((running (length (filter (lambda (x)
- (member (dbr:counts-state x) *common:running-states*))
- state-status-counts)))
- (bad-not-started (length (filter (lambda (x)
- (and (equal? (dbr:counts-state x) "NOT_STARTED")
- (not (member (dbr:counts-status x) *common:not-started-ok-statuses*))))
- state-status-counts)))
- (all-curr-states (common:special-sort ;; worst -> best (sort of)
- (delete-duplicates
- (if (and state (not (member state *common:dont-roll-up-states*)))
- (cons state (map dbr:counts-state state-status-counts))
- (map dbr:counts-state state-status-counts)))
- *common:std-states* >))
- (all-curr-statuses (common:special-sort ;; worst -> best
- (delete-duplicates
- (if (and state status (not (member state *common:dont-roll-up-states*)))
- (cons status (map dbr:counts-status state-status-counts))
- (map dbr:counts-status state-status-counts)))
- *common:std-statuses* >))
- (non-completes (filter (lambda (x)
- (not (member x (cons "COMPLETED" *common:dont-roll-up-states*))))
- all-curr-states))
- (preq-fails (filter (lambda (x)
- (equal? x "PREQ_FAIL"))
- all-curr-statuses))
- (num-non-completes (length non-completes))
- (newstate (cond
- ((> running 0) "RUNNING") ;; anything running, call the situation running
- ((> (length preq-fails) 0) "NOT_STARTED")
- ((> bad-not-started 0) "COMPLETED") ;; we have an ugly situation, it is completed in the sense we cannot do more.
- ((> num-non-completes 0) (car non-completes)) ;; (remove (lambda (x)(equal? "COMPLETED" x)) all-curr-states))) ;; only rollup DELETED if all DELETED
- (else (car all-curr-states))))
- (newstatus (cond
- ((> (length preq-fails) 0) "PREQ_FAIL")
- ((or (> bad-not-started 0)
- (and (equal? newstate "NOT_STARTED")
- (> num-non-completes 0)))
- "STARTED")
- (else (car all-curr-statuses)))))
- (debug:print-info 2 *default-log-port*
- "\n--> probe db:set-state-status-and-roll-up-items: "
- "\n--> state-status-counts: "(map dbr:counts->alist state-status-counts)
- "\n--> running: "running
- "\n--> bad-not-started: "bad-not-started
- "\n--> non-non-completes: "num-non-completes
- "\n--> non-completes: "non-completes
- "\n--> all-curr-states: "all-curr-states
- "\n--> all-curr-statuses: "all-curr-statuses
- "\n--> newstate "newstate
- "\n--> newstatus "newstatus
- "\n\n")
-
- ;; NB// Pass the db so it is part of the transaction
- (list newstate newstatus))))
-
-(define (db:set-state-status-and-roll-up-run dbstruct run-id curr-state curr-status)
- (mutex-lock! *db-transaction-mutex*)
- (db:with-db
- dbstruct run-id #t
- (lambda (dbdat db)
- (let ((tr-res
- (sqlite3:with-transaction
- db
- (lambda ()
- (let* ((state-status-counts (db:get-all-state-status-counts-for-run-db dbdat db run-id))
- (state-statuses (db:roll-up-rules state-status-counts #f #f ))
- (newstate (car state-statuses))
- (newstatus (cadr state-statuses)))
- (if (or (not (eq? newstate curr-state)) (not (eq? newstatus curr-status)))
- (db:set-run-state-status-db dbdat db run-id newstate newstatus )))))))
- (mutex-unlock! *db-transaction-mutex*)
- tr-res))))
-
-(define (db:get-all-state-status-counts-for-run-db dbdat db run-id)
- (sqlite3:map-row
- (lambda (state status count)
- (make-dbr:counts state: state status: status count: count))
- (db:get-cache-stmth
- dbdat db
- "SELECT state,status,count(id) FROM tests WHERE run_id=? GROUP BY state,status;")
- run-id ))
-
-(define (db:get-all-state-status-counts-for-run dbstruct run-id)
- (db:with-db
- dbstruct #f #f
- (lambda (dbdat db)
- (db:get-all-state-status-counts-for-run-db dbdat db run-id))))
-
-;; BBnote: db:get-all-state-status-counts-for-test returns dbr:counts object aggregating state and status of items of a given test, *not including rollup state/status*
-;;
-;; NOTE: This is called within a transaction
-;;
-(define (db:get-all-state-status-counts-for-test db run-id test-name item-path item-state-in item-status-in)
- (let* ((test-info (db:get-test-info-db db run-id test-name item-path))
- (item-state (or item-state-in (db:test-get-state test-info)))
- (item-status (or item-status-in (db:test-get-status test-info)))
- (other-items-count-recs (sqlite3:map-row
- (lambda (state status count)
- (make-dbr:counts state: state status: status count: count))
- db
- ;; ignore current item because we have changed its value in the current transation so this select will see the old value.
- "SELECT state,status,count(id) FROM tests WHERE run_id=? AND testname=? AND item_path != '' AND item_path !=? GROUP BY state,status;"
- run-id test-name item-path))
- ;; add current item to tally outside of sql query
- (match-countrec-lambda (lambda (countrec)
- (and (equal? (dbr:counts-state countrec) item-state)
- (equal? (dbr:counts-status countrec) item-status))))
-
- (already-have-count-rec-list
- (filter match-countrec-lambda other-items-count-recs)) ;; will have either 0 or 1 count recs depending if another item shares this item's state/status
-
- (updated-count-rec (if (null? already-have-count-rec-list)
- (make-dbr:counts state: item-state status: item-status count: 1)
- (let* ((our-count-rec (car already-have-count-rec-list))
- (new-count (add1 (dbr:counts-count our-count-rec))))
- (make-dbr:counts state: item-state status: item-status count: new-count))))
-
- (nonmatch-countrec-lambda (lambda (countrec) (not (match-countrec-lambda countrec))))
-
- (unrelated-rec-list
- (filter nonmatch-countrec-lambda other-items-count-recs)))
- (cons updated-count-rec unrelated-rec-list)))
-
-;; (define (db:get-all-item-states db run-id test-name)
-;; (sqlite3:map-row
-;; (lambda (a) a)
-;; db
-;; "SELECT DISTINCT state FROM tests WHERE item_path != '' AND state != 'DELETED' AND run_id=? AND testname=?"
-;; run-id test-name))
-;;
-;; (define (db:get-all-item-statuses db run-id test-name)
-;; (sqlite3:map-row
-;; (lambda (a) a)
-;; db
-;; "SELECT DISTINCT status FROM tests WHERE item_path != '' AND state != 'DELETED' AND state='COMPLETED' AND run_id=? AND testname=?"
-;; run-id test-name))
-
-(define (db:test-get-logfile-info dbstruct run-id test-name)
- (db:with-db
- dbstruct
- run-id
- #f
- (lambda (dbdat db)
- (let ((res #f))
- (sqlite3:for-each-row
- (lambda (path final_logf)
- ;; (let ((path (sdb:qry 'getstr path-id))
- ;; (final_logf (sdb:qry 'getstr final_logf-id)))
- (set! logf final_logf)
- (set! res (list path final_logf))
- (if (directory? path)
- (debug:print 2 *default-log-port* "Found path: " path)
- (debug:print 2 *default-log-port* "No such path: " path))) ;; )
- db
- "SELECT rundir,final_logf FROM tests WHERE testname=? AND item_path='' AND run_id=?;"
- test-name run-id)
- res))))
-
-;;======================================================================
-;; A G R E G A T E D T R A N S A C T I O N D B W R I T E S
-;;======================================================================
-
-(define db:queries
- (list '(update-run-duration "UPDATE tests SET run_duration=? WHERE id=?;")
-
- ;; TESTS
- '(register-test "INSERT OR IGNORE INTO tests (run_id,testname,event_time,item_path,state,status) VALUES (?,?,strftime('%s','now'),?,'NOT_STARTED','n/a');")
- ;; Test state and status
- '(set-test-state "UPDATE tests SET state=? WHERE id=?;")
- '(set-test-status "UPDATE tests SET state=? WHERE id=?;")
- '(state-status "UPDATE tests SET state=?,status=? WHERE id=?;") ;; D/ONE
- '(state-status-msg "UPDATE tests SET state=?,status=?,comment=? WHERE id=?;") ;; DONE
- ;; Test comment
- '(set-test-comment "UPDATE tests SET comment=? WHERE id=?;")
- '(set-test-start-time "UPDATE tests SET event_time=strftime('%s','now') WHERE id=?;") ;; DONE
- '(pass-fail-counts "UPDATE tests SET pass_count=?,fail_count=? WHERE id=?;")
- ;; test_data-pf-rollup is used to set a tests PASS/FAIL based on the pass/fail info from the steps
- '(test_data-pf-rollup "UPDATE tests
- SET status=CASE WHEN (SELECT fail_count FROM tests WHERE id=?) > 0
- THEN 'FAIL'
- WHEN (SELECT pass_count FROM tests WHERE id=?) > 0 AND
- (SELECT status FROM tests WHERE id=?) NOT IN ('WARN','FAIL')
- THEN 'PASS'
- ELSE status
- END WHERE id=?;") ;; DONE
- '(test-set-log "UPDATE tests SET final_logf=? WHERE id=?;") ;; DONE
- ;; '(test-set-rundir-by-test-id "UPDATE tests SET rundir=? WHERE id=?") ;; DONE
- ;; '(test-set-rundir "UPDATE tests SET rundir=? AND testname=? AND item_path=?;") ;; DONE
- '(test-set-rundir-shortdir "UPDATE tests SET rundir=?,shortdir=? WHERE testname=? AND item_path=? AND run_id=?;") ;; BROKEN!!! NEEDS run-id
- '(delete-tests-in-state ;; "DELETE FROM tests WHERE state=?;") ;; DONE
- "UPDATE tests SET state='DELETED' WHERE state=?")
- '(tests:test-set-toplog "UPDATE tests SET final_logf=? WHERE run_id=? AND testname=? AND item_path='';")
- '(update-cpuload-diskfree "UPDATE tests SET cpuload=?,diskfree=? WHERE id=?;") ;; DONE
- '(update-uname-host "UPDATE tests SET uname=?,host=? WHERE id=?;") ;; DONE
- '(update-test-rundat "INSERT INTO test_rundat (test_id,update_time,cpuload,diskfree,diskusage,run_duration) VALUES (?,?,?,?,?,?);")
- '(update-test-state "UPDATE tests SET state=? WHERE state=? AND run_id=? AND testname=? AND NOT (item_path='' AND testname IN (SELECT DISTINCT testname FROM tests WHERE testname=? AND item_path != ''));")
- '(update-test-status "UPDATE tests SET status=? WHERE status like ? AND run_id=? AND testname=? AND NOT (item_path='' AND testname IN (SELECT DISTINCT testname FROM tests WHERE testname=? AND item_path != ''));")
- ;; stuff for set-state-status-and-roll-up-items
- '(update-pass-fail-counts "UPDATE tests
- SET fail_count=(SELECT count(id) FROM tests WHERE testname=? AND item_path != '' AND status IN ('FAIL','CHECK','INCOMPLETE','ABORT')),
- pass_count=(SELECT count(id) FROM tests WHERE testname=? AND item_path != '' AND status IN ('PASS','WARN','WAIVED'))
- WHERE testname=? AND item_path='' AND run_id=?;") ;; DONE ;; BROKEN!!! NEEDS run-id
- '(top-test-set-running "UPDATE tests SET state='RUNNING' WHERE testname=? AND item_path='' AND run_id=?;") ;; DONE ;; BROKEN!!! NEEDS run-id
-
- ;; NOT USED
- ;;
- ;; Might be the following top-test-set-per-pf-counts query could be better based off of something like this:
- ;;
- ;; select state,status,count(state) from tests where run_id=59 AND testname='runfirst' group by state,status;
- ;;
- '(top-test-set-per-pf-counts "UPDATE tests
- SET state=CASE
- WHEN (SELECT count(id) FROM tests
- WHERE testname=?
- AND item_path != ''
- AND status NOT IN ('n/a')
- AND state in ('NOT_STARTED')) > 0 THEN 'UNKNOWN'
- WHEN (SELECT count(id) FROM tests
- WHERE testname=?
- AND item_path != ''
- AND (status NOT IN ('TEN_STRIKES','BLOCKED') OR status IN ('INCOMPLETE'))
- AND state in ('RUNNING','NOT_STARTED','LAUNCHED','REMOTEHOSTSTART')) > 0 THEN 'RUNNING'
- WHEN (SELECT count(id) FROM tests
- WHERE testname=?
- AND item_path != ''
- AND state NOT IN ('COMPLETED','DELETED')) = 0 THEN 'COMPLETED'
- WHEN (SELECT count(id) FROM tests
- WHERE testname=?
- AND item_path != ''
- AND state = 'NOT_STARTED') > 0 THEN 'NOT_STARTED'
- ELSE 'UNKNOWN' END,
- status=CASE
- WHEN fail_count > 0 THEN 'FAIL'
- WHEN (SELECT count(id) FROM tests
- WHERE testname=?
- AND item_path != ''
- AND state IN ('BLOCKED','INCOMPLETE')) > 0 THEN 'FAIL'
- WHEN (SELECT count(id) FROM tests
- WHERE testname=?
- AND item_path != ''
- AND state NOT IN ('DELETED')
- AND status IN ('INCOMPLETE','ABORT')) > 0 THEN 'ABORT'
- WHEN (SELECT count(id) FROM tests
- WHERE testname=?
- AND item_path != ''
- AND state NOT IN ('DELETED')
- AND status = 'AUTO') > 0 THEN 'AUTO'
- WHEN (SELECT count(id) FROM tests
- WHERE testname=?
- AND item_path != ''
- AND state NOT IN ('DELETED')
- AND status IN ('STUCK/INCOMPLETE', 'INCOMPLETE')) > 0 THEN 'INCOMPLETE'
- WHEN (SELECT count(id) FROM tests
- WHERE testname=?
- AND item_path != ''
- AND state IN ('COMPLETED','STUCK/INCOMPLETE','INCOMPLETE')
- AND status = 'FAIL') > 0 THEN 'FAIL'
- WHEN (SELECT count(id) FROM tests
- WHERE testname=?
- AND item_path != ''
- AND state NOT IN ('DELETED')
- AND status = 'CHECK') > 0 THEN 'CHECK'
- WHEN (SELECT count(id) FROM tests
- WHERE testname=?
- AND item_path != ''
- AND state NOT IN ('DELETED')
- AND status = 'SKIP') > 0 THEN 'SKIP'
- WHEN (SELECT count(id) FROM tests
- WHERE testname=?
- AND item_path != ''
- AND state NOT IN ('DELETED')
- AND status = 'WARN') > 0 THEN 'WARN'
- WHEN (SELECT count(id) FROM tests
- WHERE testname=?
- AND item_path != ''
- AND state NOT IN ('DELETED')
- AND status = 'WAIVED') > 0 THEN 'WAIVED'
- WHEN (SELECT count(id) FROM tests
- WHERE testname=?
- AND item_path != ''
- AND state NOT IN ('DELETED')
- AND status NOT IN ('PASS','FAIL','WARN','WAIVED')) > 0 THEN 'ABORT'
- WHEN (SELECT count(id) FROM tests
- WHERE testname=?
- AND item_path != ''
- AND state='NOT_STARTED') > 0 THEN 'n/a'
- WHEN (SELECT count(id) FROM tests
- WHERE testname=?
- AND item_path != ''
- AND state = 'COMPLETED'
- AND status = 'PASS') > 0 THEN 'PASS'
- WHEN pass_count > 0 AND fail_count=0 THEN 'PASS'
- ELSE 'UNKNOWN' END
- WHERE testname=? AND item_path='';") ;; DONE ;; BROKEN!!! NEEDS run-id
-
- ;; STEPS
- '(delete-test-step-records "UPDATE test_steps SET status='DELETED' WHERE test_id=?;")
- '(delete-test-data-records "UPDATE test_data SET status='DELETED' WHERE test_id=?;") ;; using status since no state field
- ))
-
-(define (db:lookup-query qry-name)
- (let ((q (alist-ref qry-name db:queries)))
- (if q (car q) #f)))
-
-;; do not run these as part of the transaction
-(define db:special-queries '(rollup-tests-pass-fail
- ;; db:set-state-status-and-roll-up-items ;; WHY NOT!?
- login
- immediate
- flush
- sync
- set-verbosity
- killserver
- ))
-
-(define (db:login dbstruct calling-path calling-version client-signature)
- (cond
- ((not (equal? calling-path *toppath*))
- (list #f "Login failed due to mismatch paths: " calling-path ", " *toppath*))
- ;; ((not (equal? *run-id* run-id))
- ;; (list #f "Login failed due to mismatch run-id: " run-id ", " *run-id*))
- ((not (equal? megatest-version calling-version))
- (list #t (conc "Login warning due to mismatch megatest version: " calling-version ", " megatest-version)))
-
- (else
- (hash-table-set! *logged-in-clients* client-signature (current-seconds))
- '(#t "successful login"))))
-
-;; NO WAY TO KNOW IF IT MODIFIES THE DB BUT NEARLY ALL ARE UPDATES/INSERTS
-;;
-(define (db:general-call dbstruct run-id stmtname params)
- ;; Why is db:lookup-query above not used here to get the query?
- (let ((query (let ((q (alist-ref (if (string? stmtname)
- (string->symbol stmtname)
- stmtname)
- db:queries)))
- (if q (car q) #f))))
- (db:with-db
- dbstruct run-id #t
- (lambda (dbdat db)
- (apply sqlite3:execute db query params)
- #t))))
-
-;; get a summary of state and status counts to calculate a rollup
-;;
-(define (db:get-state-status-summary dbstruct run-id testname)
- (let ((res '()))
- (db:with-db
- dbstruct run-id #f
- (lambda (dbdat db)
- (sqlite3:for-each-row
- (lambda (state status count)
- (set! res (cons (vector state status count) res)))
- db
- "SELECT state,status,count(state) FROM tests WHERE run_id=? AND testname=? AND item_path='' GROUP BY state,status;"
- run-id testname)
- res))))
-
-(define (db:get-latest-host-load dbstruct raw-hostname)
- (let* ((hostname (string-substitute "\\..*$" "" raw-hostname))
- (res (cons -1 0)))
- (db:with-db
- dbstruct #f #f
- (lambda (dbdat db)
- (sqlite3:for-each-row
- (lambda (cpuload update-time) (set! res (cons cpuload update-time)))
- db
- "SELECT tr.cpuload, tr.update_time FROM test_rundat tr, tests t WHERE t.host=? AND tr.cpuload != -1 AND tr.test_id=t.id ORDER BY tr.update_time DESC LIMIT 1;"
- hostname))) res ))
-
-(define (db:set-top-level-from-items dbstruct run-id testname)
- (let* ((summ (db:get-state-status-summary dbstruct run-id testname))
- (find (lambda (state status)
- (if (null? summ)
- #f
- (let loop ((hed (car summ))
- (tal (cdr summ)))
- (if (and (string-match state (vector-ref hed 0))
- (string-match status (vector-ref hed 1)))
- hed
- (if (null? tal)
- #f
- (loop (car tal)(cdr tal)))))))))
-
-
- ;;; E D I T M E ! !
-
-
- (cond
- ((> (find "COMPLETED" ".*") 0) #f))))
-
-
-
-;; get the previous records for when these tests were run where all keys match but runname
-;; NB// Merge this with test:get-previous-test-run-records? This one looks for all matching tests
-;; can use wildcards. Also can likely be factored in with get test paths?
-;;
-;; Run this remotely!!
-;;
-(define (db:get-matching-previous-test-run-records dbstruct run-id test-name item-path)
- (let* ((keys (db:get-keys dbstruct))
- (selstr (string-intersperse keys ","))
- (qrystr (string-intersperse (map (lambda (x)(conc x "=?")) keys) " AND "))
- (keyvals #f)
- (tests-hash (make-hash-table)))
- ;; first look up the key values from the run selected by run-id
- (db:with-db
- dbstruct #f #f
- (lambda (dbdat db)
- (sqlite3:for-each-row
- (lambda (a . b)
- (set! keyvals (cons a b)))
- db
- (conc "SELECT " selstr " FROM runs WHERE id=? ORDER BY event_time DESC;") run-id)))
- (if (not keyvals)
- '()
- (let ((prev-run-ids '()))
- (db:with-db
- dbstruct #f #f
- (lambda (dbdat db)
- (apply sqlite3:for-each-row
- (lambda (id)
- (set! prev-run-ids (cons id prev-run-ids)))
- db
- (conc "SELECT id FROM runs WHERE " qrystr " AND id != ?;") (append keyvals (list run-id)))))
- ;; collect all matching tests for the runs then
- ;; extract the most recent test and return that.
- (debug:print 4 *default-log-port* "selstr: " selstr ", qrystr: " qrystr ", keyvals: " keyvals
- ", previous run ids found: " prev-run-ids)
- (if (null? prev-run-ids) '() ;; no previous runs? return null
- (let loop ((hed (car prev-run-ids))
- (tal (cdr prev-run-ids)))
- (let ((results (db:get-tests-for-run dbstruct hed (conc test-name "/" item-path) '() '() #f #f #f #f #f #f #f 'normal)))
- (debug:print 4 *default-log-port* "Got tests for run-id " run-id ", test-name " test-name
- ", item-path " item-path " results: " (intersperse results "\n"))
- ;; Keep only the youngest of any test/item combination
- (for-each
- (lambda (testdat)
- (let* ((full-testname (conc (db:test-get-testname testdat) "/" (db:test-get-item-path testdat)))
- (stored-test (hash-table-ref/default tests-hash full-testname #f)))
- (if (or (not stored-test)
- (and stored-test
- (> (db:test-get-event_time testdat)(db:test-get-event_time stored-test))))
- ;; this test is younger, store it in the hash
- (hash-table-set! tests-hash full-testname testdat))))
- results)
- (if (null? tal)
- (map cdr (hash-table->alist tests-hash)) ;; return a list of the most recent tests
- (loop (car tal)(cdr tal))))))))))
-
-;; Function recursively checks if .journal exists; if yes means db busy; call itself after delayed interval
-;; return the sqlite3 db handle if possible
-;;
-(define (db:delay-if-busy dbdat #!key (count 6))
- (if (not (configf:lookup *configdat* "server" "delay-on-busy"))
- (and dbdat (dbr:dbdat-dbh dbdat))
- (if dbdat
- (let* ((dbpath (dbr:dbdat-dbfile dbdat))
- (db (dbr:dbdat-dbh dbdat)) ;; we'll return this so (db:delay--if-busy can be called inline
- (dbfj (conc dbpath "-journal")))
- (if (handle-exceptions
- exn
- (begin
- (debug:print-info 0 *default-log-port* "WARNING: failed to test for existance of " dbfj ", exn=" exn)
- (thread-sleep! 1)
- (db:delay-if-busy count (- count 1)))
- (common:file-exists? dbfj))
- (case count
- ((6)
- (thread-sleep! 0.2)
- (db:delay-if-busy count: 5))
- ((5)
- (thread-sleep! 0.4)
- (db:delay-if-busy count: 4))
- ((4)
- (thread-sleep! 0.8)
- (db:delay-if-busy count: 3))
- ((3)
- (thread-sleep! 1.6)
- (db:delay-if-busy count: 2))
- ((2)
- (thread-sleep! 3.2)
- (db:delay-if-busy count: 1))
- ((1)
- (thread-sleep! 6.4)
- (db:delay-if-busy count: 0))
- (else
- (debug:print-info 0 *default-log-port* "delaying db access due to high database load.")
- (thread-sleep! 12.8))))
- db)
- "bogus result from db:delay-if-busy")))
-
-(define (db:test-get-records-for-index-file dbstruct run-id test-name)
- (let ((res '()))
- (db:with-db
- dbstruct
- run-id
- #f
- (lambda (dbdat db)
- (sqlite3:for-each-row
- (lambda (id itempath state status run_duration logf comment)
- (set! res (cons (vector id itempath state status run_duration logf comment) res)))
- db
- "SELECT id,item_path,state,status,run_duration,final_logf,comment FROM tests WHERE testname=? AND item_path != '' AND run_id=?;" ;; BUG! WHY NO run_id?
- test-name
- run-id)
- res))))
-
-;;======================================================================
-;; Tests meta data
-;;======================================================================
-
-;; returns a hash table of tags to tests
-;;
-(define (db:get-tests-tags dbstruct)
- (db:with-db
- dbstruct #f #f
- (lambda (dbdat db)
- (let* ((res (make-hash-table)))
- (sqlite3:for-each-row
- (lambda (testname tags-in)
- (let ((tags (string-split tags-in ",")))
- (for-each
- (lambda (tag)
- (hash-table-set! res tag
- (delete-duplicates
- (cons testname (hash-table-ref/default res tag '())))))
- tags)))
- db
- "SELECT testname,tags FROM test_meta")
- (hash-table->alist res)))))
-
-;; testmeta doesn't change, we can cache it for up too an hour
-
-(define *db:testmeta-cache* (make-hash-table))
-(define *db:testmeta-last-update* 0)
-
-;; read the record given a testname
-(define (db:testmeta-get-record dbstruct testname)
- (if (and (< (- (current-seconds) *db:testmeta-last-update*) 600)
- (hash-table-exists? *db:testmeta-cache* testname))
- (hash-table-ref *db:testmeta-cache* testname)
- (let ((res #f))
- (db:with-db
- dbstruct
- #f
- #f
- (lambda (dbdat db)
- (sqlite3:for-each-row
- (lambda (id testname author owner description reviewed iterated avg_runtime avg_disk tags jobgroup)
- (set! res (vector id testname author owner description reviewed iterated avg_runtime avg_disk tags jobgroup)))
- db
- "SELECT id,testname,author,owner,description,reviewed,iterated,avg_runtime,avg_disk,tags,jobgroup FROM test_meta WHERE testname=?;"
- testname)))
- (hash-table-set! *db:testmeta-cache* testname res)
- (set! *db:testmeta-last-update* (current-seconds))
- res)))
-
-;; create a new record for a given testname
-(define (db:testmeta-add-record dbstruct testname)
- (db:with-db dbstruct #f #t
- (lambda (dbdat db)
- (sqlite3:execute
- db
- "INSERT OR IGNORE INTO test_meta (testname,author,owner,description,reviewed,iterated,avg_runtime,avg_disk,tags) VALUES (?,'','','','','','','','');" testname))))
-
-;; update one of the testmeta fields
-(define (db:testmeta-update-field dbstruct testname field value)
- (db:with-db dbstruct #f #t
- (lambda (dbdat db)
- (sqlite3:execute
- db
- (conc "UPDATE test_meta SET " field "=? WHERE testname=?;") value testname))))
-
-(define (db:testmeta-get-all dbstruct)
- (db:with-db dbstruct #f #f
- (lambda (dbdat db)
- (let ((res '()))
- (sqlite3:for-each-row
- (lambda (a . b)
- (set! res (cons (apply vector a b) res)))
- db
- "SELECT id,testname,author,owner,description,reviewed,iterated,avg_runtime,avg_disk,tags,jobgroup FROM test_meta;")
- res))))
-
-;;======================================================================
-;; M I S C M A N A G E M E N T I T E M S
-;;======================================================================
-
-;; A routine to map itempaths using a itemmap
-;; patha and pathb must be strings or this will fail
-;;
-;; path-b is waiting on path-a
-;;
-(define (db:compare-itempaths test-b-name path-a path-b itemmaps )
- (debug:print-info 6 *default-log-port* "ITEMMAPS: " itemmaps)
- (let* ((itemmap (tests:lookup-itemmap itemmaps test-b-name)))
- (if itemmap
- (let ((path-b-mapped (db:multi-pattern-apply path-b itemmap)))
- (debug:print-info 6 *default-log-port* "ITEMMAP is " itemmap ", path: " path-b ", mapped path: " path-b-mapped)
- (equal? path-a path-b-mapped))
- (equal? path-b path-a))))
-
-;; A routine to convert test/itempath using a itemmap
-;; NOTE: to process only an itempath (i.e. no prepended testname)
-;; just call db:multi-pattern-apply
-;;
-(define (db:convert-test-itempath path-in itemmap)
- (debug:print-info 6 *default-log-port* "ITEMMAP is " itemmap)
- (let* ((path-parts (string-split path-in "/"))
- (test-name (if (null? path-parts) "" (car path-parts)))
- (item-path (string-intersperse (if (null? path-parts) '() (cdr path-parts)) "/")))
- (conc test-name "/"
- (db:multi-pattern-apply item-path itemmap))))
-
-;; patterns are:
-;; "rx1" "replacement1"\n
-;; "rx2" "replacement2"
-;; etc.
-;;
-(define (db:multi-pattern-apply item-path itemmap)
- (let ((all-patts (string-split itemmap "\n")))
- (if (null? all-patts)
- item-path
- (let loop ((hed (car all-patts))
- (tal (cdr all-patts))
- (res item-path))
- (let* ((parts (string-split hed))
- (patt (car parts))
-
- (repl (if (> (length parts) 1)(cadr parts) ""))
-
- (newr (if (and patt repl)
- (begin
- (handle-exceptions
- exn
- (begin
- (debug:print 0 *default-log-port*
- "WARNING: itemmap has problem \"" itemmap "\", patt: " patt ", repl: " repl ", exn=" exn)
- res)
- (string-substitute patt repl res))
-
-
- )
- (begin
- (debug:print 0 *default-log-port*
- "WARNING: itemmap has problem \"" itemmap "\", patt: " patt ", repl: " repl)
- res))))
- (if (null? tal)
- newr
- (loop (car tal)(cdr tal) newr)))))))
-
-
-
-
-;; the new prereqs calculation, looks also at itempath if specified
-;; all prereqs must be met
-;; if prereq test with itempath='' is in common:well-ended-states, then prereq is met
-;; if prereq test with itempath=ref-item-path and COMPLETED with PASS, WARN, CHECK, or WAIVED then prereq is met
-;;
-;; Note: mode 'normal means that tests must be COMPLETED and ok (i.e. PASS, WARN, CHECK, SKIP or WAIVED)
-;; mode 'toplevel means that tests must be COMPLETED only
-;; mode 'itemmatch or 'itemwait means that tests items must be COMPLETED and (PASS|WARN|WAIVED|CHECK) [[ NB// NOT IMPLEMENTED YET ]]
-;; mode 'exclusive means this test/item cannot run if the same test/item is LAUNCHED,REMOTEHOSTSTART or RUNNING
-;;
-;; IDEA for consideration:
-;; 1. collect all tests "upstream"
-;; 2. any NOT completed and good? if yes => return those as prereqs not met, if no => return null list
-;;
-;; (define (db:get-prereqs-not-met dbstruct run-id waitons ref-item-path mode)
-(define (db:get-prereqs-not-met dbstruct run-id waitons ref-test-name ref-item-path mode itemmaps) ;; #!key (mode '(normal))(itemmap #f))
- ;; BBnote - rollup of an itemized test's overall state/status done in db:set-state-status-and-roll-up-items
- (debug:print 4 *default-log-port* "db:get-prereqs-not-met: " waitons)
- (append
- (if (member 'exclusive mode)
- (let ((running-tests (db:get-tests-for-run dbstruct
- #f ;; run-id of #f means for all runs.
- (if (string=? ref-item-path "") ;; testpatt
- ref-test-name
- (conc ref-test-name "/" ref-item-path))
- '("LAUNCHED" "REMOTEHOSTSTART" "RUNNING") ;; states
- '() ;; statuses
- #f ;; offset
- #f ;; limit
- #f ;; not-in
- #f ;; sort by
- #f ;; sort order
- 'shortlist ;; query type
- 0 ;; last update, beginning of time ....
- #f ;; mode
- )))
- ;;(map (lambda (testdat)
- ;; (if (equal? (db:test-get-item-path testdat) "")
- ;; (db:test-get-testname testdat)
- ;; (conc (db:test-get-testname testdat)
- ;; "/"
- ;; (db:test-get-item-path testdat))))
- running-tests) ;; calling functions want the entire data
- '())
-
-
-
- ;; collection of: for each waiton -
- ;; if this ref-test-name is an item in an itemized test and mode is itemwait/itemmatch:
- ;; if waiton is not itemized - if waiton is not both completed and in ok status, add as unmet prerequisite
- ;; if waiton is itemized:
- ;; and waiton's items are not expanded, add as unmet prerequisite
- ;; else if matching waiton item is not both completed and in an ok status, add as unmet prerequisite
- ;; else
- ;; if waiton toplevel is not in both completed and ok status, add as unmet prerequisite
-
- (if (or (not waitons)
- (null? waitons))
- '()
- (let* ((ref-test-itemized-mode (not (null? (lset-intersection eq? mode '(itemmatch itemwait))))) ;; how is this different from using member?
- (ref-test-toplevel-mode (not (null? (lset-intersection eq? mode '(toplevel)))))
- (ref-test-is-toplevel (equal? ref-item-path ""))
- (ref-test-is-item (not ref-test-is-toplevel))
- (unmet-pre-reqs '())
- (result '())
- (unmet-prereq-items '())
- )
- (for-each ; waitons
- (lambda (waitontest-name)
- ;; by getting the tests with matching name we are looking only at the matching test
- ;; and related sub items
- ;; next should be using mt:get-tests-for-run?
-
- (let (;(waiton-is-itemized ...)
- ;(waiton-items-are-expanded ...)
- (waiton-tests (db:get-tests-for-run-state-status dbstruct run-id waitontest-name))
- (ever-seen #f)
- (parent-waiton-met #f)
- (item-waiton-met #f)
-
- )
- (for-each ; test expanded from waiton
- (lambda (waiton-test)
- (let* ((waiton-state (db:test-get-state waiton-test))
- (waiton-status (db:test-get-status waiton-test))
- (waiton-item-path (db:test-get-item-path waiton-test)) ;; BB- this is the upstream itempath
- (waiton-test-name (db:test-get-testname waiton-test))
- (waiton-is-toplevel (equal? waiton-item-path ""))
- (waiton-is-item (not waiton-is-toplevel))
- (waiton-is-completed (member waiton-state *common:ended-states*))
- (waiton-is-running (member waiton-state *common:running-states*))
- (waiton-is-killed (member waiton-state *common:badly-ended-states*))
- (waiton-is-ok (member waiton-status *common:well-ended-states*))
- ;; testname-b path-a path-b
- (same-itempath (db:compare-itempaths ref-test-name waiton-item-path ref-item-path itemmaps)) ;; (equal? ref-item-path waiton-item-path)))
- (real-ref-test-name (car (string-split ref-test-name "/"))) ;; I THINK ref-test-name SHOULD NEVER HAVE THE ITEM_PATH!
- (test-and-ref-are-same (equal? real-ref-test-name waiton-test-name)))
- (debug:print 4 *default-log-port* "waiton-test-name " waiton-test-name " ref-test-name: " ref-test-name " test-and-ref-are-same: " test-and-ref-are-same)
- (set! ever-seen #t)
- ;;(BB> "***consider waiton "waiton-test"/"waiton-item-path"***")
- (cond
- ;; case 0 - toplevel of an itemized test, at least one item in prereq has completed
- ((and waiton-is-item ref-test-is-toplevel ref-test-itemized-mode waiton-is-completed)
- (set! parent-waiton-met #t))
-
- ;; case 1, non-item (parent test) is
- ((and waiton-is-toplevel ;; this is the parent test of the waiton being examined
- waiton-is-completed
- ;;(BB> "cond1")
- (or waiton-is-ok ref-test-toplevel-mode)) ;; itemmatch itemwait))))))
- (set! parent-waiton-met #t))
- ;; Special case for toplevel and KILLED
- ((and waiton-is-toplevel ;; this is the parent test
- waiton-is-killed
- (member 'toplevel mode))
- ;;(BB> "cond2")
- (set! parent-waiton-met #t))
- ;; For itemwait mode IFF the previous matching item is good the set parent-waiton-met
- ((and ref-test-itemized-mode ref-test-is-item same-itempath)
- ;;(BB> "cond3")
- (if (and waiton-is-completed (or waiton-is-ok ref-test-toplevel-mode))
- (set! item-waiton-met #t)
- (set! unmet-prereq-items (cons waiton-test unmet-prereq-items)))
- (if (and waiton-is-toplevel ;; if upstream rollup test is completed, parent-waiton-met is set
- (or waiton-is-completed waiton-is-running))
- (set! parent-waiton-met #t)))
- ;; normal checking of parent items, any parent or parent item not ok blocks running
- ((and waiton-is-completed
- (or waiton-is-ok
- (member 'toplevel mode)) ;; toplevel does not block on FAIL
- (and waiton-is-ok (member 'itemmatch mode) ;; itemmatch blocks on not ok ;; TODO: THIS IS PROBABLY A BUG. ITEMMATCH AND ITEMWAIT ARE SYNONYMS!! WHAT HAPPENED OT ITEMWAIT???
- ))
- ;;(BB> "cond4")
- (set! item-waiton-met #t))
- ((and waiton-is-completed waiton-is-ok same-itempath)
- ;;(BB> "cond5")
- (set! item-waiton-met #t))
- ((and waiton-is-completed waiton-is-ok test-and-ref-are-same) ;; probably from [waitons] table
- (set! item-waiton-met #t))
- (else
- #t
- ;;(BB> "condelse")
- ))))
- waiton-tests)
- ;; both requirements, parent and item-waiton must be met to NOT add item to
- ;; prereq's not met list
- ;; (BB>
- ;; "\n* waiton-tests "waiton-tests
- ;; "\n* parent-waiton-met "parent-waiton-met
- ;; "\n* item-waiton-met "item-waiton-met
- ;; "\n* ever-seen "ever-seen
- ;; "\n* ref-test-itemized-mode "ref-test-itemized-mode
- ;; "\n* unmet-prereq-items "unmet-prereq-items
- ;; "\n* result (pre) "result
- ;; "\n* ever-seen "ever-seen
- ;; "\n")
-
- (cond
- ((and ref-test-itemized-mode ref-test-is-item (not (null? unmet-prereq-items)))
- (set! result (append unmet-prereq-items result)))
- ((not (or parent-waiton-met item-waiton-met))
- (set! result (append (if (null? waiton-tests) (list waitontest-name) waiton-tests) result))) ;; appends the string if the full record is not available
- ;; if the test is not found then clearly the waiton is not met...
- ;; (if (not ever-seen)(set! result (cons waitontest-name result)))))
- ((not ever-seen)
- (set! result (append (if (null? waiton-tests)(list waitontest-name) waiton-tests) result))))))
- waitons)
- (delete-duplicates result)))))
-
-;;======================================================================
-;; To sync individual run
-;;======================================================================
-(define (db:get-run-record-ids dbstruct target run keynames)
- (let* ((backcons (lambda (lst item)(cons item lst)))
- (all_tests '())
- (keystr (string-intersperse
- (map (lambda (key val)
- (conc key " like '" val "'"))
- keynames
- (string-split target "/"))
- " AND ")
- )
- (run-qry (conc "SELECT id FROM runs WHERE " keystr " and runname='" run"'"))
- ; (test-qry (conc "SELECT id FROM tests WHERE run_id in (" run-qry ") and testname like '" test-patt "'"))
- (run_ids
- (db:with-db dbstruct #f #f
- (lambda (dbdat db)
- (sqlite3:fold-row backcons '() db run-qry))
- )
- )
- )
- run_ids)
-)
-
-;;======================================================================
-;; Just for sync, procedures to make sync easy
-;;======================================================================
-
-;; get an alist of run ids and test/run, test_step/run pairs changed since time since-time
-;; '((runs . (1 2 3 ...))(tests . ((5 . 1) (6 . 3) (6 . 2) (7 . 1) ...
-
-;; Retrieves record IDs from the database based on the timestamp of their last update.
-
-;; The function takes two arguments: dbstruct, which represents the database structure, and since-time, which is a timestamp indicating the time of the last update.
-;; The function first defines a few helper functions, including backcons, which takes a list and an item and adds the item to the front of the list.
-;; It then initializes several variables to empty lists: all_tests, all_test_steps, all_test_data, all_run_ids, and all_test_ids.
-;; The function then retrieves a list of IDs for runs that have been changed since since-time using the db:get-changed-run-ids function.
-;; It then filters the full list of run IDs to only include those that match the changed run IDs based on their modulo (num-run-dbs).
-;; For each changed run ID, the function retrieves a list of test IDs, test step IDs, and test data IDs that have been updated since since-time.
-;; It appends these IDs to the appropriate lists (all_tests, all_test_steps, and all_test_data) using the append and map functions.
-;; The function then retrieves a list of run stat IDs that have been updated since since-time.
-;; Finally, the function returns a list of associations between record types and their corresponding IDs: runs, tests, test_steps, test_data, and run_stats.
-;;
-(define (db:get-changed-record-ids dbstruct since-time)
- ;; no transaction, allow the db to be accessed between the big queries
- (let* ((backcons (lambda (lst item)(cons item lst)))
- (all_tests '())
- (changed_run_dbs (db:get-changed-run-ids since-time)) ;; gets the rundb numbers
- (all_run_ids
- (db:with-db dbstruct #f #f
- (lambda (dbdat db)
- (sqlite3:fold-row backcons '() db "SELECT id FROM runs"))
- )
- )
- (changed_run_ids (filter (lambda (run) (member (modulo run (num-run-dbs)) changed_run_dbs)) all_run_ids))
- (run_ids
- (db:with-db dbstruct #f #f
- (lambda (dbdat db)
- (sqlite3:fold-row backcons '() db "SELECT id FROM runs WHERE last_update>=?" since-time))
- )
- )
- )
- (for-each
- (lambda (run_id)
- (set! all_tests
- (append
- (map (lambda (x) (cons x run_id))
- (db:with-db dbstruct run_id #f
- (lambda (dbdat db)
- (sqlite3:fold-row backcons '() db "SELECT id FROM tests WHERE run_id=? and last_update>=?" run_id since-time)
- )
- )
- ) all_tests
- )
- )
- )
- changed_run_ids
- )
- (debug:print 2 *default-log-port* "run_ids = " run_ids)
- (debug:print 2 *default-log-port* "all_tests = " all_tests)
-
- `((runs . ,run_ids)
- (tests . ,all_tests)
- )
- )
-)
-
-
-
-(define (db:get-changed-record-test-ids dbstruct since-time run-id)
- (let* ((backcons (lambda (lst item)(cons item lst)))
- (all-tests (db:with-db dbstruct run-id #f
- (lambda (dbdat db)
- (sqlite3:fold-row backcons '() db "SELECT id FROM tests WHERE run_id=? and last_update>=?" run-id since-time)))))
-
- all-tests))
-
-(define (db:get-changed-record-run-ids dbstruct since-time)
- ;; no transaction, allow the db to be accessed between the big queries
- (let* ((backcons (lambda (lst item)(cons item lst)))
- (run_ids (db:with-db dbstruct #f #f
- (lambda (dbdat db)
- (sqlite3:fold-row backcons '() db "SELECT id FROM runs WHERE last_update>=?" since-time)))))
- (debug:print 2 *default-log-port* "run_ids = " run_ids)
- run_ids)
-)
-
-(define (db:get-all-runids dbstruct)
- (let* ((backcons (lambda (lst item)(cons item lst)))
- (all_run_ids (db:with-db dbstruct #f #f
- (lambda (dbdat db)
- (sqlite3:fold-row backcons '() db "SELECT id FROM runs")))))
-
-all_run_ids))
-
-;;======================================================================
-;; Extract ods file from the db
-;;======================================================================
-
-;; NOT REWRITTEN YET!!!!!
-
-;; runspatt is a comma delimited list of run patterns
-;; keypatt-alist must contain *all* keys with an associated pattern: '( ("KEY1" "%") .. )
-(define (db:extract-ods-file dbstruct outputfile keypatt-alist runspatt pathmod)
- (assert #f "FATAL: call to db:extract-ods-file which is not ported yet.")
- (let* ((keysstr (string-intersperse (map car keypatt-alist) ","))
- (keyqry (string-intersperse (map (lambda (p)(conc (car p) " LIKE ? ")) keypatt-alist) " AND "))
- (numkeys (length keypatt-alist))
- (test-ids '())
- (dbdat (db:get-subdb dbstruct))
- (db (dbr:dbdat-dbh dbdat))
- (windows (and pathmod (substring-index "\\" pathmod)))
- (tempdir (conc "/tmp/" (current-user-name) "/" runspatt "_" (random 10000) "_" (current-process-id)))
- (runsheader (append (list "Run Id" "Runname") ; 0 1
- (map car keypatt-alist) ; + N = length keypatt-alist
- (list "Testname" ; 2
- "Item Path" ; 3
- "Description" ; 4
- "State" ; 5
- "Status" ; 6
- "Final Log" ; 7
- "Run Duration" ; 8
- "When Run" ; 9
- "Tags" ; 10
- "Run Owner" ; 11
- "Comment" ; 12
- "Author" ; 13
- "Test Owner" ; 14
- "Reviewed" ; 15
- "Diskfree" ; 16
- "Uname" ; 17
- "Rundir" ; 18
- "Host" ; 19
- "Cpu Load" ; 20
- )))
- (results (list runsheader))
- (testdata-header (list "Run Id" "Testname" "Item Path" "Category" "Variable" "Value" "Expected" "Tol" "Units" "Status" "Comment"))
- (mainqry (conc "SELECT
- t.testname,r.id,runname," keysstr ",t.testname,
- t.item_path,tm.description,t.state,t.status,
- final_logf,run_duration,
- strftime('%m/%d/%Y %H:%M:%S',datetime(t.event_time,'unixepoch'),'localtime'),
- tm.tags,r.owner,t.comment,
- author,
- tm.owner,reviewed,
- diskfree,uname,rundir,
- host,cpuload
- FROM tests AS t JOIN runs AS r ON t.run_id=r.id JOIN test_meta AS tm ON tm.testname=t.testname
- WHERE runname LIKE ? AND " keyqry ";")))
- (debug:print 2 *default-log-port* "Using " tempdir " for constructing the ods file. keyqry: " keyqry " keystr: " keysstr " with keys: " (map cadr keypatt-alist)
- "\n mainqry: " mainqry)
- ;; "Expected Value"
- ;; "Value Found"
- ;; "Tolerance"
- (apply sqlite3:for-each-row
- (lambda (test-id . b)
- (set! test-ids (cons test-id test-ids)) ;; test-id is now testname
- (set! results (append results ;; note, drop the test-id
- (list
- (if pathmod
- (let* ((vb (apply vector b))
- (keyvals (let loop ((i 0)
- (res '()))
- (if (>= i numkeys)
- res
- (loop (+ i 1)
- (append res (list (vector-ref vb (+ i 2))))))))
- (runname (vector-ref vb 1))
- (testname (vector-ref vb (+ 2 numkeys)))
- (item-path (vector-ref vb (+ 3 numkeys)))
- (final-log (vector-ref vb (+ 7 numkeys)))
- (run-dir (vector-ref vb (+ 18 numkeys)))
- (log-fpath (conc run-dir "/" final-log))) ;; (string-intersperse keyvals "/") "/" testname "/" item-path "/"
- (debug:print 4 *default-log-port* "log: " log-fpath " exists: " (common:file-exists? log-fpath))
- (vector-set! vb (+ 7 numkeys) (if (common:file-exists? log-fpath)
- (let ((newpath (conc pathmod "/"
- (string-intersperse keyvals "/")
- "/" runname "/" testname "/"
- (if (string=? item-path "") "" (conc "/" item-path))
- final-log)))
- ;; for now throw away newpath and use the log-fpath conc'd with pathmod
- (set! newpath (conc pathmod log-fpath))
- (if windows (string-translate newpath "/" "\\") newpath))
- (if (debug:debug-mode 1)
- (conc final-log " not-found")
- "")))
- (vector->list vb))
- b)))))
- db
- mainqry
- runspatt (map cadr keypatt-alist))
- (debug:print 2 *default-log-port* "Found " (length test-ids) " records")
- (set! results (list (cons "Runs" results)))
- ;; now, for each test, collect the test_data info and add a new sheet
- (for-each
- (lambda (test-id)
- (let ((test-data (list testdata-header))
- (curr-test-name #f))
- (sqlite3:for-each-row
- (lambda (run-id testname item-path category variable value expected tol units status comment)
- (set! curr-test-name testname)
- (set! test-data (append test-data (list (list run-id testname item-path category variable value expected tol units status comment)))))
- db
- ;; "SELECT run_id,testname,item_path,category,variable,td.value AS value,expected,tol,units,td.status AS status,td.comment AS comment FROM test_data AS td INNER JOIN tests ON tests.id=td.test_id WHERE test_id=?;"
- "SELECT run_id,testname,item_path,category,variable,td.value AS value,td.expected,td.tol,td.units,td.status AS status,td.comment AS comment FROM test_data AS td INNER JOIN tests ON tests.id=td.test_id WHERE testname=?;"
- test-id)
- (if curr-test-name
- (set! results (append results (list (cons curr-test-name test-data)))))
- ))
- (sort (delete-duplicates test-ids) string<=))
- (system (conc "mkdir -p " tempdir))
- ;; (pp results)
- (ods:list->ods
- tempdir
- (if (string-match (regexp "^[/~]+.*") outputfile) ;; full path?
- outputfile
- (begin
- (debug:print 0 *default-log-port* "WARNING: path given, " outputfile " is relative, prefixing with current directory")
- (conc (current-directory) "/" outputfile)))
- results)
- ;; brutal clean up
- (dbfile:add-dbdat dbstruct #f dbdat)
- (system "rm -rf tempdir")))
-
-;; (db:extract-ods-file db "outputfile.ods" '(("sysname" "%")("fsname" "%")("datapath" "%")) "%")
-
-;;======================================================================
-;; moving watch dogs here due to dependencies
-;;======================================================================
-
-;;======================================================================
-;; currently the primary job of the watchdog is to run the sync back to megatest.db from the db in /tmp
-;; if we are on the homehost and we are a server (by definition we are on the homehost if we are a server)
-;;
-(define (common:readonly-watchdog dbstruct)
- (thread-sleep! 0.05) ;; delay for startup
- (debug:print-info 13 *default-log-port* "common:readonly-watchdog entered.")
- ;; sync megatest.db to /tmp/.../megatst.db
- (let* ((sync-cool-off-duration 3)
- (golden-mtdb (dbr:dbstruct-mtdb dbstruct))
- (golden-mtpath (db:dbdat-get-path golden-mtdb))
- (tmp-mtdb (dbr:dbstruct-tmpdb dbstruct))
- (tmp-mtpath (db:dbdat-get-path tmp-mtdb)))
- (debug:print-info 0 *default-log-port* "Read-only periodic sync thread started.")
- (let loop ((last-sync-time 0))
- (debug:print-info 13 *default-log-port* "loop top tmp-mtpath="tmp-mtpath" golden-mtpath="golden-mtpath)
- (let* ((duration-since-last-sync (- (current-seconds) last-sync-time)))
- (debug:print-info 13 *default-log-port* "duration-since-last-sync="duration-since-last-sync)
- (if (and (not *time-to-exit*)
- (< duration-since-last-sync sync-cool-off-duration))
- (thread-sleep! (- sync-cool-off-duration duration-since-last-sync)))
- (if (not *time-to-exit*)
- (let ((golden-mtdb-mtime (file-modification-time golden-mtpath))
- (tmp-mtdb-mtime (file-modification-time tmp-mtpath)))
- (if (> golden-mtdb-mtime tmp-mtdb-mtime)
- (if (< golden-mtdb-mtime (- (current-seconds) 3)) ;; file has NOT been touched in past three seconds, this way multiple servers won't fight to sync back
- (let ((res (db:multi-db-sync dbstruct 'old2new)))
- (debug:print-info 13 *default-log-port* "rosync called, " res " records transferred."))))
- (loop (current-seconds)))
- #t)))
- (debug:print-info 0 *default-log-port* "Exiting readonly-watchdog timer, *time-to-exit* = " *time-to-exit*" pid="(current-process-id)" mtpath="golden-mtpath)))
-
-
-;; Get a lock from the no-sync-db for the from-db, then copy the from-db to the to-db, otherwise return #f
-
-(define (db:lock-and-sync no-sync-db from-db to-db)
- (assert (not *db-sync-in-progress*) "FATAL: db:lock-and-sync called while a sync is in progress.")
- (let* ((lockdat (db:no-sync-get-lock no-sync-db from-db))
- (gotlock (car lockdat))
- (locktime (cdr lockdat)))
- (if gotlock
- (begin
- (file-copy from-db to-db #t)
- (db:no-sync-del! no-sync-db from-db)
- #t)
- (begin
- (debug:print 0 *default-log-port* "could not get lock for " from-db " from no-sync-db")
- #f
- ))))
-
-;; sync for filesystem local db writes
-;;
-(define (db:run-lock-and-sync no-sync-db)
- (let* ((tmp-area (common:make-tmpdir-name *toppath* ""))
- (dbfiles (glob (conc tmp-area"/.mtdb/*.db")))
- (sync-durations (make-hash-table)))
- ;; (debug:print-info 0 *default-log-port* "lock-and-sync, dbfiles: "dbfiles)
- (for-each
- (lambda (file)
- (let* ((fname (conc (pathname-file file) ".db"))
- (fulln (conc *toppath*"/.mtdb/"fname))
- (time1 (if (file-exists? file)
- (file-modification-time file)
- (begin
- (debug:print-info 0 *default-log-port* "Sync - I do not see file "file)
- 1)))
- (time2 (if (file-exists? fulln)
- (file-modification-time fulln)
- (begin
- (debug:print-info 0 *default-log-port* "Sync - I do not see file "fulln)
- 0)))
- (changed (> time1 time2))
- (do-cp (cond
- ((not (file-exists? fulln)) ;; shouldn't happen, but this might recover
- (debug:print-info 0 *default-log-port* "File "fulln" not found! Copying "fname" to "fulln)
- #t)
- (changed ;; (and changed
- ;; (> (- (current-seconds) time1) 3)) ;; if file is changed and three seconds have passed.
- #t)
- ((and changed *time-to-exit*) ;; last copy
- #t)
- (else
- #f))))
- (if do-cp
- (let* ((start-time (current-milliseconds)))
- (debug:print-info 0 *default-log-port* "sync copy file: " fname", delta: " (- time1 time2) " seconds")
- (db:lock-and-sync no-sync-db file fulln)
- (hash-table-set! sync-durations (conc fname".db") (- (current-milliseconds) start-time)))
- #;(debug:print-info 0 *default-log-port* "skipping sync..."))))
- dbfiles)
- (hash-table->alist sync-durations)))
-
-;; straight forward copy based sync
-;; 1. for each .db fil
-;; 2. next if file changed since last sync cycle
-;; 2. next if time delta /tmp file to MTRA less than 3 seconds
-;; 3. get a lock for the file in nosyncdb
-;; 4. copy the file
-;; 5. when copy is done release the lock
-;;
-;; DONE
-(define (server:writable-watchdog-copysync dbstruct)
- (thread-sleep! 0.05) ;; delay for startup
- (let ((legacy-sync (common:run-sync?))
- (sync-stale-seconds (configf:lookup-number *configdat* "server" "sync-stale-seconds" default: 300))
- (debug-mode (debug:debug-mode 1))
- (last-time (current-seconds)) ;; last time through the sync loop
- (no-sync-db (db:open-no-sync-db))
- (sync-duration 0) ;; run time of the sync in milliseconds
- (tmp-area (common:make-tmpdir-name *toppath* "")))
- ;; Sync moved to http-transport keep-running loop
- (debug:print-info 2 *default-log-port* "Periodic copy-based sync thread started. syncer is copy-sync, tmp-area is " tmp-area)
- (debug:print-info 3 *default-log-port* "watchdog starting. syncer is copy-sync pid="(current-process-id));; " this-wd-num="this-wd-num)
-
- (if (and legacy-sync (not *time-to-exit*))
- (begin
- (debug:print-info 0 *default-log-port* "Server running, periodic copy-based sync started.")
- (let loop ()
-
- ;; run the sync and print out durations
- (debug:print-info 0 *default-log-port* "Sync durations: "(db:run-lock-and-sync no-sync-db))
- ;; keep going unless time to exit
- ;;
- (if (not *time-to-exit*)
- (let delay-loop ((count 0))
- ;;(debug:print-info 13 *default-log-port* "delay-loop top; count="count" pid="(current-process-id)" this-wd-num="this-wd-num" *time-to-exit*="*time-to-exit*)
-
- (if (and (not *time-to-exit*)
- (< count 6)) ;; was 11, changing to 4.
- (begin
- (thread-sleep! 1)
- (delay-loop (+ count 1))))
- (if (not *time-to-exit*) (loop))))
-
- ;; ==> ;; time to exit, close the no-sync db here
- ;; ==> (db:no-sync-close-db no-sync-db stmt-cache)
- (if (common:low-noise-print 30)
- (debug:print-info 0 *default-log-port* "Exiting watchdog timer, *time-to-exit* = "
- *time-to-exit*" pid="(current-process-id) )))))))
-
-(define (server:writable-watchdog-deltasync dbstruct)
- ;; This is awful complex and convoluted. Plan to redo?
- ;; for now ... skip it.
-
- (thread-sleep! 0.05) ;; delay for startup
- (let ((legacy-sync (common:run-sync?)))
- (sync-stale-seconds (configf:lookup-number *configdat* "server" "sync-stale-seconds" default: 300))
- (debug-mode (debug:debug-mode 1))
- (last-time (current-seconds))
- (no-sync-db (db:open-no-sync-db))
- (stmt-cache #f) ;; (dbr:dbstruct-stmt-cache dbstruct))
- (sync-duration 0) ;; run time of the sync in milliseconds
- (subdbs (hash-table-values (dbr:dbstruct-subdbs dbstruct))))
- (debug:print-info 2 *default-log-port* "Periodic sync thread started.")
- (debug:print-info 3 *default-log-port* "watchdog starting. legacy-sync is " legacy-sync" pid="(current-process-id) );; " this-wd-num="this-wd-num)
-
- (if (and legacy-sync (not *time-to-exit*))
- (begin
- (debug:print-info 0 *default-log-port* "Server running, periodic sync started.")
- (let loop ()
- ;; sync for filesystem local db writes
- ;;
- (mutex-lock! *db-multi-sync-mutex*)
- (let* ((start-file (conc tmp-area "/.start-sync"))
- (end-file (conc tmp-area "/.end-sync"))
-
- (need-sync (>= *db-last-access* *db-last-sync*)) ;; no sync since last write
- (sync-in-progress *db-sync-in-progress*)
- (min-intersync-delay (configf:lookup-number *configdat* "server" "minimum-intersync-delay" default: 5))
- (should-sync (and (not *time-to-exit*)
- (> (- (current-seconds) *db-last-sync*) min-intersync-delay))) ;; sync every five seconds minimum, deprecated logic, can probably be removed
- (start-time (current-seconds))
- (cpu-load-adj (alist-ref 'adj-proc-load (common:get-normalized-cpu-load #f)))
- (mt-mod-time (file-modification-time mtpath))
- (last-sync-start (if (common:file-exists? start-file)
- (file-modification-time start-file)
- 0))
- (last-sync-end (if (common:file-exists? end-file)
- (file-modification-time end-file)
- 10))
- (sync-period (+ 3 (* cpu-load-adj 30))) ;; as adjusted load increases increase the sync period
- (recently-synced (and (< (- start-time mt-mod-time) sync-period) ;; not useful if sync didn't modify megatest.db!
- (< mt-mod-time last-sync-start)))
- (sync-done (<= last-sync-start last-sync-end))
- (sync-stale (> start-time (+ last-sync-start sync-stale-seconds)))
- (will-sync (and (not *time-to-exit*) ;; do not start a sync if we are in the process of exiting
- (or need-sync should-sync)
- (or sync-done sync-stale)
- (not sync-in-progress)
- (not recently-synced))))
- (debug:print-info 13 *default-log-port* "WD writable-watchdog top of loop. need-sync="need-sync" sync-in-progress=" sync-in-progress
- " should-sync="should-sync" start-time="start-time" mt-mod-time="mt-mod-time" recently-synced="recently-synced" will-sync="will-sync
- " sync-done=" sync-done " sync-period=" sync-period)
- (if (and (> sync-period 5)
- (common:low-noise-print 30 "sync-period"))
- (debug:print-info 0 *default-log-port* "Increased sync period due to long sync times, sync took: " sync-period " seconds."))
- ;; (if recently-synced (debug:print-info 0 *default-log-port* "Skipping sync due to recently-synced flag=" recently-synced))
- ;; (debug:print-info 0 *default-log-port* "need-sync: " need-sync " sync-in-progress: " sync-in-progress " should-sync: " should-sync " will-sync: " will-sync)
- (if will-sync (set! *db-sync-in-progress* #t))
- (mutex-unlock! *db-multi-sync-mutex*)
- (if will-sync
- (let (;; (max-sync-duration (configf:lookup-number *configdat* "server" "max-sync-duration")) ;; KEEPING THIS AVAILABLE BUT SHOULD NOT USE, I'M PRETTY SURE IT DOES NOT WORK!
- (sync-start (current-milliseconds)))
- (with-output-to-file start-file (lambda ()(print (current-process-id))))
-
- ;; put lock here
-
- ;; (if (or (not max-sync-duration)
- ;; (< sync-duration max-sync-duration)) ;; NOTE: db:sync-to-megatest.db keeps track of time of last sync and syncs incrementally
-
- ;;
-
- (for-each
- (lambda (subdb)
- (let* (;;(dbstruct (db:setup))
- (mtdb (dbr:subdb-mtdb subdb))
- (mtpath (db:dbdat-get-path mtdb))
- (tmp-area (common:make-tmpdir-name *toppath* ""))
- (res (db:sync-to-megatest.db dbstruct no-sync-db: no-sync-db))) ;; did we sync any data? If so need to set the db touched flag to keep the server alive
- (set! sync-duration (- (current-milliseconds) sync-start))
- (if (> res 0) ;; some records were transferred, keep the db alive
- (begin
- (mutex-lock! *heartbeat-mutex*)
- (set! *db-last-access* (current-seconds))
- (mutex-unlock! *heartbeat-mutex*)
- (debug:print-info 0 *default-log-port* "sync called, " res " records transferred."))
- (debug:print-info 2 *default-log-port* "sync called but zero records transferred")))
- )
- subdbs)))
-
- (if will-sync
- (begin
- (mutex-lock! *db-multi-sync-mutex*)
- (set! *db-sync-in-progress* #f)
- (set! *db-last-sync* start-time)
- (with-output-to-file end-file (lambda ()(print (current-process-id))))
-
- ;; release lock here
-
- (mutex-unlock! *db-multi-sync-mutex*)))
- (if (and debug-mode
- (> (- start-time last-time) 60))
- (begin
- (set! last-time start-time)
- (debug:print-info 4 *default-log-port* "timestamp -> " (seconds->time-string (current-seconds)) ", time since start -> " (seconds->hr-min-sec (- (current-seconds) *time-zero*))))))
-
- ;; keep going unless time to exit
- ;;
- (if (not *time-to-exit*)
- (let delay-loop ((count 0))
- ;;(debug:print-info 13 *default-log-port* "delay-loop top; count="count" pid="(current-process-id)" this-wd-num="this-wd-num" *time-to-exit*="*time-to-exit*)
-
- (if (and (not *time-to-exit*)
- (< count 6)) ;; was 11, changing to 4.
- (begin
- (thread-sleep! 1)
- (delay-loop (+ count 1))))
- (if (not *time-to-exit*) (loop))))
-
-;; ;; time to exit, close the no-sync db here
-;; (db:no-sync-close-db no-sync-db stmt-cache)
- (if (common:low-noise-print 30)
- (debug:print-info 0 *default-log-port* "Exiting watchdog timer, *time-to-exit* = " *time-to-exit*" pid="(current-process-id) ))))
-))
-
-(define (std-exit-procedure)
- ;;(common:telemetry-log-close)
- (on-exit (lambda () 0)) ;; why is this here?
- ;;(debug:print-info 13 *default-log-port* "std-exit-procedure called; *time-to-exit*="*time-to-exit*)
- (let ((no-hurry (if *time-to-exit* ;; hurry up
- #f
- (begin
- (set! *time-to-exit* #t)
- #t))))
- (debug:print-info 4 *default-log-port* "starting exit process, finalizing databases.")
- (if (and no-hurry
- (debug:debug-mode 18))
- (dbmod:print-db-stats))
- (let ((th1 (make-thread (lambda () ;; thread for cleaning up, give it five seconds
- (if *dbstruct-dbs* (db:close-all *dbstruct-dbs*)) ;; one second allocated
- (if (list? *on-exit-procs*)
- (for-each
- (lambda (proc)
- (proc))
- *on-exit-procs*))
- (if *task-db*
- (let ((db (cdr *task-db*)))
- (if (sqlite3:database? db)
- (begin
- (sqlite3:interrupt! db)
- (sqlite3:finalize! db #t)
- ;; (vector-set! *task-db* 0 #f)
- (set! *task-db* #f)))))
- (if (and *no-sync-db*
- (sqlite3:database? *no-sync-db*))
- (sqlite3:finalize! *no-sync-db* #t))
- (if (and (not (args:get-arg "-server"))
- *runremote*
- (eq? (rmt:transport-mode) 'http))
- (begin
- (debug:print-info 0 *default-log-port* "Closing all client connections...")
- (http-transport:close-connections *runremote*)
- #;(http-client#close-all-connections!)))
- ;; (if (and *runremote*
- ;; (remote-conndat *runremote*))
- ;; (begin
- ;; (http-client#close-all-connections!))) ;; for http-client
- (if (not (eq? *default-log-port* (current-error-port)))
- (close-output-port *default-log-port*))
- (set! *default-log-port* (current-error-port))) "Cleanup db exit thread"))
- (th2 (make-thread (lambda ()
- (debug:print 4 *default-log-port* "Attempting clean exit. Please be patient and wait a few seconds...")
- (if no-hurry
- (begin
- (thread-sleep! 5)) ;; give the clean up few seconds to do it's stuff
- (begin
- (thread-sleep! 2)))
- (debug:print 4 *default-log-port* " ... done")
- )
- "clean exit")))
- (thread-start! th1)
- (thread-start! th2)
- (thread-join! th1)
- )
- )
-
- 0)
-
Index: dbmod.scm
==================================================================
--- dbmod.scm
+++ dbmod.scm
@@ -22,10 +22,11 @@
(declare (unit dbmod))
(declare (uses dbfile))
(declare (uses commonmod))
(declare (uses configfmod))
(declare (uses debugprint))
+(declare (uses mtargs))
(module dbmod
*
(import scheme)
@@ -32,13 +33,16 @@
(cond-expand
(chicken-4
(import chicken
data-structures
+ srfi-13
+
+ debugprint
extras
files
-
+ (prefix mtargs args:)
posix
))
(chicken-5
(import chicken.base
@@ -57,19 +61,28 @@
(import format
(prefix sqlite3 sqlite3:)
matchable
typed-records
+ regex
srfi-1
srfi-18
srfi-69
commonmod
configfmod
dbfile
debugprint)
+(include "common_records.scm")
+(include "db_records.scm")
+(include "key_records.scm")
+(include "run_records.scm")
+
+(define *number-of-writes* 0)
+(define *number-non-write-queries* 0)
+
;; NOTE: This returns only the name "1.db", "main.db", not the path
;;
(define (dbmod:run-id->dbfname run-id)
(conc (dbfile:run-id->dbnum run-id)".db"))
@@ -680,12 +693,10 @@
(debug:print 0 *default-log-port* "Skipping sync of table "table" due to transaction in flight."))))
table-names)
(sqlite3:execute dbh1 "DETACH auxdb;"))))
-
-
;;======================================================================
;; Moved from dbfile
;;======================================================================
;; wait up to aprox n seconds for a journal to go away
@@ -931,53 +942,4526 @@
(let ((new-rec (make-dbstat)))
(hash-table-set! *db-stats* modified-cmd new-rec)
(set! rec new-rec)))
(dbstat-cnt-set! rec (+ (dbstat-cnt rec) 1))
(dbstat-tottime-set! rec (+ (dbstat-tottime rec) delta))))
-
-
-
-)
-
-
-;; ATTIC
-
- #;(let* ((syncer-logfile (conc areapath"/logs/"dbfname"-syncer.log"))
- (sync-cmd (if (eq? syncdir 'todisk)
- (conc "(NBFAKE_LOG="syncer-logfile" nbfake megatest -db2db -from "tmpdb" -to "dbfullname" -period 5 -timeout 10 > /dev/null 2&>1)&")
- (conc "(NBFAKE_LOG="syncer-logfile" nbfake megatest -db2db -from "dbfullname" -to "tmpdb" -period 5 -timeout 10 > /dev/null 2&>1)&")))
- (synclock-file (conc dbfullname".lock"))
- (syncer-running-file (conc dbfullname"-sync-running"))
- (synclock-mod-time (if (file-exists? synclock-file)
- (handle-exceptions
- exn
- #f
- (file-modification-time synclock-file))
- #f))
- (thethread (lambda ()
- (thread-start!
- (make-thread
- (lambda ()
- (set! *sync-in-progress* #t)
- (debug:print-info "Running "sync-cmd)
- (if (file-exists? syncer-running-file)
- (debug:print-info 0 *default-log-port* "Syncer still running, skipping syncer start.")
- (system sync-cmd))
- (set! *sync-in-progress* #f)))))))
- (if ((if (eq? syncdir 'todisk) < >) ;; use less than for todisk, greater than for from disk
- (file-modification-time tmpdb)
- (file-modification-time dbfullname))
- (debug:print 4 *default-log-port* "Skipping sync, "tmpdb" older than "dbfullname)
- (if synclock-mod-time
- (if (> (- (current-seconds) synclock-mod-time) 20) ;; something wrong with sync, remove file
- (begin
- (handle-exceptions
- exn
- #f
- (begin
- (debug:print 0 *default-log-port* "Sync lock file " synclock-file "is older than 20 seconds (" synclock-mod-time " seconds). Removing it")
- (delete-file synclock-file)
- )
- )
- (thethread))
- (debug:print 0 *default-log-port* "Skipping sync, lockfile "synclock-file" found."))
- (thethread))))
+
+;; record for keeping state,status and count for doing roll-ups in
+;; iterated tests
+;;
+(defstruct dbr:counts
+ (state #f)
+ (status #f)
+ (count 0))
+
+;; (define (db:with-db dbstruct run-id r/w proc . params)
+;; (case (rmt:transport-mode)
+;; ((http)(dbfile:with-db dbstruct run-id r/w proc params))
+;; ((tcp) (dbmod:with-db dbstruct run-id r/w proc params))
+;; ((nfs) (dbmod:with-db dbstruct run-id r/w proc params))
+;; (else (assert #f "FATAL: db:with-db called with non-existant transport mode"))))
+
+;;======================================================================
+;; hash of hashs
+;;======================================================================
+
+
+(define (db:hoh-set! dat key1 key2 val)
+ (let* ((subhash (hash-table-ref/default dat key1 #f)))
+ (if subhash
+ (hash-table-set! subhash key2 val)
+ (begin
+ (hash-table-set! dat key1 (make-hash-table))
+ (db:hoh-set! dat key1 key2 val)))))
+
+(define (db:hoh-get dat key1 key2)
+ (let* ((subhash (hash-table-ref/default dat key1 #f)))
+ (and subhash
+ (hash-table-ref/default subhash key2 #f))))
+
+;;======================================================================
+;; SQLITE3 HELPERS
+;;======================================================================
+
+(define (db:general-sqlite-error-dump exn stmt . params)
+ (let ((err-status ((condition-property-accessor 'sqlite3 'status #f) exn))) ;; RADT ... how does this work?
+ ;; check for (exn sqlite3) ((condition-property-accessor 'exn 'message) exn)
+ ;; (print "err-status: " err-status)
+ (debug:print-error 0 *default-log-port* " query " stmt " failed, params: " params ", error: " ((condition-property-accessor 'exn 'message) exn))
+ (print-call-chain (current-error-port))))
+
+;; convert to -inline
+;;
+(define (db:first-result-default db stmt default . params)
+ (handle-exceptions
+ exn
+ (let ((err-status ((condition-property-accessor 'sqlite3 'status #f) exn)))
+ ;; check for (exn sqlite3) ((condition-property-accessor 'exn 'message) exn)
+ (if (eq? err-status 'done)
+ default
+ (begin
+ (debug:print-error 0 *default-log-port* " query " stmt " failed, params: " params ", error: " ((condition-property-accessor 'exn 'message) exn) ", exn=" exn)
+ (print-call-chain (current-error-port))
+ default)))
+ (apply sqlite3:first-result db stmt params)))
+
+(define (db:setup)
+ (assert *toppath* "FATAL: db:setup called before launch:setup has been run.")
+ (let* ((tmpdir (common:make-tmpdir-name *toppath* "")))
+ (if (not *dbstruct-dbs*)
+ (dbfile:setup (conc *toppath* "/.mtdb") tmpdir)
+ *dbstruct-dbs*)))
+
+;; moved from dbfile
+;;
+;; ADD run-id SUPPORT
+;;
+(define (db:create-all-triggers dbstruct)
+ (db:with-db
+ dbstruct #f #t
+ (lambda (dbdat db)
+ (db:create-triggers db))))
+
+(define (db:create-triggers db)
+ (for-each (lambda (key)
+ (sqlite3:execute db (cadr key)))
+ db:trigger-list))
+
+(define (db:drop-all-triggers dbstruct)
+ (db:with-db
+ dbstruct #f #t
+ (lambda (dbdat db)
+ (db:drop-triggers db))))
+
+(define (db:have-incompletes? dbstruct run-id ovr-deadtime)
+ (let* ((incompleted '())
+ (oldlaunched '())
+ (toplevels '())
+ ;; (deadtime-str (configf:lookup *configdat* "setup" "deadtime"))
+ (deadtime (or ovr-deadtime 72000))) ;; twenty hours
+ (db:with-db
+ dbstruct run-id #f
+ (lambda (dbdat db)
+
+ ;; in RUNNING or REMOTEHOSTSTART for more than 10 minutes
+ ;;
+ ;; HOWEVER: this code in run:test seems to work fine
+ ;; (> (- (current-seconds)(+ (db:test-get-event_time testdat)
+ ;; (db:test-get-run_duration testdat)))
+ ;; 600)
+ ;; (db:delay-if-busy dbdat)
+ (sqlite3:for-each-row
+ (lambda (test-id run-dir uname testname item-path)
+ (if (and (equal? uname "n/a")
+ (equal? item-path "")) ;; this is a toplevel test
+ ;; what to do with toplevel? call rollup?
+ (begin
+ (set! toplevels (cons (list test-id run-dir uname testname item-path run-id) toplevels)))
+ ;; (print-info "Found old toplevel test in RUNNING state, test-id=" test-id))
+ (set! incompleted (cons (list test-id run-dir uname testname item-path run-id) incompleted))))
+ (db:get-cache-stmth dbdat db
+ "SELECT id,rundir,uname,testname,item_path FROM tests WHERE run_id=? AND (strftime('%s','now') - event_time) > (run_duration + ?) AND state IN ('RUNNING','REMOTEHOSTSTART');")
+ run-id deadtime)
+
+ ;; in LAUNCHED for more than one day. Could be long due to job queues TODO/BUG: Need override for this in config
+ ;;
+ ;; (db:delay-if-busy dbdat)
+ (sqlite3:for-each-row
+ (lambda (test-id run-dir uname testname item-path)
+ (if (and (equal? uname "n/a")
+ (equal? item-path "")) ;; this is a toplevel test
+ ;; what to do with toplevel? call rollup?
+ (set! toplevels (cons (list test-id run-dir uname testname item-path run-id) toplevels))
+ (set! oldlaunched (cons (list test-id run-dir uname testname item-path run-id) oldlaunched))))
+ (db:get-cache-stmth dbdat db
+ "SELECT id,rundir,uname,testname,item_path FROM tests WHERE run_id=? AND (strftime('%s','now') - event_time) > 86400 AND state IN ('LAUNCHED');")
+ run-id)
+
+ ;; (print-info "Found " (length oldlaunched) " old LAUNCHED items, " (length toplevels) " old LAUNCHED toplevel tests and " (length incompleted) " tests marked RUNNING but apparently dead.")
+ (if (and (null? incompleted)
+ (null? oldlaunched)
+ (null? toplevels))
+ #f
+ #t)))))
+
+
+;; looks up subdb and returns it, if not found then set up
+;; and then return it.
+;;
+#;(define (db:get-db dbstruct run-id)
+ (let* ((res (dbfile:get-subdb dbstruct run-id)))
+ (if res
+ res
+ (let* ((newsubdb (make-dbr:subdb)))
+ (dbfile:set-subdb dbstruct run-id newsubdb)
+ (db:open-db dbstruct run-id areapath: (dbr:dbstruct-areapath dbstruct) do-sync: #t)
+ newsubdb))))
+
+;; Get/open a database
+;; if run-id => get run specific db
+;; if #f => get main db
+;; if run-id is a string treat it as a filename
+;; if db already open - return cachedb
+;; if db not open, open cachedb, rundb and sync then return cachedb
+;; inuse gets set automatically for rundb's
+;;
+;; (define db:get-db db:get-subdb)
+
+;; (define (db:get-db subdb #;dbstruct run-id) ;; RENAME TO db:get-dbh
+;; ;; (let* ((subdb (dbfile:get-subdb dbstruct run-id)))
+;; (if (stack? (dbr:subdb-dbstack subdb))
+;; (if (stack-empty? (dbr:subdb-dbstack subdb))
+;; (let* ((dbname (db:run-id->dbname run-id))
+;; (newdb (db:open-megatest-db path: (db:dbfile-path)
+;; name: dbname)))
+;; ;; NOTE: pushing on the stack only happens AFTER the handle has been used
+;; ;; (stack-push! (dbr:dbstruct-dbstack dbstruct) newdb)
+;; newdb)
+;; (stack-pop! (dbr:subdb-dbstack subdb)))
+;; (db:open-db subdb run-id))) ;; )
+
+
+#;(define (db:get-db dbstruct run-id)
+ (let* ((subdb (dbfile:get-subdb dbstruct run-id))
+ (dbdat (dbfile:get-dbdat dbstruct run-id)))
+ (if (dbr:dbdat? dbdat)
+ dbdat
+ (dbfile:open-db *dbstruct-dbs* #f db:initialize-main-db)
+ )
+ )
+)
+
+(define-inline (db:generic-error-printout exn . message)
+ (print-call-chain (current-error-port))
+ (apply debug:print-error 0 *default-log-port* message)
+ (debug:print-error 0 *default-log-port* " params: " params
+ ", error: " ((condition-property-accessor 'exn 'message) exn)
+ ", arguments: " ((condition-property-accessor 'exn 'arguments) exn)
+ ", location: " ((condition-property-accessor 'exn 'location) exn)
+ ))
+
+
+(define (db:set-sync db)
+ (let ((syncprag (configf:lookup *configdat* "setup" "sychronous")))
+ (sqlite3:execute db (conc "PRAGMA synchronous = " (or syncprag 0) ";"))))
+
+
+(define (db:get-last-update-time db)
+ (let ((last-update-time #f))
+ (sqlite3:for-each-row
+ (lambda (lup)
+ (set! last-update-time lup))
+ db
+ "select max(lup) from ( select max(last_update) as lup from tests union select max(last_update) as lup from runs);")
+ last-update-time))
+
+
+;; Open the classic megatest.db file (defaults to open in toppath)
+;;
+;; NOTE: returns a dbdat not a dbstruct!
+;;
+(define (db:open-megatest-db dbpath)
+ (let* ((dbexists (file-exists? dbpath))
+ (db (db:lock-create-open dbpath
+ (lambda (db)
+ (db:initialize-main-db db))))
+ (write-access (file-write-access? dbpath)))
+ (debug:print-info 13 *default-log-port* "db:open-megatest-db "dbpath)
+ (if (and dbexists (not write-access))
+ (set! *db-write-access* #f))
+ ;; (cons db dbpath)))
+ (make-dbr:dbdat dbfile: dbpath dbh: db read-only: (not write-access))))
+
+
+;; use bunch of Unix commands to try to break the lock and recreate the db
+;;
+(define (db:move-and-recreate-db dbdat)
+ (let* ((dbpath (dbr:dbdat-dbfile dbdat))
+ (dbdir (pathname-directory dbpath))
+ (fname (pathname-strip-directory dbpath))
+ (fnamejnl (conc fname "-journal"))
+ (tmpname (conc fname "." (current-process-id)))
+ (tmpjnl (conc fnamejnl "." (current-process-id))))
+ (debug:print-error 0 *default-log-port* "" fname " appears corrupted. Making backup \"old/" fname "\"")
+ (system (conc "cd " dbdir ";mkdir -p old;cat " fname " > old/" tmpname))
+ (system (conc "rm -f " dbpath))
+ (if (common:file-exists? fnamejnl)
+ (begin
+ (debug:print-error 0 *default-log-port* "" fnamejnl " found, moving it to old dir as " tmpjnl)
+ (system (conc "cd " dbdir ";mkdir -p old;cat " fnamejnl " > old/" tmpjnl))
+ (system (conc "rm -f " dbdir "/" fnamejnl))))
+ ;; attempt to recreate database
+ (system (conc "cd " dbdir ";sqlite3 old/" tmpname " .dump | sqlite3 " fname))))
+
+;; return #f to indicate the dbdat should be closed/reopened
+;; else return dbdat
+;;
+(define (db:repair-db dbdat #!key (numtries 1))
+ (let* ((dbpath (dbr:dbdat-dbfile dbdat))
+ (dbdir (pathname-directory dbpath))
+ (fname (pathname-strip-directory dbpath)))
+ (debug:print-info 0 *default-log-port* "Checking db " dbpath " for errors.")
+ (cond
+ ((not (file-write-access? dbdir))
+ (debug:print 0 *default-log-port* "WARNING: can't write to " dbdir ", can't fix " fname)
+ #f)
+
+ ;; handle special cases, megatest.db and monitor.db
+ ;;
+ ;; NOPE: apply this same approach to all db files
+ ;;
+ (else ;; ((equal? fname "megatest.db") ;; this file can be regenerated if needed
+ (handle-exceptions
+ exn
+ (begin
+ (debug:print 0 *default-log-port* "Problems trying to repair the db, exn=" exn)
+ ;; (db:move-and-recreate-db dbdat)
+ (if (> numtries 0)
+ (db:repair-db dbdat numtries: (- numtries 1))
+ #f)
+ (debug:print 0 *default-log-port* "FATAL: file " dbpath " was found corrupted, an attempt to fix has been made but you must start over.")
+ (debug:print 0 *default-log-port*
+ " check the following:\n"
+ " 1. full directories, look in ~/ /tmp and " dbdir "\n"
+ " 2. write access to " dbdir "\n\n"
+ " if the automatic recovery failed you may be able to recover data by doing \""
+ (if (member fname '("megatest.db" "monitor.db"))
+ "megatest -cleanup-db"
+ "megatest -import-megatest.db;megatest -cleanup-db")
+ "\"\n")
+ (exit) ;; we can not safely continue when a db was corrupted - even if fixed.
+ )
+ ;; test read/write access to the database
+ (let ((db (sqlite3:open-database dbpath)))
+ (sqlite3:set-busy-handler! db (sqlite3:make-busy-timeout 136000))
+ (sqlite3:execute db "PRAGMA synchronous = 0;")
+ (cond
+ ((equal? fname "megatest.db")
+ (sqlite3:execute db "DELETE FROM tests WHERE state='DELETED';"))
+ ((equal? fname "main.db")
+ (sqlite3:execute db "DELETE FROM runs WHERE state='deleted';"))
+ ((string-match "\\d.db" fname)
+ (sqlite3:execute db "UPDATE tests SET state='DELETED' WHERE state='DELETED';"))
+ ((equal? fname "monitor.db")
+ (sqlite3:execute "DELETE FROM servers WHERE state LIKE 'defunct%';"))
+ (else
+ (sqlite3:execute db "vacuum;")))
+
+ (sqlite3:finalize! db)
+ #t))))))
+
+
+
+(define (db:adj-target db)
+ (let ((fields (configf:get-section *configdat* "fields"))
+ (field-num 0))
+ ;; because we will be refreshing the keys table it is best to clear it here
+ (sqlite3:execute db "DELETE FROM keys;")
+ (for-each
+ (lambda (field)
+ (let ((column (car field))
+ (spec (cadr field)))
+ (handle-exceptions
+ exn
+ (if (string-match ".*duplicate.*" ((condition-property-accessor 'exn 'message) exn))
+ (debug:print 0 *default-log-port* "Target field " column " already exists in the runs table")
+ (db:general-sqlite-error-dump exn "alter table runs ..." #f "none"))
+ ;; Add the column if needed
+ (sqlite3:execute
+ db
+ (conc "ALTER TABLE runs ADD COLUMN " column " " spec)))
+ ;; correct the entry in the keys column
+ (sqlite3:execute
+ db
+ "INSERT INTO keys (id,fieldname,fieldtype) VALUES (?,?,?);"
+ field-num column spec)
+ ;; fill in blanks (not allowed as it would be part of the path
+ (sqlite3:execute
+ db
+ (conc "UPDATE runs SET " column "='x' WHERE " column "='';"))
+ (set! field-num (+ field-num 1))))
+ fields)))
+
+(define *global-db-store* (make-hash-table))
+
+(define (db:get-access-mode)
+ (if (args:get-arg "-use-db-cache") 'cached 'rmt))
+
+;; Add db direct
+;;
+(define (db:dispatch-query access-mode rmt-cmd db-cmd . params)
+ (if (eq? access-mode 'cached)
+ (debug:print 2 *default-log-port* "not doing cached calls right now"))
+;; (apply db:call-with-cached-db db-cmd params)
+ (apply rmt-cmd params))
+;;)
+
+;; return the target db handle so it can be used
+;;
+(define (db:cache-for-read-only source target #!key (use-last-update #f))
+ (if (and (hash-table-ref/default *global-db-store* target #f)
+ (>= (file-modification-time target)(file-modification-time source)))
+ (hash-table-ref *global-db-store* target)
+ (let* ((toppath (launch:setup))
+ (targ-db-last-mod (db:get-sqlite3-mod-time target))
+;; (if (common:file-exists? target)
+;; BUG: This needs to include wal mode stuff .shm etc.
+;; (file-modification-time target)
+;; 0))
+ (cache-db (or (hash-table-ref/default *global-db-store* target #f)
+ (db:open-megatest-db path: target)))
+ (source-db (db:open-megatest-db path: source))
+ (curr-time (current-seconds))
+ (res '())
+ (last-update (if use-last-update (cons "last_update" targ-db-last-mod) #f)))
+ (db:sync-tables (db:sync-main-list source-db) last-update source-db cache-db)
+ (db:sync-tables db:sync-tests-only last-update source-db cache-db)
+ (hash-table-set! *global-db-store* target cache-db)
+ cache-db)))
+
+(define (db:get-sqlite3-mod-time fname)
+ (let* ((wal-file (conc fname "-wal"))
+ (shm-file (conc fname "-shm"))
+ (get-mtime (lambda (f)
+ (if (and (file-exists? f)
+ (file-read-access? f))
+ (file-modification-time f)
+ 0))))
+ (max (get-mtime fname)
+ (get-mtime wal-file)
+ (get-mtime shm-file))))
+
+;; (define (db:all-db-sync dbstruct)
+;; (let* ((dbdat (db:open-db dbstruct #f db:initialize-main-db))
+;; (data-synced 0) ;; count of changed records
+;; (tmp-area (common:make-tmpdir-name *toppath*))
+;; (dbfiles (glob (conc tmp-area"/.mtdb/*.db")))
+;; (sync-durations (make-hash-table))
+;; (no-sync-db (db:open-no-sync-db)))
+;; (for-each
+;; (lambda (file) ;; tmp db file
+;; (debug:print-info 3 *default-log-port* "file: " file)
+;; (let* ((fname (conc (pathname-file file) ".db")) ;; fname is tmp db file
+;; (wal-file (conc fname "-wal"))
+;; (shm-file (conc fname "-shm"))
+;; (fulln (conc *toppath*"/,mtdb/"fname)) ;; fulln is nfs db name
+;; (wal-time (if (file-exists? wal-file)
+;; (file-modification-time wal-file)
+;; 0))
+;; (shm-time (if (file-exists? shm-file)
+;; (file-modification-time shm-file)
+;; 0))
+;; (time1 (db:get-sqlite3-mod-time file))
+;; ;; (if (file-exists? file) ;; time1 is the max itime of the tmp db, -wal and -shm files.
+;; ;; (max (file-modification-time file) wal-time shm-time)
+;; ;; (begin
+;; ;; (debug:print-info 2 *default-log-port* "Sync - I do not see file "file)
+;; ;; 1)))
+;; (time2 (db:get-sqlite3-mod-time fulln))
+;; ;; (if (file-exists? fulln) ;; time2 is nfs file time
+;; ;; (file-modification-time fulln)
+;; ;; (begin
+;; ;; (debug:print-info 2 *default-log-port* "Sync - I do not see file "fulln)
+;; ;; 0)))
+;; (changed (> (- time1 time2) (+ (random 5) 1))) ;; it has been at some few seconds since last synced
+;; (changed10 (> (- time1 time2) 10)) ;; it has been at least ten seconds since sync'd
+;; (jfile-exists (file-exists? (conc file"-journal"))) ;; i.e. are we busy?
+;; (do-cp (cond
+;; ((not (file-exists? fulln)) ;; shouldn't happen, but this might recover
+;; (cons #t (conc "File "fulln" not found! Copying "fname" to "fulln)))
+;; ((and (not jfile-exists) changed)
+;; (cons #t "not busy, changed")) ;; not busy and changed
+;; ((and jfile-exists changed10)
+;; (cons #t "busy but not synced in a while")) ;; busy but not sync'd in over 10 seconds
+;; ((and changed *time-to-exit*)
+;; (cons #t "Time to exit, forced final sync")) ;; last sync
+;; (else
+;; (cons #f "No sync needed")))))
+;; (if (car do-cp)
+;; (let* ((start-time (current-milliseconds))
+;; (fname (pathname-file file))
+;; (runid (if (string= fname "main") #f (string->number fname))))
+;; (debug:print-info 3 *default-log-port* "db:all-db-sync: fname: "
+;; fname", delta: " (- time1 time2) " seconds, reason: "(cdr do-cp))
+;; (db:lock-and-delta-sync no-sync-db dbstruct fname runid (db:get-keys dbstruct) db:initialize-main-db)
+;; (hash-table-set! sync-durations (conc fname".db")
+;; (- (current-milliseconds) start-time)))
+;; (debug:print-info 3 *default-log-port* "skipping sync. " file " is up to date")
+;; )))
+;; dbfiles)
+;; ;; WHY does the dbdat need to be added back?
+;; (if dbdat (dbfile:add-dbdat dbstruct #f dbdat))
+;; )
+;; #t)
+
+
+;; options:
+;;
+;; 'killservers - kills all servers
+;; 'dejunk - removes junk records
+;; 'adj-testids - move test-ids into correct ranges
+;; 'old2new - sync megatest.db to /tmp/.../megatest.db and /tmp/.../megatest_ref.db
+;; 'new2old - sync /tmp/.../megatest.db to megatest.db and /tmp/.../megatest_ref.db (and update data_synced)
+;; 'closeall - close all opened dbs
+;; 'schema - attempt to apply schema changes
+;; run-ids: '(1 2 3 ...) or #f (for all)
+;;
+(define (db:multi-db-sync dbstruct . options)
+ (let* (;; (dbdat (db:open-db dbstruct #f dbfile:db-init-proc))
+ (data-synced 0) ;; count of changed records
+ (tmp-area (common:make-tmpdir-name *toppath* ""))
+ (old2new (member 'old2new options))
+ (dejunk (member 'dejunk options))
+ (killservers (member 'killservers options))
+ (src-area (if old2new *toppath* tmp-area))
+ (dest-area (if old2new tmp-area (conc *toppath* "/.mtdb")))
+ (dbfiles (if old2new (glob (conc *toppath* "/.mtdb/*.db"))
+ (glob (conc tmp-area "/*.db"))))
+ (keys (db:get-keys dbstruct))
+ (sync-durations (make-hash-table)))
+
+ ;; kill servers
+ ;; (if killservers (db:kill-servers))
+
+ (if (not dbfiles)
+ (debug:print-error 0 *default-log-port* "no dbfiles found in " (conc *toppath* "/.mtdb"))
+ (for-each
+ (lambda (srcfile)
+ (debug:print-info 3 *default-log-port* "file: " srcfile)
+ (let* ((fname (conc (pathname-file srcfile) ".db"))
+ (basename (pathname-file srcfile))
+ (run-id (if (string= basename "main") #f (string->number basename)))
+ (destfile (conc dest-area "/" fname))
+ (dest-directory dest-area)
+ (time1 (file-modification-time srcfile))
+ (time2 (if (file-exists? destfile)
+ (begin
+ (debug:print-info 2 *default-log-port* "destfile " destfile " exists")
+ (file-modification-time destfile))
+ (begin
+ (debug:print-info 0 *default-log-port* "Sync - I do not see file " destfile)
+ 0)))
+ (changed ( < (- time2 time1) 6.0)) ;; dest db not updated within last 6 seconds
+
+ (do-cp (cond
+ ((not (file-exists? destfile)) ;; shouldn't happen, but this might recover
+ (debug:print-info 2 *default-log-port* "File " destfile " not found. Copying "srcfile" to "destfile)
+ ;; TODO: Need to fix this for WAL mod. Can't just copy.
+ (system (conc "/bin/mkdir -p " dest-directory))
+ (system (conc "/bin/cp " srcfile " " destfile))
+ #t)
+ (changed ;; (and changed
+ #t)
+ ((and changed *time-to-exit*) ;; last sync
+ #t)
+ (else
+ #f))))
+
+ (if (or dejunk do-cp)
+ (let* ((start-time (current-milliseconds))
+ (subdb (or (dbfile:get-subdb dbstruct run-id) (dbfile:init-subdb dbstruct run-id dbfile:db-init-proc)))
+ (dbdat (or (dbfile:get-dbdat dbstruct run-id) (dbfile:open-db dbstruct run-id dbfile:db-init-proc)))
+ (mtdb (dbr:subdb-mtdbdat subdb))
+ ;;
+ ;; BUG: -mrw- I think this next line is wrong. run-id should be the path to .mtdb/.db
+ ;;
+ (tmpdb (dbfile:open-db dbstruct run-id dbfile:db-init-proc)))
+
+ (if dejunk
+ (begin
+ (debug:print 0 *default-log-port* "Cleaning tmp DB")
+ (db:clean-up run-id tmpdb)
+ (debug:print 0 *default-log-port* "Cleaning nfs DB")
+ (db:clean-up run-id mtdb)
+ )
+ )
+ (debug:print-info 2 *default-log-port* "delta syncing file: " srcfile ", time diff: " (- time1 time2) " seconds")
+ (if old2new
+ (begin
+ (db:sync-tables (db:sync-all-tables-list
+ (db:get-keys dbstruct))
+ #f mtdb tmpdb))
+ (begin
+ (db:sync-tables (db:sync-all-tables-list (db:get-keys dbstruct)) #f tmpdb mtdb)))
+ (hash-table-set! sync-durations (conc srcfile ".db") (- (current-milliseconds) start-time)))
+ (debug:print-info 2 *default-log-port* "skipping delta sync. " srcfile " is up to date"))))
+ dbfiles))
+ data-synced))
+
+;; Sync all changed db's
+;;
+(define (db:tmp->megatest.db-sync dbstruct run-id last-update)
+ (let* ((subdbs (hash-table-values (dbr:dbstruct-subdbs dbstruct)))
+ (res '()))
+ (for-each
+ (lambda (subdb)
+ (let* ((mtdb (dbr:subdb-mtdb subdb))
+ (tmpdb (db:get-subdb dbstruct run-id))
+ (refndb (dbr:subdb-refndb subdb))
+ (newres (db:sync-tables (db:sync-all-tables-list (db:get-keys dbstruct)) last-update tmpdb refndb mtdb)))
+ ;; (stack-push! (dbr:subdb-dbstack subdb) tmpdb)
+ ;; BUG: verify this is really needed
+ (dbfile:add-dbdat dbstruct run-id tmpdb)
+ (set! res (cons newres res))))
+ subdbs)
+ res))
+
+;;;; run-ids
+;; if #f use *db-local-sync* : or 'local-sync-flags
+;; if #t use timestamps : or 'timestamps
+;;
+;; NB// no-sync-db is the db handle, not a flag!
+;;
+(define (db:sync-to-megatest.db dbstruct #!key (no-sync-db #f))
+ (let* ((start-time (current-seconds))
+ (last-full-update (if no-sync-db
+ (db:no-sync-get/default no-sync-db "LAST_FULL_UPDATE" 0)
+ 0))
+ (full-sync-needed (> (- start-time last-full-update) 3600)) ;; every hour do a full sync
+ (last-update (if full-sync-needed
+ 0
+ (if no-sync-db
+ (db:no-sync-get/default no-sync-db "LAST_UPDATE" 0)
+ 0))) ;; (or (db:get-var dbstruct "LAST_UPDATE") 0))
+ (sync-needed (> (- start-time last-update) 6))
+ (res (if (or sync-needed ;; don't sync if a sync already occurred in the past 6 seconds
+ full-sync-needed)
+ (begin
+ (if no-sync-db
+ (begin
+ (if full-sync-needed (db:no-sync-set no-sync-db "LAST_FULL_UPDATE" start-time))
+ (db:no-sync-set no-sync-db "LAST_UPDATE" start-time)))
+ (db:tmp->megatest.db-sync dbstruct last-update))
+ 0))
+ (sync-time (- (current-seconds) start-time)))
+ (debug:print-info 3 *default-log-port* "Sync of newdb to olddb completed in " sync-time " seconds pid="(current-process-id))
+ (if (common:low-noise-print 30 "sync new to old")
+ (if sync-needed
+ (debug:print-info 0 *default-log-port* "Sync of " res " records from newdb to olddb completed in " sync-time " seconds pid="(current-process-id))
+ (debug:print-info 0 *default-log-port* "No sync needed, last updated " (- start-time last-update) " seconds ago")))
+ res))
+
+
+(define (db:initialize-main-db db)
+ (when (not *configinfo*)
+ (launch:setup)) ;; added because Elena was getting stack dump because *configinfo* below was #f.
+ (let* ((configdat (car *configinfo*)) ;; tut tut, global warning...
+ (keys (keys:config-get-fields configdat))
+ (havekeys (> (length keys) 0))
+ (keystr (keys->keystr keys))
+ (fieldstr (keys:make-key/field-string configdat))
+ #;(db (dbr:dbdat-dbh dbdat)))
+ (for-each (lambda (key)
+ (let ((keyn key))
+ (if (member (string-downcase keyn)
+ (list "runname" "state" "status" "owner" "event_time" "comment" "fail_count"
+ "pass_count" "contour"))
+ (begin
+ (debug:print 0 *default-log-port* "ERROR: your key cannot be named " keyn " as this conflicts with the same named field in the runs table, you must remove your megatest.db and /.db before trying again.")
+ (exit 1)))))
+ keys)
+ (sqlite3:with-transaction
+ db
+ (lambda ()
+ ;; handle-exceptions
+ ;; exn
+ ;; (begin
+ ;; (debug:print 0 "ERROR: Failed to create tables. Look at your [fields] section, should be: fieldname TEXT DEFAULT 'yourdefault'")
+ ;; (exit))
+ (sqlite3:execute db "CREATE TABLE IF NOT EXISTS keys (id INTEGER PRIMARY KEY, fieldname TEXT, fieldtype TEXT, CONSTRAINT keyconstraint UNIQUE (fieldname));")
+ (for-each
+ (lambda (key)
+ (let* ((fieldname #f)
+ (fieldtype #f))
+ (sqlite3:for-each-row
+ (lambda (fn ft)
+ (set! fieldname fn)
+ (set! fieldtype ft))
+ db
+ "SELECT fieldname,fieldtype FROM keys WHERE fieldname=?" key)
+ (if (not fieldname)
+ (sqlite3:execute db "INSERT INTO keys (fieldname,fieldtype) VALUES (?,?);" key "TEXT"))))
+ keys)
+ (sqlite3:execute db (conc
+ "CREATE TABLE IF NOT EXISTS runs (id INTEGER PRIMARY KEY, \n "
+ fieldstr (if havekeys "," "") "
+ runname TEXT DEFAULT 'norun',
+ contour TEXT DEFAULT '',
+ state TEXT DEFAULT '',
+ status TEXT DEFAULT '',
+ owner TEXT DEFAULT '',
+ event_time TIMESTAMP DEFAULT (strftime('%s','now')),
+ comment TEXT DEFAULT '',
+ fail_count INTEGER DEFAULT 0,
+ pass_count INTEGER DEFAULT 0,
+ last_update INTEGER DEFAULT (strftime('%s','now')),
+ CONSTRAINT runsconstraint UNIQUE (runname" (if havekeys "," "") keystr "));"))
+ ;; All triggers created at once in end
+ ;;(sqlite3:execute db "CREATE TRIGGER IF NOT EXISTS update_runs_trigger AFTER UPDATE ON runs
+ ;; FOR EACH ROW
+ ;; BEGIN
+ ;; UPDATE runs SET last_update=(strftime('%s','now'))
+ ;; WHERE id=old.id;
+ ;; END;")
+ (sqlite3:execute db "CREATE TABLE IF NOT EXISTS run_stats (
+ id INTEGER PRIMARY KEY,
+ run_id INTEGER,
+ state TEXT,
+ status TEXT,
+ count INTEGER,
+ last_update INTEGER DEFAULT (strftime('%s','now')))")
+ ;; All triggers created at once in end
+ ;; (sqlite3:execute db "CREATE TRIGGER IF NOT EXISTS update_run_stats_trigger AFTER UPDATE ON run_stats
+ ;; FOR EACH ROW
+ ;; BEGIN
+ ;; UPDATE run_stats SET last_update=(strftime('%s','now'))
+ ;; WHERE id=old.id;
+ ;; END;")
+ (sqlite3:execute db "CREATE TABLE IF NOT EXISTS test_meta (
+ id INTEGER PRIMARY KEY,
+ testname TEXT DEFAULT '',
+ author TEXT DEFAULT '',
+ owner TEXT DEFAULT '',
+ description TEXT DEFAULT '',
+ reviewed TIMESTAMP,
+ iterated TEXT DEFAULT '',
+ avg_runtime REAL,
+ avg_disk REAL,
+ tags TEXT DEFAULT '',
+ jobgroup TEXT DEFAULT 'default',
+ CONSTRAINT test_meta_constraint UNIQUE (testname));")
+ (sqlite3:execute db "CREATE TABLE IF NOT EXISTS tasks_queue (id INTEGER PRIMARY KEY,
+ action TEXT DEFAULT '',
+ owner TEXT,
+ state TEXT DEFAULT 'new',
+ target TEXT DEFAULT '',
+ name TEXT DEFAULT '',
+ testpatt TEXT DEFAULT '',
+ keylock TEXT,
+ params TEXT,
+ creation_time TIMESTAMP DEFAULT (strftime('%s','now')),
+ execution_time TIMESTAMP);")
+ ;; archive disk areas, cached info from [archive-disks]
+ (sqlite3:execute db "CREATE TABLE IF NOT EXISTS archive_disks (
+ id INTEGER PRIMARY KEY,
+ archive_area_name TEXT,
+ disk_path TEXT,
+ last_df INTEGER DEFAULT -1,
+ last_df_time TIMESTAMP DEFAULT (strftime('%s','now')),
+ creation_time TIMESTAMP DEFAULT (strftime('%s','now')));")
+ ;; individual bup (or tar) data chunks
+ (sqlite3:execute db "CREATE TABLE IF NOT EXISTS archive_blocks (
+ id INTEGER PRIMARY KEY,
+ archive_disk_id INTEGER,
+ disk_path TEXT,
+ last_du INTEGER DEFAULT -1,
+ last_du_time TIMESTAMP DEFAULT (strftime('%s','now')),
+ creation_time TIMESTAMP DEFAULT (strftime('%s','now')));")
+ ;; tests allocated to what chunks. reusing a chunk for a test/item_path is very efficient
+ ;; NB// the per run/test recording of where the archive is stored is done in the test
+ ;; record.
+ (sqlite3:execute db "CREATE TABLE IF NOT EXISTS archive_allocations (
+ id INTEGER PRIMARY KEY,
+ archive_block_id INTEGER,
+ testname TEXT,
+ item_path TEXT,
+ creation_time TIMESTAMP DEFAULT (strftime('%s','now')));")
+ ;; move this clean up call somewhere else
+ (sqlite3:execute db "DELETE FROM tasks_queue WHERE state='done' AND creation_time < ?;" (- (current-seconds)(* 24 60 60))) ;; remove older than 24 hrs
+ (sqlite3:execute db (conc "CREATE INDEX IF NOT EXISTS runs_index ON runs (runname" (if havekeys "," "") keystr ");"))
+ ;; (sqlite3:execute db "CREATE VIEW runs_tests AS SELECT * FROM runs INNER JOIN tests ON runs.id=tests.run_id;")
+ (sqlite3:execute db "CREATE TABLE IF NOT EXISTS extradat (id INTEGER PRIMARY KEY, run_id INTEGER, key TEXT, val TEXT);")
+ (sqlite3:execute db "CREATE TABLE IF NOT EXISTS metadat (id INTEGER PRIMARY KEY, var TEXT, val TEXT,
+ CONSTRAINT metadat_constraint UNIQUE (var));")
+ (sqlite3:execute db "CREATE TABLE IF NOT EXISTS access_log (id INTEGER PRIMARY KEY, user TEXT, accessed TIMESTAMP, args TEXT);")
+ ;; Must do this *after* running patch db !! No more.
+ ;; cannot use db:set-var since it will deadlock, hardwire the code here
+ (let* ((prev-version #f)
+ (curr-version (common:version-signature)))
+ (sqlite3:for-each-row
+ (lambda (ver)
+ (set! prev-version ver))
+ db
+ "SELECT val FROM metadat WHERE var='MEGATEST_VERSION';")
+ (if prev-version
+ (if (not (equal? prev-version curr-version))
+ (sqlite3:execute db "UPDATE metadat SET val=? WHERE var=?;" curr-version "MEGATEST_VERSION"))
+ (sqlite3:execute db "INSERT OR REPLACE INTO metadat (var,val) VALUES (?,?);" "MEGATEST_VERSION" curr-version) ))
+ (debug:print-info 11 *default-log-port* "db:initialize END") ;; ))))
+
+ ;;======================================================================
+ ;; R U N S P E C I F I C D B
+ ;;======================================================================
+
+ ;; (define (db:initialize-run-id-db db)
+ ;; (sqlite3:with-transaction
+ ;; db
+ ;; (lambda ()
+ (sqlite3:execute db "CREATE TABLE IF NOT EXISTS tests
+ (id INTEGER PRIMARY KEY,
+ run_id INTEGER DEFAULT -1,
+ testname TEXT DEFAULT 'noname',
+ host TEXT DEFAULT 'n/a',
+ cpuload REAL DEFAULT -1,
+ diskfree INTEGER DEFAULT -1,
+ uname TEXT DEFAULT 'n/a',
+ rundir TEXT DEFAULT '/tmp/badname',
+ shortdir TEXT DEFAULT '/tmp/badname',
+ item_path TEXT DEFAULT '',
+ state TEXT DEFAULT 'NOT_STARTED',
+ status TEXT DEFAULT 'FAIL',
+ attemptnum INTEGER DEFAULT 0,
+ final_logf TEXT DEFAULT 'logs/final.log',
+ logdat TEXT DEFAULT '',
+ run_duration INTEGER DEFAULT 0,
+ comment TEXT DEFAULT '',
+ event_time TIMESTAMP DEFAULT (strftime('%s','now')),
+ fail_count INTEGER DEFAULT 0,
+ pass_count INTEGER DEFAULT 0,
+ archived INTEGER DEFAULT 0, -- 0=no, > 1=archive block id where test data can be found
+ last_update INTEGER DEFAULT (strftime('%s','now')),
+ CONSTRAINT testsconstraint UNIQUE (run_id, testname, item_path));")
+ ;; deprecated -- (sqlite3:execute db "CREATE INDEX IF NOT EXISTS tests_index ON tests (run_id, testname, item_path, uname);")
+
+ (sqlite3:execute db "CREATE INDEX IF NOT EXISTS tests_run_id_index ON tests (run_id);") ;; new
+ (sqlite3:execute db "CREATE INDEX IF NOT EXISTS tests_testname_index ON tests (testname,item_path);") ;; new
+ (sqlite3:execute db "CREATE INDEX IF NOT EXISTS tests_state_status_index ON tests (state, status); ") ;; new
+
+ ;; All triggers created at once in end
+ ;;(sqlite3:execute db "CREATE TRIGGER IF NOT EXISTS update_tests_trigger AFTER UPDATE ON tests
+ ;; FOR EACH ROW
+ ;; BEGIN
+ ;; UPDATE tests SET last_update=(strftime('%s','now'))
+ ;; WHERE id=old.id;
+ ;; END;")
+ (sqlite3:execute db "CREATE TABLE IF NOT EXISTS test_steps
+ (id INTEGER PRIMARY KEY,
+ test_id INTEGER,
+ stepname TEXT,
+ state TEXT DEFAULT 'NOT_STARTED',
+ status TEXT DEFAULT 'n/a',
+ event_time TIMESTAMP,
+ comment TEXT DEFAULT '',
+ logfile TEXT DEFAULT '',
+ last_update INTEGER DEFAULT (strftime('%s','now')),
+ CONSTRAINT test_steps_constraint UNIQUE (test_id,stepname,state));")
+ (sqlite3:execute db "CREATE INDEX IF NOT EXISTS teststeps_index ON test_steps (test_id, stepname, state);")
+ ;; All triggers created at once in end
+ ;;(sqlite3:execute db "CREATE TRIGGER IF NOT EXISTS update_teststeps_trigger AFTER UPDATE ON test_steps
+ ;; FOR EACH ROW
+ ;; BEGIN
+ ;; UPDATE test_steps SET last_update=(strftime('%s','now'))
+ ;; WHERE id=old.id;
+ ;; END;")
+ (sqlite3:execute db "CREATE TABLE IF NOT EXISTS test_data (id INTEGER PRIMARY KEY,
+ test_id INTEGER,
+ category TEXT DEFAULT '',
+ variable TEXT,
+ value REAL,
+ expected REAL,
+ tol REAL,
+ units TEXT,
+ comment TEXT DEFAULT '',
+ status TEXT DEFAULT 'n/a',
+ type TEXT DEFAULT '',
+ last_update INTEGER DEFAULT (strftime('%s','now')),
+ CONSTRAINT test_data_constraint UNIQUE (test_id,category,variable));")
+ (sqlite3:execute db "CREATE INDEX IF NOT EXISTS test_data_index ON test_data (test_id);")
+ ;; All triggers created at once in end
+ ;;(sqlite3:execute db "CREATE TRIGGER IF NOT EXISTS update_test_data_trigger AFTER UPDATE ON test_data
+ ;; FOR EACH ROW
+ ;; BEGIN
+ ;; UPDATE test_data SET last_update=(strftime('%s','now'))
+ ;; WHERE id=old.id;
+ ;; END;")
+ (sqlite3:execute db "CREATE TABLE IF NOT EXISTS test_rundat (
+ id INTEGER PRIMARY KEY,
+ test_id INTEGER,
+ update_time TIMESTAMP,
+ cpuload INTEGER DEFAULT -1,
+ diskfree INTEGER DEFAULT -1,
+ diskusage INTGER DEFAULT -1,
+ run_duration INTEGER DEFAULT 0,
+ last_update INTEGER DEFAULT (strftime('%s','now')));")
+ (sqlite3:execute db "CREATE TABLE IF NOT EXISTS archives (
+ id INTEGER PRIMARY KEY,
+ test_id INTEGER,
+ state TEXT DEFAULT 'new',
+ status TEXT DEFAULT 'n/a',
+ archive_type TEXT DEFAULT 'bup',
+ du INTEGER,
+ archive_path TEXT,
+ last_update INTEGER DEFAULT (strftime('%s','now')));")))
+ (db:create-triggers db)
+ db)) ;; )
+
+;;======================================================================
+;; A R C H I V E S
+;;======================================================================
+
+;; dneeded is minimum space needed, scan for existing archives that
+;; are on disks with adequate space and already have this test/itempath
+;; archived
+;;
+(define (db:archive-get-allocations dbstruct testname itempath dneeded)
+ (let* ((dbdat (db:get-subdb dbstruct #f)) ;; archive tables are in main.db
+ (db (dbr:dbdat-dbh dbdat))
+ (res '())
+ (blocks '())) ;; a block is an archive chunck that can be added too if there is space
+ (sqlite3:for-each-row
+ (lambda (id archive-disk-id disk-path last-du last-du-time)
+ (set! res (cons (vector id archive-disk-id disk-path last-du last-du-time) res)))
+ db
+ "SELECT b.id,b.archive_disk_id,b.disk_path,b.last_du,b.last_du_time FROM archive_blocks AS b
+ INNER JOIN archive_allocations AS a ON a.archive_block_id=b.id
+ WHERE a.testname=? AND a.item_path=?;"
+ testname itempath)
+ ;; Now res has list of candidate paths, look in archive_disks for candidate with potential free space
+ (if (null? res)
+ '()
+ (sqlite3:for-each-row
+ (lambda (id archive-area-name disk-path last-df last-df-time)
+ (set! blocks (cons (vector id archive-area-name disk-path last-df last-df-time) blocks)))
+ db
+ (conc
+ "SELECT d.id,d.archive_area_name,disk_path,last_df,last_df_time FROM archive_disks AS d
+ INNER JOIN archive_blocks AS b ON d.id=b.archive_disk_id
+ WHERE b.id IN (" (string-intersperse (map conc res) ",") ") AND
+ last_df > ?;")
+ dneeded))
+ ;; BUG: Verfify this is really needed
+ (dbfile:add-dbdat dbstruct #f dbdat)
+ blocks))
+
+;; returns id of the record, register a disk allocated to archiving and record it's last known
+;; available space
+;;
+(define (db:archive-register-disk dbstruct bdisk-name bdisk-path df)
+ (let* ((dbdat (db:get-subdb dbstruct #f)) ;; archive tables are in main.db
+ (db (dbr:dbdat-dbh dbdat))
+ (res #f))
+ (sqlite3:for-each-row
+ (lambda (id)
+ (set! res id))
+ db
+ "SELECT id FROM archive_disks WHERE archive_area_name=? AND disk_path=?;"
+ bdisk-name bdisk-path)
+ (if res ;; record exists, update df and return id
+ (begin
+ (sqlite3:execute db "UPDATE archive_disks SET last_df=?,last_df_time=(strftime('%s','now'))
+ WHERE archive_area_name=? AND disk_path=?;"
+ df bdisk-name bdisk-path)
+ (dbfile:add-dbdat dbstruct #f dbdat)
+ res)
+ (begin
+ (sqlite3:execute
+ db
+ "INSERT OR REPLACE INTO archive_disks (archive_area_name,disk_path,last_df)
+ VALUES (?,?,?);"
+ bdisk-name bdisk-path df)
+ (dbfile:add-dbdat dbstruct #f dbdat)
+ (db:archive-register-disk dbstruct bdisk-name bdisk-path df)))))
+
+;; record an archive path created on a given archive disk (identified by it's bdisk-id)
+;; if path starts with / then it is full, otherwise it is relative to the archive disk
+;; preference is to store the relative path.
+;;
+(define (db:archive-register-block-name dbstruct bdisk-id archive-path #!key (du #f))
+ (let* ((dbdat (db:get-subdb dbstruct #f)) ;; archive tables are in main.db
+ (db (dbr:dbdat-dbh dbdat))
+ (res #f))
+ ;; first look to see if this path is already registered
+ (sqlite3:for-each-row
+ (lambda (id)
+ (set! res id))
+ db
+ "SELECT id FROM archive_blocks WHERE archive_disk_id=? AND disk_path=?;"
+ bdisk-id archive-path)
+ (if res ;; record exists, update du if applicable and return res
+ (if du (sqlite3:execute db "UPDATE archive_blocks SET last_du=?,last_du_time=(strftime('%s','now'))
+ WHERE archive_disk_id=? AND disk_path=?;"
+ bdisk-id archive-path du))
+ (begin
+ (sqlite3:execute db "INSERT OR REPLACE INTO archive_blocks (archive_disk_id,disk_path,last_du)
+ VALUES (?,?,?);"
+ bdisk-id archive-path (or du 0))
+ (set! res (db:archive-register-block-name dbstruct bdisk-id archive-path du: du))))
+ (dbfile:add-dbdat dbstruct #f dbdat)
+ res))
+
+
+;; The "archived" field in tests is overloaded; 0 = not archived, > 0 archived in block with given id
+;;
+(define (db:test-set-archive-block-id dbstruct run-id test-id archive-block-id)
+ (db:with-db
+ dbstruct
+ run-id
+ #t
+ (lambda (dbdat db)
+ (sqlite3:execute db "UPDATE tests SET archived=? WHERE id=?;"
+ archive-block-id test-id))))
+
+;; Look up the archive block info given a block-id
+;;
+(define (db:test-get-archive-block-info dbstruct archive-block-id)
+ (db:with-db
+ dbstruct
+ #f
+ #f
+ (lambda (dbdat db)
+ (let ((res #f))
+ (sqlite3:for-each-row
+ ;; 0 1 2 3 4 5
+ (lambda (id archive-disk-id disk-path last-du last-du-time creation-time)
+ (set! res (vector id archive-disk-id disk-path last-du last-du-time creation-time)))
+ db
+ "SELECT id,archive_disk_id,disk_path,last_du,last_du_time,creation_time FROM archive_blocks WHERE id=?;"
+ archive-block-id)
+ res))))
+
+;; (define (db:archive-allocate-testsuite/area-to-block block-id testsuite-name areakey)
+;; (let* ((dbdat (db:get-subdb dbstruct #f)) ;; archive tables are in main.db
+;; (db (dbr:dbdat-dbh dbdat))
+;; (res '())
+;; (blocks '())) ;; a block is an archive chunck that can be added too if there is space
+;; (sqlite3:for-each-row #f)
+
+;;======================================================================
+;; D B U T I L S
+;;======================================================================
+
+;;======================================================================
+;; M A I N T E N A N C E
+;;======================================================================
+
+;; (define (db:have-incompletes? dbstruct run-id ovr-deadtime)
+;; (let* ((incompleted '())
+;; (oldlaunched '())
+;; (toplevels '())
+;; (deadtime-str (configf:lookup *configdat* "setup" "deadtime"))
+;; (deadtime (if (and deadtime-str
+;; (string->number deadtime-str))
+;; (string->number deadtime-str)
+;; 72000))) ;; twenty hours
+;; (db:with-db
+;; dbstruct run-id #f
+;; (lambda (dbdat db)
+;; (if (number? ovr-deadtime)(set! deadtime ovr-deadtime))
+;;
+;; ;; in RUNNING or REMOTEHOSTSTART for more than 10 minutes
+;; ;;
+;; ;; HOWEVER: this code in run:test seems to work fine
+;; ;; (> (- (current-seconds)(+ (db:test-get-event_time testdat)
+;; ;; (db:test-get-run_duration testdat)))
+;; ;; 600)
+;; ;; (db:delay-if-busy dbdat)
+;; (sqlite3:for-each-row
+;; (lambda (test-id run-dir uname testname item-path)
+;; (if (and (equal? uname "n/a")
+;; (equal? item-path "")) ;; this is a toplevel test
+;; ;; what to do with toplevel? call rollup?
+;; (begin
+;; (set! toplevels (cons (list test-id run-dir uname testname item-path run-id) toplevels))
+;; (debug:print-info 0 *default-log-port* "Found old toplevel test in RUNNING state, test-id=" test-id))
+;; (set! incompleted (cons (list test-id run-dir uname testname item-path run-id) incompleted))))
+;; (db:get-cache-stmth dbdat db
+;; "SELECT id,rundir,uname,testname,item_path FROM tests WHERE run_id=? AND (strftime('%s','now') - event_time) > (run_duration + ?) AND state IN ('RUNNING','REMOTEHOSTSTART');")
+;; run-id deadtime)
+;;
+;; ;; in LAUNCHED for more than one day. Could be long due to job queues TODO/BUG: Need override for this in config
+;; ;;
+;; ;; (db:delay-if-busy dbdat)
+;; (sqlite3:for-each-row
+;; (lambda (test-id run-dir uname testname item-path)
+;; (if (and (equal? uname "n/a")
+;; (equal? item-path "")) ;; this is a toplevel test
+;; ;; what to do with toplevel? call rollup?
+;; (set! toplevels (cons (list test-id run-dir uname testname item-path run-id) toplevels))
+;; (set! oldlaunched (cons (list test-id run-dir uname testname item-path run-id) oldlaunched))))
+;; (db:get-cache-stmth dbdat db
+;; "SELECT id,rundir,uname,testname,item_path FROM tests WHERE run_id=? AND (strftime('%s','now') - event_time) > 86400 AND state IN ('LAUNCHED');")
+;; run-id)
+;;
+;; (debug:print-info 18 *default-log-port* "Found " (length oldlaunched) " old LAUNCHED items, " (length toplevels) " old LAUNCHED toplevel tests and " (length incompleted) " tests marked RUNNING but apparently dead.")
+;; (if (and (null? incompleted)
+;; (null? oldlaunched)
+;; (null? toplevels))
+;; #f
+;; #t)))))
+
+;; BUG: Probably broken - does not explicitly use run-id in the query
+;;
+(define (db:top-test-set-per-pf-counts dbstruct run-id test-name)
+ (db:general-call dbstruct run-id 'top-test-set-per-pf-counts (list test-name test-name test-name test-name test-name test-name test-name test-name test-name test-name test-name test-name test-name test-name test-name test-name test-name)))
+
+;; Clean out old junk and vacuum the database
+;;
+;; Ultimately do something like this:
+;;
+;; 1. Look at test records either deleted or part of deleted run:
+;; a. If test dir exists, set the the test to state='UNKNOWN', Set the run to 'unknown'
+;; b. If test dir gone, delete the test record
+;; 2. Look at run records
+;; a. If have tests that are not deleted, set state='unknown'
+;; b. ....
+;;
+(define (db:clean-up run-id dbdat)
+ (if run-id
+ (begin
+ (debug:print 0 *default-log-port* "Cleaning run DB " run-id)
+ (db:clean-up-rundb dbdat run-id)
+ )
+ (begin
+ (debug:print 0 *default-log-port* "Cleaning main DB ")
+ (db:clean-up-maindb dbdat)
+ )
+ )
+)
+
+
+;; Clean out old junk and vacuum the database
+;;
+;; Ultimately do something like this:
+;;
+;; 1. Look at test records either deleted or part of deleted run:
+;; a. If test dir exists, set the the test to state='UNKNOWN', Set the run to 'unknown'
+;; b. If test dir gone, delete the test record
+;; 2. Look at run records
+;; a. If have tests that are not deleted, set state='unknown'
+;; b. ....
+;;
+(define (db:clean-up-rundb dbdat run-id)
+ ;; (debug:print 0 *default-log-port* "WARNING: db clean up not fully ported to v1.60, cleanup action will be on megatest.db")
+ (let* ((db (dbr:dbdat-dbh dbdat))
+ (test-count-stmt (sqlite3:prepare db "SELECT (SELECT count(id) FROM tests);"))
+ (step-count-stmt (sqlite3:prepare db "SELECT (SELECT count(id) FROM test_steps);"))
+ (statements
+ (map (lambda (stmt)
+ (sqlite3:prepare db stmt))
+ (list
+ "DELETE FROM tests WHERE state='DELETED';"
+ "DELETE FROM test_steps WHERE status = 'DELETED';"
+ "DELETE FROM tests WHERE run_id IN (SELECT id FROM runs WHERE state = 'deleted');"
+ ))))
+ (sqlite3:with-transaction
+ db
+ (lambda ()
+ (sqlite3:for-each-row (lambda (tot)
+ (debug:print-info 0 *default-log-port* "Test records count before clean: " tot))
+ test-count-stmt)
+ (sqlite3:for-each-row (lambda (tot)
+ (debug:print-info 0 *default-log-port* "Test_step records count before clean: " tot))
+ step-count-stmt)
+ (map sqlite3:execute statements)
+ (sqlite3:for-each-row (lambda (tot)
+ (debug:print-info 0 *default-log-port* "Test records count after clean: " tot))
+ test-count-stmt)
+ (sqlite3:for-each-row (lambda (tot)
+ (debug:print-info 0 *default-log-port* "Test_step records count after clean: " tot))
+ step-count-stmt)))
+ (map sqlite3:finalize! statements)
+ (sqlite3:finalize! test-count-stmt)
+ (sqlite3:finalize! step-count-stmt)
+ (sqlite3:execute db "VACUUM;")))
+
+;; Clean out old junk and vacuum the database
+;;
+;; Ultimately do something like this:
+;;
+;; 1. Look at test records either deleted or part of deleted run:
+;; a. If test dir exists, set the the test to state='UNKNOWN', Set the run to 'unknown'
+;; b. If test dir gone, delete the test record
+;; 2. Look at run records
+;; a. If have tests that are not deleted, set state='unknown'
+;; b. ....
+;;
+(define (db:clean-up-maindb dbdat)
+ ;; (debug:print 0 *default-log-port* "WARNING: db clean up not fully ported to v1.60, cleanup action will be on megatest.db")
+ (let* ((db (dbr:dbdat-dbh dbdat))
+ (count-stmt (sqlite3:prepare db "SELECT (SELECT count(id) FROM runs);"))
+ (statements
+ (map (lambda (stmt)
+ (sqlite3:prepare db stmt))
+ (list
+ ;; delete all tests that belong to runs that are 'deleted'
+ ;; (conc "DELETE FROM tests WHERE run_id NOT IN (" (string-intersperse (map conc valid-runs) ",") ");")
+ ;; delete all tests that are 'DELETED'
+ "DELETE FROM runs WHERE state='deleted';"
+ )))
+ (dead-runs '()))
+ (sqlite3:for-each-row
+ (lambda (run-id)
+ (set! dead-runs (cons run-id dead-runs)))
+ db
+ "SELECT id FROM runs WHERE state='deleted';")
+ ;; (db:delay-if-busy dbdat)
+ (sqlite3:with-transaction
+ db
+ (lambda ()
+ (sqlite3:for-each-row (lambda (tot)
+ (debug:print-info 0 *default-log-port* "Run records count before clean: " tot))
+ count-stmt)
+ (map sqlite3:execute statements)
+ (sqlite3:for-each-row (lambda (tot)
+ (debug:print-info 0 *default-log-port* "Run records count after clean: " tot))
+ count-stmt)))
+ (map sqlite3:finalize! statements)
+ (sqlite3:finalize! count-stmt)
+ ;; (db:find-and-mark-incomplete db)
+ ;; (db:delay-if-busy dbdat)
+ (sqlite3:execute db "VACUUM;")
+ dead-runs))
+
+;;======================================================================
+;; no-sync.db - small bits of data to be shared between servers
+;;======================================================================
+
+(define (db:get-dbsync-path)
+ (case (rmt:transport-mode)
+ ((http)(common:make-tmpdir-name *toppath* ""))
+ ((tcp) (conc *toppath*"/.mtdb"))
+ ((nfs) (conc *toppath*"/.mtdb"))
+ (else "/tmp/dunno-this-gonna-exist")))
+
+;; This is needed for api.scm
+(define (db:open-no-sync-db)
+ (dbfile:open-no-sync-db (db:get-dbsync-path)))
+
+;; why get the keys from the db? why not get from the *configdat*
+;; using keys:config-get-fields?
+
+(define (db:get-keys dbstruct)
+ (keys:config-get-fields *configdat*))
+
+;; extract index number given a header/data structure
+(define (db:get-index-by-header header field)
+ (list-index (lambda (x)(equal? x field)) header))
+
+;; look up values in a header/data structure
+(define (db:get-value-by-header row header field)
+ (let ((len (if (vector? row)
+ (vector-length row)
+ 0)))
+ (if (or (null? header) (not row))
+ #f
+ (let loop ((hed (car header))
+ (tal (cdr header))
+ (n 0))
+ (if (equal? hed field)
+ (handle-exceptions
+ exn
+ (begin
+ (debug:print 4 *default-log-port* "WARNING: attempt to read non-existant field, row="
+ row " header=" header " field=" field ", exn=" exn)
+ #f)
+ (if (>= n len)
+ #f
+ (vector-ref row n)))
+ (if (null? tal) #f (loop (car tal)(cdr tal)(+ n 1))))))))
+
+;; Accessors for the header/data structure
+;; get rows and header from
+(define (db:get-header vec)(vector-ref vec 0))
+(define (db:get-rows vec)(vector-ref vec 1))
+
+;;======================================================================
+;; R U N S
+;;======================================================================
+
+(define (db:get-run-times dbstruct run-patt target-patt)
+(let ((res `())
+ (qry (conc "select runname, (max(end_time)-min(event_time))/60 as runtime, target from (select runname, run_id,tests.event_time,tests.event_time+run_duration AS end_time, " (string-join (db:get-keys dbstruct) " || '/' || ") " as target from tests inner join runs on tests.run_id = runs.id where runs.runname like ? and target like ?) group by run_id ;")))
+ ;(print qry)
+ (db:with-db
+ dbstruct
+ #f ;; this is for the main runs db
+ #f ;; does not modify db
+ (lambda (dbdat db)
+ (sqlite3:for-each-row
+ (lambda (runname runtime target )
+ (set! res (cons (vector runname runtime target) res)))
+ db
+ qry
+ run-patt target-patt)
+ res))))
+
+(define (db:get-run-name-from-id dbstruct run-id)
+ (db:with-db
+ dbstruct
+ #f ;; this is for the main runs db
+ #f ;; does not modify db
+ (lambda (dbdat db)
+ (let ((res #f))
+ (sqlite3:for-each-row
+ (lambda (runname)
+ (set! res runname))
+ db
+ "SELECT runname FROM runs WHERE id=?;"
+ run-id)
+ res))))
+
+(define (db:get-run-key-val dbstruct run-id key)
+ (db:with-db
+ dbstruct
+ #f
+ #f
+ (lambda (dbdat db)
+ (let ((res #f))
+ (sqlite3:for-each-row
+ (lambda (val)
+ (set! res val))
+ db
+ (conc "SELECT " key " FROM runs WHERE id=?;")
+ run-id)
+ res))))
+
+;; keys list to key1,key2,key3 ...
+(define (runs:get-std-run-fields keys remfields)
+ (let* ((header (append keys remfields))
+ (keystr (conc (keys->keystr keys) ","
+ (string-intersperse remfields ","))))
+ (list keystr header)))
+
+;; make a query (fieldname like 'patt1' OR fieldname
+(define (db:patt->like fieldname pattstr #!key (comparator " OR "))
+ (let ((patts (if (string? pattstr)
+ (string-split pattstr ",")
+ '("%"))))
+ (string-intersperse (map (lambda (patt)
+ (let ((wildtype (if (substring-index "%" patt) "LIKE" "GLOB")))
+ (conc fieldname " " wildtype " '" patt "'")))
+ (if (null? patts)
+ '("")
+ patts))
+ comparator)))
+
+
+;; register a test run with the db, this accesses the main.db and does NOT
+;; use server api
+;;
+(define (db:register-run dbstruct keyvals runname state status user contour-in)
+ (let* ((keys (map car keyvals))
+ (keystr (keys->keystr keys))
+ (contour (or contour-in "")) ;; empty string to force no hierarcy and be backwards compatible.
+ (comma (if (> (length keys) 0) "," ""))
+ (andstr (if (> (length keys) 0) " AND " ""))
+ (valslots (keys->valslots keys)) ;; ?,?,? ...
+ (allvals (append (list runname state status user contour) (map cadr keyvals)))
+ (qryvals (append (list runname) (map cadr keyvals)))
+ (key=?str (string-intersperse (map (lambda (k)(conc k "=?")) keys) " AND ")))
+ ;; (debug:print 0 *default-log-port* "Got here 0.")
+ (debug:print 3 *default-log-port* "keys: " keys " allvals: " allvals " keyvals: " keyvals " key=?str is " key=?str)
+ (debug:print 2 *default-log-port* "NOTE: using target " (string-intersperse (map cadr keyvals) "/") " for this run")
+ (if (and runname (null? (filter (lambda (x)(not x)) keyvals))) ;; there must be a better way to "apply and"
+ (db:with-db
+ dbstruct #f #t
+ (lambda (dbdat db)
+ ;; (debug:print 0 *default-log-port* "Got here 1.")
+ (let ((res #f))
+ (apply sqlite3:execute db
+ (conc "INSERT OR IGNORE INTO runs (runname,state,status,owner,event_time,contour"
+ comma keystr ") VALUES (?,?,?,?,strftime('%s','now'),?" comma valslots ");")
+ allvals)
+ (apply sqlite3:for-each-row
+ (lambda (id)
+ (set! res id))
+ db
+ (let ((qry (conc "SELECT id FROM runs WHERE (runname=? " andstr key=?str ");")))
+ qry)
+ qryvals)
+ (sqlite3:execute db "UPDATE runs SET state=?,status=?,event_time=strftime('%s','now') WHERE id=? AND state='deleted';" state status res)
+ res)))
+ (begin
+ (debug:print-error 0 *default-log-port* "Called without all necessary keys")
+ #f))))
+
+(define (db:get-run-id dbstruct runname target)
+ (let ((runs (db:simple-get-runs dbstruct runname #f #f target #f))) ;; runpatt count offset target last-update
+ (if (null? runs)
+ #f
+ (simple-run-id (car runs)))))
+
+;; called with run-id=#f so will operate on main.db
+;;
+(define (db:insert-run dbstruct run-id target runname run-meta)
+ (let* ((keys (db:get-keys dbstruct))
+ (runs (db:simple-get-runs dbstruct runname #f #f target #f))) ;; runpatt count offset target last-update
+ ;; need to insert run based on target and runname
+ (let* ((targvals (string-split target "/"))
+ (keystr (string-intersperse keys ","))
+ (key?str (string-intersperse (make-list (length targvals) "?") ","))
+ (qrystr (conc "INSERT INTO runs (id,runname,"keystr") VALUES (?,?,"key?str")"))
+ (get-var (lambda (db qrystr)
+ (let* ((res #f))
+ (sqlite3:for-each-row
+ (lambda row
+ (set res (car row)))
+ db qrystr run-id runname)
+ res))))
+ (if (null? runs)
+ (begin
+ (db:create-initial-run-record dbstruct run-id runname target)
+ )
+ )
+ (let* ()
+ ;;(debug:print 0 *default-log-port* "db:insert-run: Calling db:with-db to update the run record")
+ (debug:print 0 *default-log-port* "db:insert-run: runid = " run-id)
+ run-id))))
+
+(define (db:create-initial-run-record dbstruct run-id runname target)
+ (let* ((keys (db:get-keys dbstruct))
+ (targvals (string-split target "/"))
+ (keystr (string-intersperse keys ","))
+ (key?str (string-intersperse (make-list (length targvals) "?") ",")) ;; a string with the same length as targvals, where each element is "?" and interspersed with commas.
+ (qrystr (conc "INSERT INTO runs (id,runname,"keystr") VALUES (?,?,"key?str")")))
+ (debug:print 0 *default-log-port* "db:create-initial-run-record")
+ (debug:print 0 *default-log-port* "qrystr = " qrystr)
+
+ (db:with-db
+ dbstruct #f #t ;; run-id writable
+ (lambda (dbdat db)
+ (debug:print 0 *default-log-port* "lambda proc: dbdat: " dbdat " db: " db)
+ (apply sqlite3:execute db qrystr run-id runname targvals)))))
+
+(define (db:insert-test dbstruct run-id test-rec)
+ (let* ((testname (alist-ref "testname" test-rec equal?))
+ (item-path (alist-ref "item_path" test-rec equal?))
+ (id (db:get-test-id dbstruct run-id testname item-path))
+ (fieldvals (filter (lambda (x)(not (member (car x) '("id" "last_update")))) test-rec))
+ (setqry (conc "UPDATE tests SET "(string-intersperse
+ (map (lambda (dat)
+ (conc (car dat)"=?"))
+ fieldvals)
+ ",")" WHERE id=?;"))
+ (insqry (conc "INSERT INTO tests ("(string-intersperse (map (lambda (x) (car x)) fieldvals) ",")
+ ") VALUES ("(string-intersperse (make-list (length fieldvals) "?") ",")");")))
+ ;; (debug:print 0 *default-log-port* "id: "id"\nset: "setqry"\ninsqry: "insqry)
+ (db:with-db
+ dbstruct
+ run-id #t
+ (lambda (dbdat db)
+ (if id
+ (apply sqlite3:execute db setqry (append (map cdr fieldvals) (list id)))
+ (apply sqlite3:execute db insqry (map cdr fieldvals)))))))
+
+;; replace header and keystr with a call to runs:get-std-run-fields
+;;
+;; keypatts: ( (KEY1 "abc%def")(KEY2 "%") )
+;; runpatts: patt1,patt2 ...
+;;
+(define (db:get-runs dbstruct runpatt count offset keypatts)
+ (let* ((res '())
+ (keys (db:get-keys dbstruct))
+ (runpattstr (db:patt->like "runname" runpatt))
+ (remfields (list "id" "runname" "state" "status" "owner" "event_time"))
+ (header (append keys remfields))
+ (keystr (conc (keys->keystr keys) ","
+ (string-intersperse remfields ",")))
+ (qrystr (conc "SELECT " keystr " FROM runs WHERE (" runpattstr ") " ;; runname LIKE ? "
+ ;; Generate: " AND x LIKE 'keypatt' ..."
+ (if (null? keypatts) ""
+ (conc " AND "
+ (string-join
+ (map (lambda (keypatt)
+ (let ((key (car keypatt))
+ (patt (cadr keypatt)))
+ (db:patt->like key patt)))
+ keypatts)
+ " AND ")))
+ " AND state != 'deleted' ORDER BY event_time DESC "
+ (if (number? count)
+ (conc " LIMIT " count)
+ "")
+ (if (number? offset)
+ (conc " OFFSET " offset)
+ ""))))
+ (debug:print-info 11 *default-log-port* "db:get-runs START qrystr: " qrystr " keypatts: " keypatts " offset: " offset " limit: " count)
+ (db:with-db dbstruct #f #f
+ (lambda (dbdat db)
+ (sqlite3:for-each-row
+ (lambda (a . x)
+ (set! res (cons (apply vector a x) res)))
+ db
+ qrystr
+ )))
+ (debug:print-info 11 *default-log-port* "db:get-runs END qrystr: " qrystr " keypatts: " keypatts " offset: " offset " limit: " count)
+ (vector header res)))
+
+;; simple get-runs
+;;
+;; records used defined in dbfile
+;;
+(define (db:simple-get-runs dbstruct runpatt count offset target last-update)
+ (let* ((res '())
+ (keys (db:get-keys dbstruct))
+ (runpattstr (db:patt->like "runname" runpatt))
+ (remfields (list "id" "runname" "state" "status" "owner" "event_time"))
+ (targstr (string-intersperse keys "||'/'||"))
+ (keystr (conc targstr " AS target,"
+ (string-intersperse remfields ",")))
+ (qrystr (conc "SELECT " keystr " FROM runs WHERE (" runpattstr ") " ;; runname LIKE ? "
+ ;; Generate: " AND x LIKE 'keypatt' ..."
+ " AND target LIKE '" target "'"
+ " AND state != 'deleted' "
+ (if (number? last-update)
+ (conc " AND last_update >= " last-update)
+ "")
+ " ORDER BY event_time DESC "
+ (if (number? count)
+ (conc " LIMIT " count)
+ "")
+ (if (number? offset)
+ (conc " OFFSET " offset)
+ "")))
+ )
+ (debug:print-info 11 *default-log-port* "db:get-runs START qrystr: " qrystr " target: " target " offset: " offset " limit: " count)
+ (db:with-db dbstruct #f #f
+ (lambda (dbdat db)
+ (sqlite3:for-each-row
+ (lambda (target id runname state status owner event_time)
+ (set! res (cons (make-simple-run target id runname state status owner event_time) res)))
+ db
+ qrystr
+ )))
+ (debug:print-info 11 *default-log-port* "db:get-runs END qrystr: " qrystr " target: " target " offset: " offset " limit: " count)
+ res))
+
+;; TODO: Switch this to use max(update_time) from each run db? Then if using a server there is no disk traffic (using cachedb db) ???
+;;
+;; NOTE: This DOESN'T (necessarily) get the real run ids, but the number of the .db!!
+
+(define (db:get-changed-run-ids since-time)
+ (let* ((dbdir (common:make-tmpdir-name *toppath* "")) ;; (configf:lookup *configdat* "setup" "dbdir"))
+ (alldbs (glob (conc *toppath* "/.mtdb/[0-9]*.db*")))
+ (changed (filter (lambda (dbfile)
+ (> (file-modification-time dbfile) since-time))
+ alldbs)))
+ (delete-duplicates
+ (map (lambda (dbfile)
+ (let* ((res (string-match ".*\\/(\\d+)\\.db*" dbfile)))
+ (if res
+ (string->number (cadr res))
+ (begin
+ (debug:print 2 *default-log-port* "WARNING: Failed to process " dbfile " for run-id")
+ 0))))
+ changed))))
+
+;; Get all targets from the db
+;;
+(define (db:get-targets dbstruct)
+ (let* ((res '())
+ (keys (db:get-keys dbstruct))
+ (header keys) ;; (map key:get-fieldname keys))
+ (keystr (keys->keystr keys))
+ (qrystr (conc "SELECT " keystr " FROM runs WHERE state != 'deleted';"))
+ (seen (make-hash-table)))
+ (db:with-db
+ dbstruct
+ #f
+ #f
+ (lambda (dbdat db)
+ (sqlite3:for-each-row
+ (lambda (a . x)
+ (let ((targ (cons a x)))
+ (if (not (hash-table-ref/default seen targ #f))
+ (begin
+ (hash-table-set! seen targ #t)
+ (set! res (cons (apply vector targ) res))))))
+ db
+ qrystr)
+ (debug:print-info 11 *default-log-port* "db:get-targets END qrystr: " qrystr )
+ (vector header res)))))
+
+;; just get count of runs
+(define (db:get-num-runs dbstruct runpatt)
+ (db:with-db
+ dbstruct
+ #f
+ #f
+ (lambda (dbdat db)
+ (let ((numruns 0))
+ (debug:print-info 11 *default-log-port* "db:get-num-runs START " runpatt)
+ (sqlite3:for-each-row
+ (lambda (count)
+ (set! numruns count))
+ db
+ "SELECT COUNT(id) FROM runs WHERE runname LIKE ? AND state != 'deleted';" runpatt)
+ (debug:print-info 11 *default-log-port* "db:get-num-runs END " runpatt)
+ numruns))))
+
+;; just get count of runs
+(define (db:get-runs-cnt-by-patt dbstruct runpatt targetpatt keys)
+ (db:with-db
+ dbstruct
+ #f
+ #f
+ (lambda (dbdat db)
+ (let ((numruns 0)
+ (qry-str #f)
+ (key-patt "")
+ (keyvals (if targetpatt (keys:target->keyval keys targetpatt) '())))
+
+ (for-each (lambda (keyval)
+ (let* ((key (car keyval))
+ (patt (cadr keyval))
+ (fulkey (conc ":" key))
+ (wildtype (if (substring-index "%" patt) "like" "glob")))
+
+ (if patt
+ (set! key-patt (conc key-patt " AND " key " " wildtype " '" patt "'"))
+ (begin
+ (debug:print-error 0 *default-log-port* "searching for runs with no pattern set for " fulkey)
+ (exit 6)))))
+ keyvals)
+ ;(print runpatt " -- " key-patt)
+ (set! qry-str (conc "SELECT COUNT(id) FROM runs WHERE state != 'deleted' AND runname like '" runpatt "'" key-patt))
+ ;(print qry-str )
+
+ (sqlite3:for-each-row
+ (lambda (count)
+ (set! numruns count))
+ db
+ qry-str)
+ (debug:print-info 11 *default-log-port* "db:get-num-runs END " runpatt)
+ numruns))))
+
+
+;; (sqlite3#fold-row proc3670 init3671 db-or-stmt3672 . params3673)>
+;;
+(define (db:get-raw-run-stats dbstruct run-id)
+ (db:with-db
+ dbstruct
+ run-id
+ #f
+ (lambda (dbdat db)
+ (sqlite3:fold-row
+ (lambda (res state status count)
+ (cons (list state status count) res))
+ '()
+ db
+ "SELECT state,status,count(id) AS count FROM tests WHERE run_id=? AND NOT(uname='n/a' AND item_path='') GROUP BY state,status;"
+ run-id))))
+
+;; Update run_stats for given run_id
+;; input data is a list (state status count)
+;;
+(define (db:update-run-stats dbstruct run-id stats)
+ (mutex-lock! *db-transaction-mutex*)
+ (db:with-db
+ dbstruct
+ #f
+ #t
+ (lambda (dbdat db)
+ ;; remove previous data
+
+ (let* ((stmt1 (sqlite3:prepare db "DELETE FROM run_stats WHERE run_id=? AND state=? AND status=?;"))
+ (stmt2 (sqlite3:prepare db "INSERT INTO run_stats (run_id,state,status,count) VALUES (?,?,?,?);"))
+ (res
+ (sqlite3:with-transaction
+ db
+ (lambda ()
+ (for-each
+ (lambda (dat)
+ (sqlite3:execute stmt1 run-id (car dat)(cadr dat))
+ (apply sqlite3:execute stmt2 run-id dat))
+ stats)))))
+ (sqlite3:finalize! stmt1)
+ (sqlite3:finalize! stmt2)
+ (mutex-unlock! *db-transaction-mutex*)
+ res))))
+
+(define (db:get-main-run-stats dbstruct run-id)
+ (db:with-db
+ dbstruct
+ #f ;; this data comes from main
+ #f
+ (lambda (dbdat db)
+ (sqlite3:fold-row
+ (lambda (res state status count)
+ (cons (list state status count) res))
+ '()
+ db
+ "SELECT state,status,count FROM run_stats WHERE run_id=? AND run_id IN (SELECT id FROM runs WHERE state NOT IN ('DELETED','deleted'));"
+ run-id))))
+
+(define (db:print-current-query-stats)
+ ;; generate stats from *db-api-call-time*
+ (let ((ordered-keys (sort (hash-table-keys *db-api-call-time*)
+ (lambda (a b)
+ (let ((sum-a (common:sum (hash-table-ref *db-api-call-time* a)))
+ (sum-b (common:sum (hash-table-ref *db-api-call-time* b))))
+ (> sum-a sum-b)))))
+ (total 0))
+ (for-each
+ (lambda (cmd-key)
+ (let* ((dat (hash-table-ref *db-api-call-time* cmd-key))
+ (num (length dat))
+ (avg (if (> num 0)
+ (/ (common:sum dat)(length dat)))))
+ (set! total (+ total num))
+ (debug:print-info 0 *default-log-port* cmd-key "\tavg: " avg " max: " (common:max dat) " min: " (common:min-max < dat) " num: " (length dat))))
+ ordered-keys)
+ (debug:print-info 0 *default-log-port* "TOTAL: " total " api calls since start.")))
+
+(define (db:get-all-run-ids dbstruct)
+ (db:with-db
+ dbstruct
+ #f
+ #f
+ (lambda (dbdat db)
+ (let ((run-ids '()))
+ (sqlite3:for-each-row
+ (lambda (run-id)
+ (set! run-ids (cons run-id run-ids)))
+ db
+ "SELECT id FROM runs WHERE state != 'deleted' ORDER BY event_time DESC;")
+ (reverse run-ids)))))
+
+;; get some basic run stats
+;;
+;; data structure:
+;;
+;; ( (runname (( state count ) ... ))
+;; ( ...
+;;
+(define (db:get-run-stats dbstruct)
+ (let* ((totals (make-hash-table))
+ (curr (make-hash-table))
+ (res '())
+ (runs-info '()))
+ ;; First get all the runname/run-ids
+ (db:with-db
+ dbstruct #f #f
+ (lambda (dbdat db)
+ (sqlite3:for-each-row
+ (lambda (run-id runname)
+ (set! runs-info (cons (list run-id runname) runs-info)))
+ db
+ "SELECT id,runname FROM runs WHERE state != 'deleted' ORDER BY event_time DESC;"))) ;; If you change this to the more logical ASC please adjust calls to db:get-run-stats
+ ;; for each run get stats data
+ (for-each
+ (lambda (run-info)
+ ;; get the net state/status counts for this run
+ (let* ((run-id (car run-info))
+ (run-name (cadr run-info)))
+ (db:with-db
+ dbstruct
+ run-id
+ #f
+ (lambda (dbdat db)
+ (sqlite3:for-each-row
+ (lambda (state status count)
+ (let ((netstate (if (equal? state "COMPLETED") status state)))
+ (if (string? netstate)
+ (begin
+ (hash-table-set! totals netstate (+ (hash-table-ref/default totals netstate 0) count))
+ (hash-table-set! curr netstate (+ (hash-table-ref/default curr netstate 0) count))))))
+ db
+ "SELECT state,status,count(id) FROM tests AS t WHERE run_id=? GROUP BY state,status ORDER BY state,status DESC;"
+ run-id)
+ ;; add the per run counts to res
+ (for-each (lambda (state)
+ (set! res (cons (list run-name state (hash-table-ref curr state)) res)))
+ (sort (hash-table-keys curr) string>=))
+ (set! curr (make-hash-table))))))
+ runs-info)
+ (for-each (lambda (state)
+ (set! res (cons (list "Totals" state (hash-table-ref totals state)) res)))
+ (sort (hash-table-keys totals) string>=))
+ res))
+
+;; db:get-runs-by-patt
+;; get runs by list of criteria
+;; register a test run with the db
+;;
+;; Use: (db:get-value-by-header (db:get-header runinfo)(db:get-rows runinfo))
+;; to extract info from the structure returned
+;;
+(define (db:get-runs-by-patt dbstruct keys runnamepatt targpatt offset limit fields last-update sort-order ) ;; test-name)
+ (let* ((tmp (runs:get-std-run-fields keys (or fields '("id" "runname" "state" "status" "owner" "event_time"))))
+ (keystr (car tmp))
+ (header (cadr tmp))
+ (key-patt "")
+ (runwildtype (if (substring-index "%" runnamepatt) "like" "glob"))
+ (qry-str #f)
+ (keyvals (if targpatt (keys:target->keyval keys targpatt) '())))
+ (for-each (lambda (keyval)
+ (let* ((key (car keyval))
+ (patt (cadr keyval))
+ (fulkey (conc ":" key))
+ (wildtype (if (substring-index "%" patt) "like" "glob")))
+ (if patt
+ (set! key-patt (conc key-patt " AND " key " " wildtype " '" patt "'"))
+ (begin
+ (debug:print-error 0 *default-log-port* "searching for runs with no pattern set for " fulkey)
+ (exit 6)))))
+ keyvals)
+ (set! qry-str (conc "SELECT " keystr " FROM runs WHERE state != 'deleted' AND runname " runwildtype " ? " key-patt
+ (if last-update
+ (conc " AND last_update >= " last-update " ")
+ " ")
+ " ORDER BY event_time " sort-order " "
+ (if limit (conc " LIMIT " limit) "")
+ (if offset (conc " OFFSET " offset) "")
+ ";"))
+ (debug:print-info 4 *default-log-port* "runs:get-runs-by-patt qry=" qry-str " " runnamepatt)
+ ;(print "runs:get-runs-by-patt qry=" qry-str " " runnamepatt)
+
+ (vector header
+ (reverse
+ (db:with-db
+ dbstruct #f #f ;; reads db, does not write to it.
+ (lambda (dbdat db)
+ (sqlite3:fold-row
+ (lambda (res . r)
+ (cons (list->vector r) res))
+ '()
+ db
+ qry-str
+ runnamepatt)))))))
+
+;; use (get-value-by-header (db:get-header runinfo)(db:get-rows runinfo))
+;; NOTE: Does NOT return a list of rows (or one row) for the first slot of the vector
+;; this is inconsistent with get-runs but it makes some sense.
+;;
+(define (db:get-run-info dbstruct run-id)
+ ;;(if (hash-table-ref/default *run-info-cache* run-id #f)
+ ;; (hash-table-ref *run-info-cache* run-id)
+ (let* ((res (vector #f #f #f #f))
+ (keys (db:get-keys dbstruct))
+ (remfields (list "id" "runname" "state" "status" "owner" "event_time" "comment" "fail_count" "pass_count" "contour" "last_update")) ;; "area_id"))
+ (header (append keys remfields))
+ (keystr (conc (keys->keystr keys) ","
+ (string-intersperse remfields ","))))
+ (debug:print-info 11 *default-log-port* "db:get-run-info run-id: " run-id " header: " header " keystr: " keystr)
+
+ (db:with-db
+ dbstruct #f #f
+ (lambda (dbdat db)
+ (sqlite3:for-each-row
+ (lambda (a . x)
+ (set! res (apply vector a x)))
+ db
+ (conc "SELECT " keystr " FROM runs WHERE id=?;")
+ run-id)))
+ (debug:print-info 11 *default-log-port* "db:get-run-info run-id: " run-id " header: " header " keystr: " keystr)
+ (let ((finalres (vector header res)))
+ ;; (hash-table-set! *run-info-cache* run-id finalres)
+ finalres)))
+
+(define (db:set-comment-for-run dbstruct run-id comment)
+ (db:with-db
+ dbstruct #f #f
+ (lambda (dbdat db)
+ (sqlite3:execute db "UPDATE runs SET comment=? WHERE id=?;" comment ;; (sdb:qry 'getid comment)
+ run-id))))
+
+;; does not (obviously!) removed dependent data. But why not!!?
+(define (db:delete-run dbstruct run-id)
+ (db:with-db
+ dbstruct #f #t
+ (lambda (dbdat db)
+ (sqlite3:with-transaction
+ db
+ (lambda ()
+ (sqlite3:execute db "DELETE FROM test_steps WHERE test_id IN (SELECT id FROM tests WHERE run_id=?);" run-id)
+ (sqlite3:execute db "DELETE FROM test_data WHERE test_id IN (SELECT id FROM tests WHERE run_id=?);" run-id)
+ (sqlite3:execute db "UPDATE tests SET state='DELETED',comment='' WHERE run_id=?;" run-id)
+ ;; (db:delay-if-busy dbdat)
+ (sqlite3:execute db "UPDATE runs SET state='deleted',comment='' WHERE id=?;" run-id))))))
+
+(define (db:update-run-event_time dbstruct run-id)
+ (db:with-db
+ dbstruct #f #t
+ (lambda (dbdat db)
+ (sqlite3:execute db "UPDATE runs SET event_time=strftime('%s','now') WHERE id=?;" run-id))))
+
+(define (db:lock/unlock-run dbstruct run-id lock unlock user)
+ (db:with-db
+ dbstruct #f #t
+ (lambda (dbdat db)
+ (let ((newlockval (if lock "locked"
+ (if unlock
+ "unlocked"
+ "locked")))) ;; semi-failsafe
+ (sqlite3:execute db "UPDATE runs SET state=? WHERE id=?;" newlockval run-id)
+ (sqlite3:execute db "INSERT INTO access_log (user,accessed,args) VALUES(?,strftime('%s','now'),?);"
+ user (conc newlockval " " run-id))
+ (debug:print-info 1 *default-log-port* "" newlockval " run number " run-id)))))
+
+(define (db:set-run-status dbstruct run-id status msg)
+ (db:with-db
+ dbstruct #f #t
+ (lambda (dbdat db)
+ (if msg
+ (sqlite3:execute db "UPDATE runs SET status=?,comment=? WHERE id=?;" status msg run-id)
+ (sqlite3:execute db "UPDATE runs SET status=? WHERE id=?;" status run-id)))))
+
+(define (db:set-run-state-status-db dbdat db run-id state status )
+ (sqlite3:execute
+ (db:get-cache-stmth
+ dbdat db "UPDATE runs SET status=?,state=? WHERE id=?;") status state run-id))
+
+(define (db:set-run-state-status dbstruct run-id state status )
+ (db:with-db
+ dbstruct #f #t
+ (lambda (dbdat db)
+ (db:set-run-state-status-db dbdat db run-id state status))))
+
+(define (db:get-run-status dbstruct run-id)
+ (let ((res "n/a"))
+ (db:with-db
+ dbstruct #f #f
+ (lambda (dbdat db)
+ (sqlite3:for-each-row
+ (lambda (status)
+ (set! res status))
+ (db:get-cache-stmth
+ dbdat db
+ "SELECT status FROM runs WHERE id=?;" )
+ run-id)
+ res))))
+
+(define (db:get-run-state dbstruct run-id)
+ (let ((res "n/a"))
+ (db:with-db
+ dbstruct #f #f
+ (lambda (dbdat db)
+ (sqlite3:for-each-row
+ (lambda (status)
+ (set! res status))
+ (db:get-cache-stmth
+ dbdat db
+ "SELECT state FROM runs WHERE id=?;" )
+ run-id)
+ res))))
+
+(define (db:get-run-state-status dbstruct run-id)
+ (let ((res (cons "n/a" "n/a")))
+ (db:with-db
+ dbstruct #f #f
+ (lambda (dbdat db)
+ (sqlite3:for-each-row
+ (lambda (state status)
+ (set! res (cons state status)))
+ (db:get-cache-stmth
+ dbdat db
+ "SELECT state,status FROM runs WHERE id=?;" )
+ run-id)
+ res))))
+
+
+;;======================================================================
+;; K E Y S
+;;======================================================================
+
+;; get key val pairs for a given run-id
+;; ( (FIELDNAME1 keyval1) (FIELDNAME2 keyval2) ... )
+(define (db:get-key-val-pairs dbstruct run-id)
+ (let* ((keys (db:get-keys dbstruct))
+ (res '()))
+ (db:with-db
+ dbstruct #f #f
+ (lambda (dbdat db)
+ (for-each
+ (lambda (key)
+ (let ((qry (conc "SELECT " key " FROM runs WHERE id=?;")))
+ (sqlite3:for-each-row
+ (lambda (key-val)
+ (set! res (cons (list key (if (string? key-val) key-val "")) res))) ;; replace non-string bad values with empty string to prevent crashes. This scenario can happen when Megatest is killed on updating the db
+ db qry run-id)))
+ keys)))
+ (reverse res)))
+
+;; get key vals for a given run-id
+(define (db:get-key-vals dbstruct run-id)
+ (let* ((keys (db:get-keys dbstruct))
+ (res '()))
+ (db:with-db
+ dbstruct #f #f
+ (lambda (dbdat db)
+ (for-each
+ (lambda (key)
+ (let ((qry (conc "SELECT " key " FROM runs WHERE id=?;")))
+ ;; (db:delay-if-busy dbdat)
+ (sqlite3:for-each-row
+ (lambda (key-val)
+ (set! res (cons (if (string? key-val) key-val "") res))) ;; check that the key-val is a string for cases where a crash injected bad data in the megatest.db
+ db qry run-id)))
+ keys)))
+ (let ((final-res (reverse res)))
+ (hash-table-set! *keyvals* run-id final-res)
+ final-res)))
+
+;; The target is keyval1/keyval2..., cached in *target* as it is used often
+(define (db:get-target dbstruct run-id)
+ (let* ((keyvals (db:get-key-vals dbstruct run-id))
+ (thekey (string-intersperse (map (lambda (x)(if x x "-na-")) keyvals) "/")))
+ thekey))
+
+;; Get run-ids for runs with same target but different runnames and NOT run-id
+;;
+(define (db:get-prev-run-ids dbstruct run-id)
+ (let* ((keyvals (db:get-key-val-pairs dbstruct run-id))
+ (kvalues (map cadr keyvals))
+ (keys (db:get-keys dbstruct))
+ (qrystr (string-intersperse (map (lambda (x)(conc x "=?")) keys) " AND ")))
+ (let ((prev-run-ids '()))
+ (if (null? keyvals)
+ '()
+ (begin
+ (db:with-db dbstruct #f #f ;; #f means work with the zeroth db - i.e. the runs db
+ (lambda (dbdat db)
+ (apply sqlite3:for-each-row
+ (lambda (id)
+ (set! prev-run-ids (cons id prev-run-ids)))
+ db
+ (conc "SELECT id FROM runs WHERE " qrystr " AND state != 'deleted' AND id != ?;")
+ (append kvalues (list run-id)))))
+ prev-run-ids)))))
+
+;;======================================================================
+;; T E S T S
+;;======================================================================
+
+;; states and statuses are lists, turn them into ("PASS","FAIL"...) and use NOT IN
+;; i.e. these lists define what to NOT show.
+;; states and statuses are required to be lists, empty is ok
+;; not-in #t = above behaviour, #f = must match
+;; mode:
+;; 'dashboard - use state = 'COMPLETED' AND status in ( statuses ) OR state in ( states )
+;;
+(define (db:get-tests-for-run dbstruct run-id testpatt states statuses offset limit not-in sort-by sort-order qryvals last-update mode)
+ (let* ((qryvalstr (case qryvals
+ ((shortlist) "id,run_id,testname,item_path,state,status")
+ ((#f) db:test-record-qry-selector) ;; "id,run_id,testname,state,status,event_time,host,cpuload,diskfree,uname,rundir,item_path,run_duration,final_logf,comment")
+ (else qryvals)))
+ (res '())
+ ;; if states or statuses are null then assume match all when not-in is false
+ (states-qry (if (null? states)
+ #f
+ (conc " state "
+ (if (eq? mode 'dashboard)
+ " IN ('"
+ (if not-in
+ " NOT IN ('"
+ " IN ('"))
+ (string-intersperse states "','")
+ "')")))
+ (statuses-qry (if (null? statuses)
+ #f
+ (conc " status "
+ (if (eq? mode 'dashboard)
+ " IN ('"
+ (if not-in
+ " NOT IN ('"
+ " IN ('") )
+ (string-intersperse statuses "','")
+ "')")))
+ (interim-qry (conc " AND " (if not-in "NOT " "") "( state='COMPLETED' " (if statuses-qry (conc " AND " statuses-qry " ) ") " ) ")
+ (if states-qry
+ (conc (if not-in " AND " " OR ") states-qry ) ;; " ) ")
+ "")))
+ (states-statuses-qry
+ (cond
+ ((and states-qry statuses-qry)
+ (case mode
+ ((dashboard)
+ (if not-in
+ (conc " AND (state='COMPLETED' AND status NOT IN ('" (string-intersperse statuses "','") "')) "
+ " OR (state != 'COMPLETED' AND state NOT IN ('" (string-intersperse states "','") "')) ")
+ (conc " AND (state='COMPLETED' AND status IN ('" (string-intersperse statuses "','") "')) "
+ " OR (state NOT IN ('COMPLETED','DELETED') AND state IN ('" (string-intersperse states "','") "')) ")))
+ (else (conc " AND ( " states-qry " AND " statuses-qry " ) "))))
+ (states-qry
+ (case mode
+ ((dashboard) (conc " AND " (if not-in "NOT " "") " state IN ('" (string-intersperse states "','") "') ")) ;; interim-qry)
+ (else (conc " AND " states-qry))))
+ (statuses-qry
+ (case mode
+ ((dashboard) (conc " AND " (if not-in "NOT " "") " status IN ('" (string-intersperse statuses "','") "') ")) ;; interim-qry)
+ (else (conc " AND " statuses-qry))))
+ (else "")))
+ (tests-match-qry (tests:match->sqlqry testpatt))
+ (qry (conc "SELECT " qryvalstr
+ (if run-id
+ " FROM tests WHERE run_id=? "
+ " FROM tests WHERE ? > 0 ") ;; should work?
+ (if last-update " " " AND state != 'DELETED' ") ;; if using last-update we want deleted tests?
+ states-statuses-qry
+ (if tests-match-qry (conc " AND (" tests-match-qry ") ") "")
+ (if last-update (conc " AND last_update >= " last-update " ") "")
+ (case sort-by
+ ((rundir) " ORDER BY length(rundir) ")
+ ((testname) (conc " ORDER BY testname " (if sort-order (conc sort-order ",") "") " item_path "))
+ ((statestatus) (conc " ORDER BY state " (if sort-order (conc sort-order ",") "") " status "))
+ ((event_time) " ORDER BY event_time ")
+ (else (if (string? sort-by)
+ (conc " ORDER BY " sort-by " ")
+ " ")))
+ (if sort-order sort-order " ")
+ (if limit (conc " LIMIT " limit) " ")
+ (if offset (conc " OFFSET " offset) " ")
+ ";"
+ )))
+ (debug:print-info 8 *default-log-port* "db:get-tests-for-run run-id=" run-id ", qry=" qry)
+ (let* ((res (db:with-db dbstruct run-id #f
+ (lambda (dbdat db)
+ ;; (let* ((stmth (db:get-cache-stmth dbstruct db qry))) ;; due to use of last-update we can't efficiently cache this query
+ (reverse
+ (sqlite3:fold-row
+ (lambda (res . row)
+ ;; id run-id testname state status event-time host cpuload
+ ;; diskfree uname rundir item-path run-duration final-logf comment)
+ (cons (list->vector row) res))
+ '()
+ db qry ;; stmth
+ (or run-id 1) ;; 1 > 0 , for the case where we are seeking tests matching criteral for all runs
+ ))))))
+ (case qryvals
+ ((shortlist)(map db:test-short-record->norm res))
+ ((#f) res)
+ (else res)))))
+
+(define (db:test-short-record->norm inrec)
+ ;; "id,run_id,testname,item_path,state,status"
+ ;; "id,run_id,testname,state,status,event_time,host,cpuload,diskfree,uname,rundir,item_path,run_duration,final_logf,comment
+ (vector (vector-ref inrec 0) ;; id
+ (vector-ref inrec 1) ;; run_id
+ (vector-ref inrec 2) ;; testname
+ (vector-ref inrec 4) ;; state
+ (vector-ref inrec 5) ;; status
+ -1 "" -1 -1 "" "-"
+ (vector-ref inrec 3) ;; item-path
+ -1 "-" "-"))
+
+;;
+;; 1. cache tests-match-qry
+;; 2. compile qry and store in hash
+;; 3. convert for-each-row to fold
+;;
+;; (define (db:get-tests-for-run-state-status dbstruct run-id testpatt)
+;; (db:with-db
+;; dbstruct run-id #f
+;; (lambda (dbdat db)
+;; (let* ((res '())
+;; (stmt-cache (dbr:dbstruct-stmt-cache dbstruct))
+;; (stmth (let* ((sh (db:hoh-get stmt-cache db testpatt)))
+;; (or sh
+;; (let* ((tests-match-qry (tests:match->sqlqry testpatt))
+;; (qry (conc "SELECT id,testname,item_path,state,status FROM tests WHERE run_id=? "
+;; (if tests-match-qry (conc " AND (" tests-match-qry ") ") "")))
+;; (newsh (sqlite3:prepare db qry)))
+;; (debug:print-info 8 *default-log-port* "db:get-tests-for-run qry=" qry)
+;; (db:hoh-set! stmt-cache db testpatt newsh)
+;; newsh)))))
+;; (reverse
+;; (sqlite3:fold-row
+;; (lambda (res id testname item-path state status)
+;; ;; id,run_id,testname,state,status,event_time,host,cpuload,diskfree,uname,rundir,item_path,run_duration,final_logf,comment
+;; (cons (vector id run-id testname state status -1 "" -1 -1 "" "-" item-path -1 "-" "-") res))
+;; '()
+;; stmth
+;; run-id))))))
+
+(define (db:get-tests-for-run-state-status dbstruct run-id testpatt #!optional (last-update 0))
+ (let* ((res '())
+ (tests-match-qry (tests:match->sqlqry testpatt))
+ (qry (conc "SELECT id,testname,item_path,state,status,event_time,run_duration FROM tests WHERE run_id=? "
+ " AND last_update > ? "
+ (if tests-match-qry (conc " AND (" tests-match-qry ") ") "")
+ )))
+ (debug:print-info 8 *default-log-port* "db:get-tests-for-run qry=" qry)
+ (db:with-db dbstruct run-id #f
+ (lambda (dbdat db)
+ (sqlite3:fold-row
+ (lambda (res id testname item-path state status event-time run-duration)
+ ;; id,run_id,testname,state,status,event_time,host,cpuload,diskfree,uname,rundir,item_path,run_duration,final_logf,comment
+ (cons (vector id run-id testname state status event-time "" -1 -1 "" "-" item-path run-duration "-" "-") res))
+ '()
+ db
+ qry
+ run-id
+ (or last-update 0))))))
+
+(define (db:get-testinfo-state-status dbstruct run-id test-id)
+ (db:with-db
+ dbstruct run-id #f
+ (lambda (dbdat db)
+ (let* ((res #f)
+ (stmth (db:get-cache-stmth dbdat db "SELECT run_id,testname,item_path,state,status FROM tests WHERE id=? and run_id=?;")))
+ (sqlite3:for-each-row
+ (lambda (run-id testname item-path state status)
+ ;; id,run_id,testname,state,status,event_time,host,cpuload,diskfree,uname,rundir,item_path,run_duration,final_logf,comment
+ (set! res (vector test-id run-id testname state status -1 "" -1 -1 "" "-" item-path -1 "-" "-")))
+ ;; db
+ ;; "SELECT run_id,testname,item_path,state,status FROM tests WHERE id=? and run_id=?;"
+ stmth
+ test-id run-id)
+ res))))
+
+;; get a useful subset of the tests data (used in dashboard
+;; use db:mintest-get-{id ,run_id,testname ...}
+;;
+(define (db:get-tests-for-run-mindata dbstruct run-id testpatt states statuses not-in)
+ (db:get-tests-for-run dbstruct run-id testpatt states statuses #f #f not-in #f #f "id,run_id,testname,state,status,event_time,item_path" 0 #f))
+
+;; do not use.
+;;
+(define (db:get-tests-for-runs dbstruct run-ids testpatt states statuses #!key (not-in #f)(qryvals #f))
+ ;; (db:delay-if-busy)
+ (let ((res '()))
+ (for-each
+ (lambda (run-id)
+ (set! res (append
+ res
+ (db:get-tests-for-run dbstruct run-id testpatt states statuses #f #f not-in #f #f qryvals #f 'normal))))
+ (if run-ids
+ run-ids
+ (db:get-all-run-ids dbstruct)))
+ res))
+
+;; Convert calling routines to get list of run-ids and loop, do not use the get-tests-for-runs
+;;
+
+(define (db:delete-test-records dbstruct run-id test-id)
+ (db:general-call dbstruct run-id 'delete-test-step-records (list test-id))
+ (db:general-call dbstruct run-id 'delete-test-data-records (list test-id))
+ (db:with-db
+ dbstruct run-id #t
+ (lambda (dbdat db)
+ (sqlite3:execute db "UPDATE tests SET state='DELETED',status='n/a',comment='' WHERE id=?;" test-id))))
+
+;;
+(define (db:delete-old-deleted-test-records dbstruct run-id)
+ (let* ((targtime (- (current-seconds)
+ (or (configf:lookup-number *configdat* "setup" "keep-deleted-records")
+ (* 7 24 60 60)))) ;; cleanup if over one week old
+ (mtdbfile (dbmod:run-id->full-dbfname dbstruct run-id))
+ (qry1 "DELETE FROM test_steps WHERE test_id IN (SELECT id FROM tests WHERE state='DELETED' AND event_timenumber fieldname fields)
+ (if (null? fields)
+ #f
+ (let loop ((hed (car fields))
+ (tal (cdr fields))
+ (indx 0))
+ (if (equal? fieldname hed)
+ indx
+ (if (null? tal)
+ #f
+ (loop (car tal)(cdr tal)(+ indx 1)))))))
+
+(define db:test-record-qry-selector (string-intersperse db:test-record-fields ","))
+
+(define (db:update-tesdata-on-repilcate-db dbstruct old-lt new-lt)
+ (db:with-db
+ dbstruct #f #t
+ (lambda (dbdat db)
+ (sqlite3:execute db "UPDATE tests SET rundir= replace(rundir,?,?), shortdir=replace(shortdir,?,?);"
+ old-lt new-lt old-lt new-lt))))
+
+;; NOTE: Use db:test-get* to access records
+;; NOTE: This needs rundir decoding? Decide, decode here or where used? For the moment decode where used.
+(define (db:get-all-tests-info-by-run-id dbstruct run-id)
+ (let* ((res '()))
+ (db:with-db
+ dbstruct #f #f
+ (lambda (dbdat db)
+ (sqlite3:for-each-row
+ (lambda (id run-id testname state status event-time host cpuload diskfree uname rundir item-path run-duration final-logf comment shortdir attemptnum archived)
+ ;; 0 1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16
+ (set! res (cons (vector id run-id testname state status event-time host cpuload diskfree uname rundir item-path run-duration final-logf comment shortdir attemptnum archived)
+ res)))
+ db
+ (conc "SELECT " db:test-record-qry-selector " FROM tests WHERE state != 'DELETED' AND run_id=?;")
+ run-id)))
+ res))
+
+(define (db:replace-test-records dbstruct run-id testrecs)
+ (db:with-db dbstruct run-id #t
+ (lambda (dbdat db)
+ (let* ((qmarks (string-intersperse (make-list (length db:test-record-fields) "?") ","))
+ (qrystr (conc "INSERT OR REPLACE INTO tests (" db:test-record-qry-selector ") VALUES (" qmarks ") WHERE run_id=?;"))
+ (qry (sqlite3:prepare db qrystr)))
+ (debug:print 0 *default-log-port* "INFO: migrating test records for run with id " run-id)
+ (sqlite3:with-transaction
+ db
+ (lambda ()
+ (for-each
+ (lambda (rec)
+ ;; (debug:print 0 *default-log-port* "INFO: Inserting values: " (string-intersperse (map conc (vector->list rec)) ",") "\n")
+ (apply sqlite3:execute qry (append (vector->list rec)(list run-id))))
+ testrecs)))
+ (sqlite3:finalize! qry)))))
+
+;; map a test-id into the proper range
+;;
+(define (db:adj-test-id mtdb min-test-id test-id)
+ (if (>= test-id min-test-id)
+ test-id
+ (let loop ((new-id min-test-id))
+ (let ((test-id-found #f))
+ (sqlite3:for-each-row
+ (lambda (id)
+ (set! test-id-found id))
+ (dbr:dbdat-dbh mtdb)
+ "SELECT id FROM tests WHERE id=?;"
+ new-id)
+ ;; if test-id-found then need to try again
+ (if test-id-found
+ (loop (+ new-id 1))
+ (begin
+ (debug:print-info 0 *default-log-port* "New test id " new-id " selected for test with id " test-id)
+ (sqlite3:execute mtdb "UPDATE tests SET id=? WHERE id=?;" new-id test-id)))))))
+
+;; move test ids into the 30k * run_id range
+;;
+(define (db:prep-megatest.db-adj-test-ids mtdb run-id testrecs)
+ (debug:print-info 0 *default-log-port* "Adjusting test ids in megatest.db for run " run-id)
+ (let ((min-test-id (* run-id 30000)))
+ (for-each
+ (lambda (testrec)
+ (let* ((test-id (vector-ref testrec (db:field->number "id" db:test-record-fields))))
+ (db:adj-test-id (dbr:dbdat-dbh mtdb) min-test-id test-id)))
+ testrecs)))
+
+;; 1. move test ids into the 30k * run_id range
+;; 2. move step ids into the 30k * run_id range
+;;
+(define (db:prep-megatest.db-for-migration mtdb)
+ (let* ((run-ids (db:get-all-run-ids mtdb)))
+ (for-each
+ (lambda (run-id)
+ (let ((testrecs (db:get-all-tests-info-by-run-id mtdb run-id)))
+ (db:prep-megatest.db-adj-test-ids (dbr:dbdat-dbh mtdb) run-id testrecs)))
+ run-ids)))
+
+;; Get test data using test_id
+;;
+(define (db:get-test-info-by-id dbstruct run-id test-id)
+ (db:with-db
+ dbstruct
+ run-id
+ #f
+ (lambda (dbdat db)
+ (let ((res #f))
+ (sqlite3:for-each-row ;; attemptnum added to hold pid of top process (not Megatest) controlling a test
+ (lambda (id run-id testname state status event-time host cpuload diskfree uname rundir-id item-path run_duration final-logf-id comment short-dir-id attemptnum archived last-update)
+ ;; 0 1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16
+ (set! res (vector id run-id testname state status event-time host cpuload diskfree uname rundir-id item-path run_duration final-logf-id comment short-dir-id attemptnum archived last-update)))
+ db
+ ;; (db:get-cache-stmth dbdat db
+ ;; (conc "SELECT " db:test-record-qry-selector " FROM tests WHERE id=? AND run_id=?;"))
+ (conc "SELECT " db:test-record-qry-selector " FROM tests WHERE id=? AND run_id=?;")
+ test-id run-id)
+ res))))
+
+;; Get test state, status using test_id
+;;
+(define (db:get-test-state-status-by-id dbstruct run-id test-id)
+ (db:with-db
+ dbstruct
+ run-id
+ #f
+ (lambda (dbdat db)
+ (let ((res (cons #f #f))
+ (stmth (db:get-cache-stmth dbdat db "SELECT state,status FROM tests WHERE id=? AND run_id=?;")))
+ (sqlite3:for-each-row ;; attemptnum added to hold pid of top process (not Megatest) controlling a test
+ (lambda (state status)
+ (cons state status))
+ ;; db
+ stmth ;;"SELECT state,status FROM tests WHERE id=? AND run_id=?;" ;; stmth try not compiling this one - yes, this fixed the bind issue
+ test-id run-id)
+ res))))
+
+;; Use db:test-get* to access
+;; Get test data using test_ids. NB// Only works within a single run!!
+;;
+(define (db:get-test-info-by-ids dbstruct run-id test-ids)
+ (db:with-db
+ dbstruct
+ run-id
+ #f
+ (lambda (dbdat db)
+ (let ((res '()))
+ (sqlite3:for-each-row
+ (lambda (a . b)
+ ;; 0 1 2 3 4 5 6 7 8 9 10 11 12 13 14
+ (set! res (cons (apply vector a b) res)))
+ db
+ (conc "SELECT " db:test-record-qry-selector " FROM tests WHERE id in ("
+ (string-intersperse (map conc test-ids) ",") ");"))
+ res))))
+
+;; try every second until tries times proc
+;;
+(define (db:keep-trying-until-true proc params tries)
+ (let* ((res (apply proc params)))
+ (if res
+ res
+ (if (> tries 0)
+ (begin
+ (thread-sleep! 1)
+ (db:keep-trying-until-true proc params (- tries 1)))
+ (begin
+ ;; (debug:print-info 0 *default-log-port* "proc never returned true, params="params)
+ (print"db:keep-trying-until-true proc never returned true, proc = " proc " params =" params " tries = " tries)
+ #f)))))
+
+(define (db:get-test-info dbstruct run-id test-name item-path)
+ (db:with-db
+ dbstruct
+ run-id
+ #f
+ (lambda (dbdat db)
+ (db:get-test-info-db db run-id test-name item-path))))
+
+(define (db:get-test-info-db db run-id test-name item-path)
+ (let ((res #f))
+ (sqlite3:for-each-row
+ (lambda (a . b)
+ (set! res (apply vector a b)))
+ db
+ (conc "SELECT " db:test-record-qry-selector " FROM tests WHERE testname=? AND item_path=? AND run_id=?;")
+ test-name item-path run-id)
+ res))
+
+(define (db:test-get-rundir-from-test-id dbstruct run-id test-id)
+ (db:with-db
+ dbstruct
+ run-id
+ #f
+ (lambda (dbdat db)
+ (db:first-result-default
+ db
+ "SELECT rundir FROM tests WHERE id=? AND run_id=?;"
+ #f ;; default result
+ test-id run-id))))
+
+(define (db:get-test-times dbstruct run-name target)
+ (let ((res `())
+ (qry (conc "select testname, item_path, run_duration, "
+ (string-join (db:get-keys dbstruct) " || '/' || ")
+ " as target from tests inner join runs on tests.run_id = runs.id where runs.runname = ? and target = ? ;")))
+ (db:with-db
+ dbstruct
+ #f ;; this is for the main runs db
+ #f ;; does not modify db
+ (lambda (dbdat db)
+ (sqlite3:for-each-row
+ (lambda (test-name item-path test-time target )
+ (set! res (cons (vector test-name item-path test-time) res)))
+ db
+ qry
+ run-name target)
+ res))))
+
+;;======================================================================
+;; S T E P S
+;;======================================================================
+
+(define (db:teststep-set-status! dbstruct run-id test-id teststep-name state-in status-in comment logfile)
+ (db:with-db
+ dbstruct
+ run-id
+ #t
+ (lambda (dbdat db)
+ (sqlite3:execute
+ db
+ "INSERT OR REPLACE into test_steps (test_id,stepname,state,status,event_time,comment,logfile) VALUES(?,?,?,?,?,?,?);"
+ test-id teststep-name state-in status-in (current-seconds)
+ (if comment comment "")
+ (if logfile logfile "")))))
+
+
+
+(define (db:delete-steps-for-test! dbstruct run-id test-id)
+ ;; TODO: figure out why status is the key field rather than state (note: CONSTRAINT test_steps_constraint UNIQUE (test_id,stepname,state) )
+ (db:with-db
+ dbstruct
+ run-id
+ #t
+ (lambda (dbdat db)
+ (sqlite3:execute
+ db
+ "UPDATE test_steps set status='DELETED' where test_id=?" ;; and run_id=? !! - run_id not in table (bummer) TODO: get run_id into schema for test_steps
+ test-id))))
+
+
+;; db-get-test-steps-for-run
+(define (db:get-steps-for-test dbstruct run-id test-id)
+ (db:with-db
+ dbstruct
+ run-id
+ #f
+ (lambda (dbdat db)
+ (let* ((res '()))
+ (sqlite3:for-each-row
+ (lambda (id test-id stepname state status event-time logfile comment)
+ (set! res (cons (vector id test-id stepname state status event-time (if (string? logfile) logfile "") comment) res)))
+ db
+ "SELECT id,test_id,stepname,state,status,event_time,logfile,comment FROM test_steps WHERE status != 'DELETED' AND test_id=? ORDER BY id ASC;" ;; event_time DESC,id ASC;
+ test-id)
+ (reverse res)))))
+
+ (define (db:get-steps-info-by-id dbstruct run-id test-step-id)
+ (db:with-db
+ dbstruct
+ run-id
+ #f
+ (lambda (dbdat db)
+ (let* ((res (vector #f #f #f #f #f #f #f #f #f)))
+ (sqlite3:for-each-row
+ (lambda (id test-id stepname state status event-time logfile comment last-update)
+ (set! res (vector id test-id stepname state status event-time (if (string? logfile) logfile "") comment last-update)))
+ db
+ "SELECT id,test_id,stepname,state,status,event_time,logfile,comment,last_update FROM test_steps WHERE id=? ORDER BY id ASC;" ;; event_time DESC,id ASC;
+ test-step-id)
+ res))))
+
+(define (db:get-steps-data dbstruct run-id test-id)
+ (db:with-db
+ dbstruct
+ run-id
+ #f
+ (lambda (dbdat db)
+ (let ((res '()))
+ (sqlite3:for-each-row
+ (lambda (id test-id stepname state status event-time logfile)
+ (set! res (cons (vector id test-id stepname state status event-time (if (string? logfile) logfile "")) res)))
+ db
+ "SELECT id,test_id,stepname,state,status,event_time,logfile FROM test_steps WHERE status != 'DELETED' AND test_id=? ORDER BY id ASC;" ;; event_time DESC,id ASC;
+ test-id)
+ (reverse res)))))
+
+;;======================================================================
+;; T E S T D A T A
+;;======================================================================
+
+(define (db:get-data-info-by-id dbstruct run-id test-data-id)
+ (let* ((stmt "SELECT id,test_id, category, variable, value, expected, tol, units, comment, status, type, last_update FROM test_data WHERE id=? ORDER BY id ASC;")) ;; event_time DESC,id ASC;
+ (db:with-db
+ dbstruct
+ run-id
+ #f
+ (lambda (dbdat db)
+ (let* ((stmth (db:get-cache-stmth dbdat db stmt))
+ (res (sqlite3:fold-row
+ (lambda (res id test-id category variable value expected tol units comment status type last-update)
+ (vector id test-id category variable value expected tol units comment status type last-update))
+ (vector #f #f #f #f #f #f #f #f #f #f #f #f)
+ stmth
+ test-data-id)))
+ res)))))
+
+;; WARNING: Do NOT call this for the parent test on an iterated test
+;; Roll up test_data pass/fail results
+;; look at the test_data status field,
+;; if all are pass (any case) and the test status is PASS or NULL or '' then set test status to PASS.
+;; if one or more are fail (any case) then set test status to PASS, non "pass" or "fail" are ignored
+(define (db:test-data-rollup dbstruct run-id test-id status)
+ (let* ((fail-count 0)
+ (pass-count 0))
+ (db:with-db
+ dbstruct run-id #t
+ (lambda (dbdat db)
+ (sqlite3:for-each-row
+ (lambda (fcount pcount)
+ (set! fail-count fcount)
+ (set! pass-count pcount))
+ db
+ "SELECT (SELECT count(id) FROM test_data WHERE test_id=? AND status like 'fail') AS fail_count,
+ (SELECT count(id) FROM test_data WHERE test_id=? AND status like 'pass') AS pass_count;"
+ test-id test-id)
+ ;; Now rollup the counts to the central megatest.db
+ (db:general-call dbstruct run-id 'pass-fail-counts (list pass-count fail-count test-id))
+ ;; if the test is not FAIL then set status based on the fail and pass counts.
+ (db:general-call dbstruct run-id 'test_data-pf-rollup (list test-id test-id test-id test-id))))))
+
+;; each section is a rule except "final" which is the final result
+;;
+;; [rule-5]
+;; operator in
+;; section LogFileBody
+;; desc Output voltage
+;; status OK
+;; expected 1.9
+;; measured 1.8
+;; type +/-
+;; tolerance 0.1
+;; pass 1
+;; fail 0
+;;
+;; [final]
+;; exit-code 6
+;; exit-status SKIP
+;; message If flagged we are asking for this to exit with code 6
+;;
+;; recorded in steps table:
+;; category: stepname
+;; variable: rule-N
+;; value: measured
+;; expected: expected
+;; tol: tolerance
+;; units: -
+;; comment: desc or message
+;; status: status
+;; type: type
+;;
+(define (db:logpro-dat->csv dat stepname)
+ (let ((res '()))
+ (for-each
+ (lambda (entry-name)
+ (if (equal? entry-name "final")
+ (set! res (append
+ res
+ (list
+ (list stepname
+ entry-name
+ (configf:lookup dat entry-name "exit-code") ;; 0 ;; Value
+ 0 ;; 1 ;; Expected
+ 0 ;; 2 ;; Tolerance
+ "n/a" ;; 3 ;; Units
+ (configf:lookup dat entry-name "message") ;; 4 ;; Comment
+ (configf:lookup dat entry-name "exit-status") ;; 5 ;; Status
+ "logpro" ;; 6 ;; Type
+ ))))
+ (let* ((value (or (configf:lookup dat entry-name "measured") "n/a"))
+ (expected (or (configf:lookup dat entry-name "expected") 0.0))
+ (tolerance (or (configf:lookup dat entry-name "tolerance") 0.0))
+ (comment (or (configf:lookup dat entry-name "comment")
+ (configf:lookup dat entry-name "desc") "n/a"))
+ (status (or (configf:lookup dat entry-name "status") "n/a"))
+ (type (or (configf:lookup dat entry-name "expected") "n/a")))
+ (set! res (append
+ res
+ (list (list stepname
+ entry-name
+ value ;; 0
+ expected ;; 1
+ tolerance ;; 2
+ "n/a" ;; 3 Units
+ comment ;; 4
+ status ;; 5
+ type ;; 6
+ )))))))
+ (hash-table-keys dat))
+ res))
+
+;; $MT_MEGATEST -load-test-data << EOF
+;; foo,bar, 1.2, 1.9, >
+;; foo,rab, 1.0e9, 10e9, 1e9
+;; foo,bla, 1.2, 1.9, <
+;; foo,bal, 1.2, 1.2, < , ,Check for overload
+;; foo,alb, 1.2, 1.2, <= , Amps,This is the high power circuit test
+;; foo,abl, 1.2, 1.3, 0.1
+;; foo,bra, 1.2, pass, silly stuff
+;; faz,bar, 10, 8mA, , ,"this is a comment"
+;; EOF
+
+(define (db:csv->test-data dbstruct run-id test-id csvdata)
+ (debug:print 4 *default-log-port* "test-id " test-id ", csvdata: " csvdata)
+ (db:with-db
+ dbstruct #f #t
+ (lambda (dbdat db)
+ (let* ((csvlist (csv->list (make-csv-reader
+ (open-input-string csvdata)
+ '((strip-leading-whitespace? #t)
+ (strip-trailing-whitespace? #t)))))) ;; (csv->list csvdata)))
+ (for-each
+ (lambda (csvrow)
+ (let* ((padded-row (take (append csvrow (list #f #f #f #f #f #f #f #f #f)) 9))
+ (category (list-ref padded-row 0))
+ (variable (list-ref padded-row 1))
+ (value (any->number-if-possible (list-ref padded-row 2)))
+ (expected (any->number-if-possible (list-ref padded-row 3)))
+ (tol (any->number-if-possible (list-ref padded-row 4))) ;; >, <, >=, <=, or a number
+ (units (list-ref padded-row 5))
+ (comment (list-ref padded-row 6))
+ (status (let ((s (list-ref padded-row 7)))
+ (if (and (string? s)(or (string-match (regexp "^\\s*$") s)
+ (string-match (regexp "^n/a$") s)))
+ #f
+ s))) ;; if specified on the input then use, else calculate
+ (type (list-ref padded-row 8)))
+ ;; look up expected,tol,units from previous best fit test if they are all either #f or ''
+ (debug:print 4 *default-log-port* "BEFORE: category: " category " variable: " variable " value: " value
+ ", expected: " expected " tol: " tol " units: " units " status: " status " comment: " comment " type: " type)
+
+ (if (and (or (not expected)(equal? expected ""))
+ (or (not tol) (equal? expected ""))
+ (or (not units) (equal? expected "")))
+ (let-values (((new-expected new-tol new-units)(tdb:get-prev-tol-for-test #f test-id category variable)))
+ (set! expected new-expected)
+ (set! tol new-tol)
+ (set! units new-units)))
+
+ (debug:print 4 *default-log-port* "AFTER: category: " category " variable: " variable " value: " value
+ ", expected: " expected " tol: " tol " units: " units " status: " status " comment: " comment)
+ ;; calculate status if NOT specified
+ (if (and (not status)(number? expected)(number? value)) ;; need expected and value to be numbers
+ (if (number? tol) ;; if tol is a number then we do the standard comparison
+ (let* ((max-val (+ expected tol))
+ (min-val (- expected tol))
+ (result (and (>= value min-val)(<= value max-val))))
+ (debug:print 4 *default-log-port* "max-val: " max-val " min-val: " min-val " result: " result)
+ (set! status (if result "pass" "fail")))
+ (set! status ;; NB// need to assess each one (i.e. not return operator since need to act if not valid op.
+ (case (string->symbol tol) ;; tol should be >, <, >=, <=
+ ((>) (if (> value expected) "pass" "fail"))
+ ((<) (if (< value expected) "pass" "fail"))
+ ((>=) (if (>= value expected) "pass" "fail"))
+ ((<=) (if (<= value expected) "pass" "fail"))
+ (else (conc "ERROR: bad tol comparator " tol))))))
+ (debug:print 4 *default-log-port* "AFTER2: category: " category " variable: " variable " value: " value
+ ", expected: " expected " tol: " tol " units: " units " status: " status " comment: " comment)
+ ;; (db:delay-if-busy dbdat)
+ (sqlite3:execute db "INSERT OR REPLACE INTO test_data (test_id,category,variable,value,expected,tol,units,comment,status,type) VALUES (?,?,?,?,?,?,?,?,?,?);"
+ test-id category variable value expected tol units (if comment comment "") status type)))
+ csvlist)))))
+
+;; This routine moved from tdb.scm, tdb:read-test-data
+;;
+(define (db:read-test-data dbstruct run-id test-id categorypatt)
+ (let* ((res '()))
+ (db:with-db
+ dbstruct #f #f
+ (lambda (dbdat db)
+ (sqlite3:for-each-row
+ (lambda (id test_id category variable value expected tol units comment status type)
+ (set! res (cons (vector id test_id category variable value expected tol units comment status type) res)))
+ db
+ "SELECT id,test_id,category,variable,value,expected,tol,units,comment,status,type FROM test_data WHERE test_id=? AND category LIKE ? ORDER BY category,variable;" test-id categorypatt)
+ (reverse res)))))
+
+;; This routine moved from tdb.scm, :read-test-data
+;;
+(define (db:read-test-data-varpatt dbstruct run-id test-id categorypatt varpatt)
+ (let* ((res '()))
+ (db:with-db
+ dbstruct #f #f
+ (lambda (dbdat db)
+ (sqlite3:for-each-row
+ (lambda (id test_id category variable value expected tol units comment status type)
+ (set! res (cons (vector id test_id category variable value expected tol units comment status type) res)))
+ db
+ "SELECT id,test_id,category,variable,value,expected,tol,units,comment,status,type FROM test_data WHERE test_id=? AND category LIKE ? AND variable LIKE ? ORDER BY category,variable;" test-id categorypatt varpatt)
+ (reverse res)))))
+
+
+;;======================================================================
+;; Misc. test related queries
+;;======================================================================
+
+(define (db:get-run-ids-matching-target dbstruct keynames target res runname testpatt statepatt statuspatt)
+ (db:with-db
+ dbstruct #f #f
+ (lambda (dbdat db)
+ (let* ((row-ids '())
+ (keystr (string-intersperse
+ (map (lambda (key val)
+ (conc key " like '" val "'"))
+ keynames
+ (string-split target "/"))
+ " AND "))
+ ;; (testqry (tests:match->sqlqry testpatt))
+ (runsqry (sqlite3:prepare db (conc "SELECT id FROM runs WHERE " keystr " AND runname LIKE '" runname "';"))))
+ ;; (debug:print 8 *default-log-port* "db:test-get-paths-matching-keynames-target-new\n runsqry=" runsqry "\n tstsqry=" testqry)
+ (sqlite3:for-each-row
+ (lambda (rid)
+ (set! row-ids (cons rid row-ids)))
+ runsqry)
+ (sqlite3:finalize! runsqry)
+ row-ids))))
+
+;; finds latest matching all patts for given run-id
+;;
+(define (db:test-get-paths-matching-keynames-target-new dbstruct run-id keynames target res testpatt statepatt statuspatt runname)
+ (let* ((testqry (tests:match->sqlqry testpatt))
+ (tstsqry (conc "SELECT rundir FROM tests WHERE run_id=? AND " testqry " AND state LIKE '" statepatt "' AND status LIKE '" statuspatt "' ORDER BY event_time ASC;")))
+ (db:with-db
+ dbstruct
+ run-id
+ #f
+ (lambda (dbdat db)
+ (sqlite3:for-each-row
+ (lambda (p)
+ (set! res (cons p res)))
+ db
+ tstsqry
+ run-id)
+ res))))
+
+(define (db:test-toplevel-num-items dbstruct run-id testname)
+ (db:with-db
+ dbstruct
+ run-id
+ #f
+ (lambda (dbdat db)
+ (let ((res 0))
+ (sqlite3:for-each-row
+ (lambda (num-items)
+ (set! res num-items))
+ db
+ "SELECT count(id) FROM tests WHERE run_id=? AND testname=? AND item_path != '' AND state NOT IN ('DELETED');"
+ run-id
+ testname)
+ res))))
+
+;;======================================================================
+;; QUEUE UP META, TEST STATUS AND STEPS REMOTE ACCESS
+;;======================================================================
+
+;; NOTE: Can remove the regex and base64 encoding for zmq
+(define (db:obj->string obj #!key (transport 'http))
+ (case transport
+ ;; ((fs) obj)
+ ((http fs)
+ (string-substitute
+ (regexp "=") "_"
+ (base64:base64-encode
+ (z3:encode-buffer
+ (with-output-to-string
+ (lambda ()(serialize obj))))) ;; BB: serialize - this is what causes problems between different builds of megatest communicating. serialize is sensitive to binary image of mtest.
+ #t))
+ ((zmq nmsg)(with-output-to-string (lambda ()(serialize obj))))
+ (else obj))) ;; rpc
+
+(define (db:string->obj msg #!key (transport 'http))
+ (case transport
+ ;; ((fs) msg)
+ ((http fs)
+ (if (string? msg)
+ (with-input-from-string
+ (z3:decode-buffer
+ (base64:base64-decode
+ (string-substitute
+ (regexp "_") "=" msg #t)))
+ (lambda ()(deserialize)))
+ (begin
+ (debug:print-error 0 *default-log-port* "reception failed. Received \"" msg "\" but cannot translate it.")
+ (print-call-chain (current-error-port))
+ msg))) ;; crude reply for when things go awry
+ ((zmq nmsg)(with-input-from-string msg (lambda ()(deserialize))))
+ (else msg))) ;; rpc
+
+;; ; This is to be the big daddy call NOPE: Replaced by db:set-state-status-and-roll-up-items
+;; ;
+;; define (db:test-set-state-status dbstruct run-id test-id state status msg)
+;; (let ((dbdat (db:get-subdb dbstruct run-id)))
+;; (if (member state '("LAUNCHED" "REMOTEHOSTSTART"))
+;; (db:general-call dbdat 'set-test-start-time (list test-id)))
+;; ;; (if msg
+;; ;; (db:general-call dbdat 'state-status-msg (list state status msg test-id))
+;; ;; (db:general-call dbdat 'state-status (list state status test-id)))
+;; (db:set-state-status-and-roll-up-items dbstruct run-id test-id #f state status msg)
+;; ;; process the test_data table
+;; (if (and test-id state status (equal? status "AUTO"))
+;; (db:test-data-rollup dbstruct run-id test-id status))
+;; (mt:process-triggers dbstruct run-id test-id state status)))
+
+;; state is the priority rollup of all states
+;; status is the priority rollup of all completed statesfu
+;;
+;; if test-name is an integer work off that as test-id instead of test-name test-path
+;;
+(define (db:set-state-status-and-roll-up-items dbstruct run-id test-name item-path state status comment)
+ ;; establish info on incoming test followed by info on top level test
+ ;; BBnote - for mode itemwait, linkage between upstream test & matching item status is propagated to run queue in db:prereqs-not-met
+ (let* ((testdat (if (number? test-name)
+ (db:get-test-info-by-id dbstruct run-id test-name) ;; test-name is actually a test-id
+ (db:keep-trying-until-true ;; in our threaded stuff this call could happen before the test is registered (maybe?)
+ db:get-test-info
+ (list dbstruct run-id test-name item-path)
+ 10)))
+ (test-id (db:test-get-id testdat))
+ (test-name (if (number? test-name)
+ (db:test-get-testname testdat)
+ test-name))
+ (item-path (db:test-get-item-path testdat))
+ (tl-testdat (db:get-test-info dbstruct run-id test-name ""))
+ (tl-test-id (if tl-testdat
+ (db:test-get-id tl-testdat)
+ #f))
+ (new-state-eh #f)
+ (new-status-eh #f))
+ (if (member state '("LAUNCHED" "REMOTEHOSTSTART"))
+ (db:general-call dbstruct run-id 'set-test-start-time (list test-id)))
+ (mutex-lock! *db-transaction-mutex*)
+ (db:with-db
+ dbstruct run-id #t
+ (lambda (dbdat db)
+ (let ((tr-res
+ (sqlite3:with-transaction
+ db
+ (lambda ()
+ ;; NB// Pass the db so it is part fo the transaction
+ (db:test-set-state-status-db db run-id test-id state status comment) ;; this call sets the item state/status
+ (if (not (equal? item-path "")) ;; only roll up IF incoming test is an item
+ (let* ((state-status-counts (db:get-all-state-status-counts-for-test db run-id test-name item-path state status)) ;; item-path is used to exclude current state/status of THIS test
+ (state-statuses (db:roll-up-rules state-status-counts state status))
+ (newstate (car state-statuses))
+ (newstatus (cadr state-statuses)))
+ (set! new-state-eh newstate)
+ (set! new-status-eh newstatus)
+ (debug:print 4 *default-log-port* "BB> tl-test-id="tl-test-id" ; "test-name":"item-path" newstate="newstate" newstatus="newstatus" len(sscs)="(length state-status-counts) " state-status-counts: "
+ (apply conc
+ (map (lambda (x)
+ (conc
+ (with-output-to-string (lambda () (pp (dbr:counts->alist x)))) " | "))
+ state-status-counts))); end debug:print
+ (if tl-test-id
+ (db:test-set-state-status-db db run-id tl-test-id newstate newstatus #f)) ;; we are still in the transaction - must access the db and not the dbstruct
+ ))))))
+ (mutex-unlock! *db-transaction-mutex*)
+ (if (and test-id state status (equal? status "AUTO"))
+ (db:test-data-rollup dbstruct run-id test-id status))
+ (if new-state-eh ;; moved from db:test-set-state-status
+ (mt:process-triggers dbstruct run-id test-id new-state-eh new-status-eh))
+ tr-res)))))
+
+(define (db:roll-up-rules state-status-counts state status)
+ (if (null? state-status-counts)
+ '(#f #f)
+ (let* ((running (length (filter (lambda (x)
+ (member (dbr:counts-state x) *common:running-states*))
+ state-status-counts)))
+ (bad-not-started (length (filter (lambda (x)
+ (and (equal? (dbr:counts-state x) "NOT_STARTED")
+ (not (member (dbr:counts-status x) *common:not-started-ok-statuses*))))
+ state-status-counts)))
+ (all-curr-states (common:special-sort ;; worst -> best (sort of)
+ (delete-duplicates
+ (if (and state (not (member state *common:dont-roll-up-states*)))
+ (cons state (map dbr:counts-state state-status-counts))
+ (map dbr:counts-state state-status-counts)))
+ *common:std-states* >))
+ (all-curr-statuses (common:special-sort ;; worst -> best
+ (delete-duplicates
+ (if (and state status (not (member state *common:dont-roll-up-states*)))
+ (cons status (map dbr:counts-status state-status-counts))
+ (map dbr:counts-status state-status-counts)))
+ *common:std-statuses* >))
+ (non-completes (filter (lambda (x)
+ (not (member x (cons "COMPLETED" *common:dont-roll-up-states*))))
+ all-curr-states))
+ (preq-fails (filter (lambda (x)
+ (equal? x "PREQ_FAIL"))
+ all-curr-statuses))
+ (num-non-completes (length non-completes))
+ (newstate (cond
+ ((> running 0) "RUNNING") ;; anything running, call the situation running
+ ((> (length preq-fails) 0) "NOT_STARTED")
+ ((> bad-not-started 0) "COMPLETED") ;; we have an ugly situation, it is completed in the sense we cannot do more.
+ ((> num-non-completes 0) (car non-completes)) ;; (remove (lambda (x)(equal? "COMPLETED" x)) all-curr-states))) ;; only rollup DELETED if all DELETED
+ (else (car all-curr-states))))
+ (newstatus (cond
+ ((> (length preq-fails) 0) "PREQ_FAIL")
+ ((or (> bad-not-started 0)
+ (and (equal? newstate "NOT_STARTED")
+ (> num-non-completes 0)))
+ "STARTED")
+ (else (car all-curr-statuses)))))
+ (debug:print-info 2 *default-log-port*
+ "\n--> probe db:set-state-status-and-roll-up-items: "
+ "\n--> state-status-counts: "(map dbr:counts->alist state-status-counts)
+ "\n--> running: "running
+ "\n--> bad-not-started: "bad-not-started
+ "\n--> non-non-completes: "num-non-completes
+ "\n--> non-completes: "non-completes
+ "\n--> all-curr-states: "all-curr-states
+ "\n--> all-curr-statuses: "all-curr-statuses
+ "\n--> newstate "newstate
+ "\n--> newstatus "newstatus
+ "\n\n")
+
+ ;; NB// Pass the db so it is part of the transaction
+ (list newstate newstatus))))
+
+(define (db:set-state-status-and-roll-up-run dbstruct run-id curr-state curr-status)
+ (mutex-lock! *db-transaction-mutex*)
+ (db:with-db
+ dbstruct run-id #t
+ (lambda (dbdat db)
+ (let ((tr-res
+ (sqlite3:with-transaction
+ db
+ (lambda ()
+ (let* ((state-status-counts (db:get-all-state-status-counts-for-run-db dbdat db run-id))
+ (state-statuses (db:roll-up-rules state-status-counts #f #f ))
+ (newstate (car state-statuses))
+ (newstatus (cadr state-statuses)))
+ (if (or (not (eq? newstate curr-state)) (not (eq? newstatus curr-status)))
+ (db:set-run-state-status-db dbdat db run-id newstate newstatus )))))))
+ (mutex-unlock! *db-transaction-mutex*)
+ tr-res))))
+
+(define (db:get-all-state-status-counts-for-run-db dbdat db run-id)
+ (sqlite3:map-row
+ (lambda (state status count)
+ (make-dbr:counts state: state status: status count: count))
+ (db:get-cache-stmth
+ dbdat db
+ "SELECT state,status,count(id) FROM tests WHERE run_id=? GROUP BY state,status;")
+ run-id ))
+
+(define (db:get-all-state-status-counts-for-run dbstruct run-id)
+ (db:with-db
+ dbstruct #f #f
+ (lambda (dbdat db)
+ (db:get-all-state-status-counts-for-run-db dbdat db run-id))))
+
+;; BBnote: db:get-all-state-status-counts-for-test returns dbr:counts object aggregating state and status of items of a given test, *not including rollup state/status*
+;;
+;; NOTE: This is called within a transaction
+;;
+(define (db:get-all-state-status-counts-for-test db run-id test-name item-path item-state-in item-status-in)
+ (let* ((test-info (db:get-test-info-db db run-id test-name item-path))
+ (item-state (or item-state-in (db:test-get-state test-info)))
+ (item-status (or item-status-in (db:test-get-status test-info)))
+ (other-items-count-recs (sqlite3:map-row
+ (lambda (state status count)
+ (make-dbr:counts state: state status: status count: count))
+ db
+ ;; ignore current item because we have changed its value in the current transation so this select will see the old value.
+ "SELECT state,status,count(id) FROM tests WHERE run_id=? AND testname=? AND item_path != '' AND item_path !=? GROUP BY state,status;"
+ run-id test-name item-path))
+ ;; add current item to tally outside of sql query
+ (match-countrec-lambda (lambda (countrec)
+ (and (equal? (dbr:counts-state countrec) item-state)
+ (equal? (dbr:counts-status countrec) item-status))))
+
+ (already-have-count-rec-list
+ (filter match-countrec-lambda other-items-count-recs)) ;; will have either 0 or 1 count recs depending if another item shares this item's state/status
+
+ (updated-count-rec (if (null? already-have-count-rec-list)
+ (make-dbr:counts state: item-state status: item-status count: 1)
+ (let* ((our-count-rec (car already-have-count-rec-list))
+ (new-count (add1 (dbr:counts-count our-count-rec))))
+ (make-dbr:counts state: item-state status: item-status count: new-count))))
+
+ (nonmatch-countrec-lambda (lambda (countrec) (not (match-countrec-lambda countrec))))
+
+ (unrelated-rec-list
+ (filter nonmatch-countrec-lambda other-items-count-recs)))
+ (cons updated-count-rec unrelated-rec-list)))
+
+;; (define (db:get-all-item-states db run-id test-name)
+;; (sqlite3:map-row
+;; (lambda (a) a)
+;; db
+;; "SELECT DISTINCT state FROM tests WHERE item_path != '' AND state != 'DELETED' AND run_id=? AND testname=?"
+;; run-id test-name))
+;;
+;; (define (db:get-all-item-statuses db run-id test-name)
+;; (sqlite3:map-row
+;; (lambda (a) a)
+;; db
+;; "SELECT DISTINCT status FROM tests WHERE item_path != '' AND state != 'DELETED' AND state='COMPLETED' AND run_id=? AND testname=?"
+;; run-id test-name))
+
+(define (db:test-get-logfile-info dbstruct run-id test-name)
+ (db:with-db
+ dbstruct
+ run-id
+ #f
+ (lambda (dbdat db)
+ (let ((res #f))
+ (sqlite3:for-each-row
+ (lambda (path final_logf)
+ ;; (let ((path (sdb:qry 'getstr path-id))
+ ;; (final_logf (sdb:qry 'getstr final_logf-id)))
+ (set! logf final_logf)
+ (set! res (list path final_logf))
+ (if (directory? path)
+ (debug:print 2 *default-log-port* "Found path: " path)
+ (debug:print 2 *default-log-port* "No such path: " path))) ;; )
+ db
+ "SELECT rundir,final_logf FROM tests WHERE testname=? AND item_path='' AND run_id=?;"
+ test-name run-id)
+ res))))
+
+;;======================================================================
+;; A G R E G A T E D T R A N S A C T I O N D B W R I T E S
+;;======================================================================
+
+(define db:queries
+ (list '(update-run-duration "UPDATE tests SET run_duration=? WHERE id=?;")
+
+ ;; TESTS
+ '(register-test "INSERT OR IGNORE INTO tests (run_id,testname,event_time,item_path,state,status) VALUES (?,?,strftime('%s','now'),?,'NOT_STARTED','n/a');")
+ ;; Test state and status
+ '(set-test-state "UPDATE tests SET state=? WHERE id=?;")
+ '(set-test-status "UPDATE tests SET state=? WHERE id=?;")
+ '(state-status "UPDATE tests SET state=?,status=? WHERE id=?;") ;; D/ONE
+ '(state-status-msg "UPDATE tests SET state=?,status=?,comment=? WHERE id=?;") ;; DONE
+ ;; Test comment
+ '(set-test-comment "UPDATE tests SET comment=? WHERE id=?;")
+ '(set-test-start-time "UPDATE tests SET event_time=strftime('%s','now') WHERE id=?;") ;; DONE
+ '(pass-fail-counts "UPDATE tests SET pass_count=?,fail_count=? WHERE id=?;")
+ ;; test_data-pf-rollup is used to set a tests PASS/FAIL based on the pass/fail info from the steps
+ '(test_data-pf-rollup "UPDATE tests
+ SET status=CASE WHEN (SELECT fail_count FROM tests WHERE id=?) > 0
+ THEN 'FAIL'
+ WHEN (SELECT pass_count FROM tests WHERE id=?) > 0 AND
+ (SELECT status FROM tests WHERE id=?) NOT IN ('WARN','FAIL')
+ THEN 'PASS'
+ ELSE status
+ END WHERE id=?;") ;; DONE
+ '(test-set-log "UPDATE tests SET final_logf=? WHERE id=?;") ;; DONE
+ ;; '(test-set-rundir-by-test-id "UPDATE tests SET rundir=? WHERE id=?") ;; DONE
+ ;; '(test-set-rundir "UPDATE tests SET rundir=? AND testname=? AND item_path=?;") ;; DONE
+ '(test-set-rundir-shortdir "UPDATE tests SET rundir=?,shortdir=? WHERE testname=? AND item_path=? AND run_id=?;") ;; BROKEN!!! NEEDS run-id
+ '(delete-tests-in-state ;; "DELETE FROM tests WHERE state=?;") ;; DONE
+ "UPDATE tests SET state='DELETED' WHERE state=?")
+ '(tests:test-set-toplog "UPDATE tests SET final_logf=? WHERE run_id=? AND testname=? AND item_path='';")
+ '(update-cpuload-diskfree "UPDATE tests SET cpuload=?,diskfree=? WHERE id=?;") ;; DONE
+ '(update-uname-host "UPDATE tests SET uname=?,host=? WHERE id=?;") ;; DONE
+ '(update-test-rundat "INSERT INTO test_rundat (test_id,update_time,cpuload,diskfree,diskusage,run_duration) VALUES (?,?,?,?,?,?);")
+ '(update-test-state "UPDATE tests SET state=? WHERE state=? AND run_id=? AND testname=? AND NOT (item_path='' AND testname IN (SELECT DISTINCT testname FROM tests WHERE testname=? AND item_path != ''));")
+ '(update-test-status "UPDATE tests SET status=? WHERE status like ? AND run_id=? AND testname=? AND NOT (item_path='' AND testname IN (SELECT DISTINCT testname FROM tests WHERE testname=? AND item_path != ''));")
+ ;; stuff for set-state-status-and-roll-up-items
+ '(update-pass-fail-counts "UPDATE tests
+ SET fail_count=(SELECT count(id) FROM tests WHERE testname=? AND item_path != '' AND status IN ('FAIL','CHECK','INCOMPLETE','ABORT')),
+ pass_count=(SELECT count(id) FROM tests WHERE testname=? AND item_path != '' AND status IN ('PASS','WARN','WAIVED'))
+ WHERE testname=? AND item_path='' AND run_id=?;") ;; DONE ;; BROKEN!!! NEEDS run-id
+ '(top-test-set-running "UPDATE tests SET state='RUNNING' WHERE testname=? AND item_path='' AND run_id=?;") ;; DONE ;; BROKEN!!! NEEDS run-id
+
+ ;; NOT USED
+ ;;
+ ;; Might be the following top-test-set-per-pf-counts query could be better based off of something like this:
+ ;;
+ ;; select state,status,count(state) from tests where run_id=59 AND testname='runfirst' group by state,status;
+ ;;
+ '(top-test-set-per-pf-counts "UPDATE tests
+ SET state=CASE
+ WHEN (SELECT count(id) FROM tests
+ WHERE testname=?
+ AND item_path != ''
+ AND status NOT IN ('n/a')
+ AND state in ('NOT_STARTED')) > 0 THEN 'UNKNOWN'
+ WHEN (SELECT count(id) FROM tests
+ WHERE testname=?
+ AND item_path != ''
+ AND (status NOT IN ('TEN_STRIKES','BLOCKED') OR status IN ('INCOMPLETE'))
+ AND state in ('RUNNING','NOT_STARTED','LAUNCHED','REMOTEHOSTSTART')) > 0 THEN 'RUNNING'
+ WHEN (SELECT count(id) FROM tests
+ WHERE testname=?
+ AND item_path != ''
+ AND state NOT IN ('COMPLETED','DELETED')) = 0 THEN 'COMPLETED'
+ WHEN (SELECT count(id) FROM tests
+ WHERE testname=?
+ AND item_path != ''
+ AND state = 'NOT_STARTED') > 0 THEN 'NOT_STARTED'
+ ELSE 'UNKNOWN' END,
+ status=CASE
+ WHEN fail_count > 0 THEN 'FAIL'
+ WHEN (SELECT count(id) FROM tests
+ WHERE testname=?
+ AND item_path != ''
+ AND state IN ('BLOCKED','INCOMPLETE')) > 0 THEN 'FAIL'
+ WHEN (SELECT count(id) FROM tests
+ WHERE testname=?
+ AND item_path != ''
+ AND state NOT IN ('DELETED')
+ AND status IN ('INCOMPLETE','ABORT')) > 0 THEN 'ABORT'
+ WHEN (SELECT count(id) FROM tests
+ WHERE testname=?
+ AND item_path != ''
+ AND state NOT IN ('DELETED')
+ AND status = 'AUTO') > 0 THEN 'AUTO'
+ WHEN (SELECT count(id) FROM tests
+ WHERE testname=?
+ AND item_path != ''
+ AND state NOT IN ('DELETED')
+ AND status IN ('STUCK/INCOMPLETE', 'INCOMPLETE')) > 0 THEN 'INCOMPLETE'
+ WHEN (SELECT count(id) FROM tests
+ WHERE testname=?
+ AND item_path != ''
+ AND state IN ('COMPLETED','STUCK/INCOMPLETE','INCOMPLETE')
+ AND status = 'FAIL') > 0 THEN 'FAIL'
+ WHEN (SELECT count(id) FROM tests
+ WHERE testname=?
+ AND item_path != ''
+ AND state NOT IN ('DELETED')
+ AND status = 'CHECK') > 0 THEN 'CHECK'
+ WHEN (SELECT count(id) FROM tests
+ WHERE testname=?
+ AND item_path != ''
+ AND state NOT IN ('DELETED')
+ AND status = 'SKIP') > 0 THEN 'SKIP'
+ WHEN (SELECT count(id) FROM tests
+ WHERE testname=?
+ AND item_path != ''
+ AND state NOT IN ('DELETED')
+ AND status = 'WARN') > 0 THEN 'WARN'
+ WHEN (SELECT count(id) FROM tests
+ WHERE testname=?
+ AND item_path != ''
+ AND state NOT IN ('DELETED')
+ AND status = 'WAIVED') > 0 THEN 'WAIVED'
+ WHEN (SELECT count(id) FROM tests
+ WHERE testname=?
+ AND item_path != ''
+ AND state NOT IN ('DELETED')
+ AND status NOT IN ('PASS','FAIL','WARN','WAIVED')) > 0 THEN 'ABORT'
+ WHEN (SELECT count(id) FROM tests
+ WHERE testname=?
+ AND item_path != ''
+ AND state='NOT_STARTED') > 0 THEN 'n/a'
+ WHEN (SELECT count(id) FROM tests
+ WHERE testname=?
+ AND item_path != ''
+ AND state = 'COMPLETED'
+ AND status = 'PASS') > 0 THEN 'PASS'
+ WHEN pass_count > 0 AND fail_count=0 THEN 'PASS'
+ ELSE 'UNKNOWN' END
+ WHERE testname=? AND item_path='';") ;; DONE ;; BROKEN!!! NEEDS run-id
+
+ ;; STEPS
+ '(delete-test-step-records "UPDATE test_steps SET status='DELETED' WHERE test_id=?;")
+ '(delete-test-data-records "UPDATE test_data SET status='DELETED' WHERE test_id=?;") ;; using status since no state field
+ ))
+
+(define (db:lookup-query qry-name)
+ (let ((q (alist-ref qry-name db:queries)))
+ (if q (car q) #f)))
+
+;; do not run these as part of the transaction
+(define db:special-queries '(rollup-tests-pass-fail
+ ;; db:set-state-status-and-roll-up-items ;; WHY NOT!?
+ login
+ immediate
+ flush
+ sync
+ set-verbosity
+ killserver
+ ))
+
+(define (db:login dbstruct calling-path calling-version client-signature)
+ (cond
+ ((not (equal? calling-path *toppath*))
+ (list #f "Login failed due to mismatch paths: " calling-path ", " *toppath*))
+ ;; ((not (equal? *run-id* run-id))
+ ;; (list #f "Login failed due to mismatch run-id: " run-id ", " *run-id*))
+ ((not (equal? megatest-version calling-version))
+ (list #t (conc "Login warning due to mismatch megatest version: " calling-version ", " megatest-version)))
+
+ (else
+ (hash-table-set! *logged-in-clients* client-signature (current-seconds))
+ '(#t "successful login"))))
+
+;; NO WAY TO KNOW IF IT MODIFIES THE DB BUT NEARLY ALL ARE UPDATES/INSERTS
+;;
+(define (db:general-call dbstruct run-id stmtname params)
+ ;; Why is db:lookup-query above not used here to get the query?
+ (let ((query (let ((q (alist-ref (if (string? stmtname)
+ (string->symbol stmtname)
+ stmtname)
+ db:queries)))
+ (if q (car q) #f))))
+ (db:with-db
+ dbstruct run-id #t
+ (lambda (dbdat db)
+ (apply sqlite3:execute db query params)
+ #t))))
+
+;; get a summary of state and status counts to calculate a rollup
+;;
+(define (db:get-state-status-summary dbstruct run-id testname)
+ (let ((res '()))
+ (db:with-db
+ dbstruct run-id #f
+ (lambda (dbdat db)
+ (sqlite3:for-each-row
+ (lambda (state status count)
+ (set! res (cons (vector state status count) res)))
+ db
+ "SELECT state,status,count(state) FROM tests WHERE run_id=? AND testname=? AND item_path='' GROUP BY state,status;"
+ run-id testname)
+ res))))
+
+(define (db:get-latest-host-load dbstruct raw-hostname)
+ (let* ((hostname (string-substitute "\\..*$" "" raw-hostname))
+ (res (cons -1 0)))
+ (db:with-db
+ dbstruct #f #f
+ (lambda (dbdat db)
+ (sqlite3:for-each-row
+ (lambda (cpuload update-time) (set! res (cons cpuload update-time)))
+ db
+ "SELECT tr.cpuload, tr.update_time FROM test_rundat tr, tests t WHERE t.host=? AND tr.cpuload != -1 AND tr.test_id=t.id ORDER BY tr.update_time DESC LIMIT 1;"
+ hostname))) res ))
+
+(define (db:set-top-level-from-items dbstruct run-id testname)
+ (let* ((summ (db:get-state-status-summary dbstruct run-id testname))
+ (find (lambda (state status)
+ (if (null? summ)
+ #f
+ (let loop ((hed (car summ))
+ (tal (cdr summ)))
+ (if (and (string-match state (vector-ref hed 0))
+ (string-match status (vector-ref hed 1)))
+ hed
+ (if (null? tal)
+ #f
+ (loop (car tal)(cdr tal)))))))))
+
+
+ ;;; E D I T M E ! !
+
+
+ (cond
+ ((> (find "COMPLETED" ".*") 0) #f))))
+
+
+
+;; get the previous records for when these tests were run where all keys match but runname
+;; NB// Merge this with test:get-previous-test-run-records? This one looks for all matching tests
+;; can use wildcards. Also can likely be factored in with get test paths?
+;;
+;; Run this remotely!!
+;;
+(define (db:get-matching-previous-test-run-records dbstruct run-id test-name item-path)
+ (let* ((keys (db:get-keys dbstruct))
+ (selstr (string-intersperse keys ","))
+ (qrystr (string-intersperse (map (lambda (x)(conc x "=?")) keys) " AND "))
+ (keyvals #f)
+ (tests-hash (make-hash-table)))
+ ;; first look up the key values from the run selected by run-id
+ (db:with-db
+ dbstruct #f #f
+ (lambda (dbdat db)
+ (sqlite3:for-each-row
+ (lambda (a . b)
+ (set! keyvals (cons a b)))
+ db
+ (conc "SELECT " selstr " FROM runs WHERE id=? ORDER BY event_time DESC;") run-id)))
+ (if (not keyvals)
+ '()
+ (let ((prev-run-ids '()))
+ (db:with-db
+ dbstruct #f #f
+ (lambda (dbdat db)
+ (apply sqlite3:for-each-row
+ (lambda (id)
+ (set! prev-run-ids (cons id prev-run-ids)))
+ db
+ (conc "SELECT id FROM runs WHERE " qrystr " AND id != ?;") (append keyvals (list run-id)))))
+ ;; collect all matching tests for the runs then
+ ;; extract the most recent test and return that.
+ (debug:print 4 *default-log-port* "selstr: " selstr ", qrystr: " qrystr ", keyvals: " keyvals
+ ", previous run ids found: " prev-run-ids)
+ (if (null? prev-run-ids) '() ;; no previous runs? return null
+ (let loop ((hed (car prev-run-ids))
+ (tal (cdr prev-run-ids)))
+ (let ((results (db:get-tests-for-run dbstruct hed (conc test-name "/" item-path) '() '() #f #f #f #f #f #f #f 'normal)))
+ (debug:print 4 *default-log-port* "Got tests for run-id " run-id ", test-name " test-name
+ ", item-path " item-path " results: " (intersperse results "\n"))
+ ;; Keep only the youngest of any test/item combination
+ (for-each
+ (lambda (testdat)
+ (let* ((full-testname (conc (db:test-get-testname testdat) "/" (db:test-get-item-path testdat)))
+ (stored-test (hash-table-ref/default tests-hash full-testname #f)))
+ (if (or (not stored-test)
+ (and stored-test
+ (> (db:test-get-event_time testdat)(db:test-get-event_time stored-test))))
+ ;; this test is younger, store it in the hash
+ (hash-table-set! tests-hash full-testname testdat))))
+ results)
+ (if (null? tal)
+ (map cdr (hash-table->alist tests-hash)) ;; return a list of the most recent tests
+ (loop (car tal)(cdr tal))))))))))
+
+;; Function recursively checks if .journal exists; if yes means db busy; call itself after delayed interval
+;; return the sqlite3 db handle if possible
+;;
+(define (db:delay-if-busy dbdat #!key (count 6))
+ (if (not (configf:lookup *configdat* "server" "delay-on-busy"))
+ (and dbdat (dbr:dbdat-dbh dbdat))
+ (if dbdat
+ (let* ((dbpath (dbr:dbdat-dbfile dbdat))
+ (db (dbr:dbdat-dbh dbdat)) ;; we'll return this so (db:delay--if-busy can be called inline
+ (dbfj (conc dbpath "-journal")))
+ (if (handle-exceptions
+ exn
+ (begin
+ (debug:print-info 0 *default-log-port* "WARNING: failed to test for existance of " dbfj ", exn=" exn)
+ (thread-sleep! 1)
+ (db:delay-if-busy count (- count 1)))
+ (common:file-exists? dbfj))
+ (case count
+ ((6)
+ (thread-sleep! 0.2)
+ (db:delay-if-busy count: 5))
+ ((5)
+ (thread-sleep! 0.4)
+ (db:delay-if-busy count: 4))
+ ((4)
+ (thread-sleep! 0.8)
+ (db:delay-if-busy count: 3))
+ ((3)
+ (thread-sleep! 1.6)
+ (db:delay-if-busy count: 2))
+ ((2)
+ (thread-sleep! 3.2)
+ (db:delay-if-busy count: 1))
+ ((1)
+ (thread-sleep! 6.4)
+ (db:delay-if-busy count: 0))
+ (else
+ (debug:print-info 0 *default-log-port* "delaying db access due to high database load.")
+ (thread-sleep! 12.8))))
+ db)
+ "bogus result from db:delay-if-busy")))
+
+(define (db:test-get-records-for-index-file dbstruct run-id test-name)
+ (let ((res '()))
+ (db:with-db
+ dbstruct
+ run-id
+ #f
+ (lambda (dbdat db)
+ (sqlite3:for-each-row
+ (lambda (id itempath state status run_duration logf comment)
+ (set! res (cons (vector id itempath state status run_duration logf comment) res)))
+ db
+ "SELECT id,item_path,state,status,run_duration,final_logf,comment FROM tests WHERE testname=? AND item_path != '' AND run_id=?;" ;; BUG! WHY NO run_id?
+ test-name
+ run-id)
+ res))))
+
+;;======================================================================
+;; Tests meta data
+;;======================================================================
+
+;; returns a hash table of tags to tests
+;;
+(define (db:get-tests-tags dbstruct)
+ (db:with-db
+ dbstruct #f #f
+ (lambda (dbdat db)
+ (let* ((res (make-hash-table)))
+ (sqlite3:for-each-row
+ (lambda (testname tags-in)
+ (let ((tags (string-split tags-in ",")))
+ (for-each
+ (lambda (tag)
+ (hash-table-set! res tag
+ (delete-duplicates
+ (cons testname (hash-table-ref/default res tag '())))))
+ tags)))
+ db
+ "SELECT testname,tags FROM test_meta")
+ (hash-table->alist res)))))
+
+;; testmeta doesn't change, we can cache it for up too an hour
+
+(define *db:testmeta-cache* (make-hash-table))
+(define *db:testmeta-last-update* 0)
+
+;; read the record given a testname
+(define (db:testmeta-get-record dbstruct testname)
+ (if (and (< (- (current-seconds) *db:testmeta-last-update*) 600)
+ (hash-table-exists? *db:testmeta-cache* testname))
+ (hash-table-ref *db:testmeta-cache* testname)
+ (let ((res #f))
+ (db:with-db
+ dbstruct
+ #f
+ #f
+ (lambda (dbdat db)
+ (sqlite3:for-each-row
+ (lambda (id testname author owner description reviewed iterated avg_runtime avg_disk tags jobgroup)
+ (set! res (vector id testname author owner description reviewed iterated avg_runtime avg_disk tags jobgroup)))
+ db
+ "SELECT id,testname,author,owner,description,reviewed,iterated,avg_runtime,avg_disk,tags,jobgroup FROM test_meta WHERE testname=?;"
+ testname)))
+ (hash-table-set! *db:testmeta-cache* testname res)
+ (set! *db:testmeta-last-update* (current-seconds))
+ res)))
+
+;; create a new record for a given testname
+(define (db:testmeta-add-record dbstruct testname)
+ (db:with-db dbstruct #f #t
+ (lambda (dbdat db)
+ (sqlite3:execute
+ db
+ "INSERT OR IGNORE INTO test_meta (testname,author,owner,description,reviewed,iterated,avg_runtime,avg_disk,tags) VALUES (?,'','','','','','','','');" testname))))
+
+;; update one of the testmeta fields
+(define (db:testmeta-update-field dbstruct testname field value)
+ (db:with-db dbstruct #f #t
+ (lambda (dbdat db)
+ (sqlite3:execute
+ db
+ (conc "UPDATE test_meta SET " field "=? WHERE testname=?;") value testname))))
+
+(define (db:testmeta-get-all dbstruct)
+ (db:with-db dbstruct #f #f
+ (lambda (dbdat db)
+ (let ((res '()))
+ (sqlite3:for-each-row
+ (lambda (a . b)
+ (set! res (cons (apply vector a b) res)))
+ db
+ "SELECT id,testname,author,owner,description,reviewed,iterated,avg_runtime,avg_disk,tags,jobgroup FROM test_meta;")
+ res))))
+
+;;======================================================================
+;; M I S C M A N A G E M E N T I T E M S
+;;======================================================================
+
+;; A routine to map itempaths using a itemmap
+;; patha and pathb must be strings or this will fail
+;;
+;; path-b is waiting on path-a
+;;
+(define (db:compare-itempaths test-b-name path-a path-b itemmaps )
+ (debug:print-info 6 *default-log-port* "ITEMMAPS: " itemmaps)
+ (let* ((itemmap (tests:lookup-itemmap itemmaps test-b-name)))
+ (if itemmap
+ (let ((path-b-mapped (db:multi-pattern-apply path-b itemmap)))
+ (debug:print-info 6 *default-log-port* "ITEMMAP is " itemmap ", path: " path-b ", mapped path: " path-b-mapped)
+ (equal? path-a path-b-mapped))
+ (equal? path-b path-a))))
+
+;; A routine to convert test/itempath using a itemmap
+;; NOTE: to process only an itempath (i.e. no prepended testname)
+;; just call db:multi-pattern-apply
+;;
+(define (db:convert-test-itempath path-in itemmap)
+ (debug:print-info 6 *default-log-port* "ITEMMAP is " itemmap)
+ (let* ((path-parts (string-split path-in "/"))
+ (test-name (if (null? path-parts) "" (car path-parts)))
+ (item-path (string-intersperse (if (null? path-parts) '() (cdr path-parts)) "/")))
+ (conc test-name "/"
+ (db:multi-pattern-apply item-path itemmap))))
+
+;; patterns are:
+;; "rx1" "replacement1"\n
+;; "rx2" "replacement2"
+;; etc.
+;;
+(define (db:multi-pattern-apply item-path itemmap)
+ (let ((all-patts (string-split itemmap "\n")))
+ (if (null? all-patts)
+ item-path
+ (let loop ((hed (car all-patts))
+ (tal (cdr all-patts))
+ (res item-path))
+ (let* ((parts (string-split hed))
+ (patt (car parts))
+
+ (repl (if (> (length parts) 1)(cadr parts) ""))
+
+ (newr (if (and patt repl)
+ (begin
+ (handle-exceptions
+ exn
+ (begin
+ (debug:print 0 *default-log-port*
+ "WARNING: itemmap has problem \"" itemmap "\", patt: " patt ", repl: " repl ", exn=" exn)
+ res)
+ (string-substitute patt repl res))
+
+
+ )
+ (begin
+ (debug:print 0 *default-log-port*
+ "WARNING: itemmap has problem \"" itemmap "\", patt: " patt ", repl: " repl)
+ res))))
+ (if (null? tal)
+ newr
+ (loop (car tal)(cdr tal) newr)))))))
+
+
+
+
+;; the new prereqs calculation, looks also at itempath if specified
+;; all prereqs must be met
+;; if prereq test with itempath='' is in common:well-ended-states, then prereq is met
+;; if prereq test with itempath=ref-item-path and COMPLETED with PASS, WARN, CHECK, or WAIVED then prereq is met
+;;
+;; Note: mode 'normal means that tests must be COMPLETED and ok (i.e. PASS, WARN, CHECK, SKIP or WAIVED)
+;; mode 'toplevel means that tests must be COMPLETED only
+;; mode 'itemmatch or 'itemwait means that tests items must be COMPLETED and (PASS|WARN|WAIVED|CHECK) [[ NB// NOT IMPLEMENTED YET ]]
+;; mode 'exclusive means this test/item cannot run if the same test/item is LAUNCHED,REMOTEHOSTSTART or RUNNING
+;;
+;; IDEA for consideration:
+;; 1. collect all tests "upstream"
+;; 2. any NOT completed and good? if yes => return those as prereqs not met, if no => return null list
+;;
+;; (define (db:get-prereqs-not-met dbstruct run-id waitons ref-item-path mode)
+(define (db:get-prereqs-not-met dbstruct run-id waitons ref-test-name ref-item-path mode itemmaps) ;; #!key (mode '(normal))(itemmap #f))
+ ;; BBnote - rollup of an itemized test's overall state/status done in db:set-state-status-and-roll-up-items
+ (debug:print 4 *default-log-port* "db:get-prereqs-not-met: " waitons)
+ (append
+ (if (member 'exclusive mode)
+ (let ((running-tests (db:get-tests-for-run dbstruct
+ #f ;; run-id of #f means for all runs.
+ (if (string=? ref-item-path "") ;; testpatt
+ ref-test-name
+ (conc ref-test-name "/" ref-item-path))
+ '("LAUNCHED" "REMOTEHOSTSTART" "RUNNING") ;; states
+ '() ;; statuses
+ #f ;; offset
+ #f ;; limit
+ #f ;; not-in
+ #f ;; sort by
+ #f ;; sort order
+ 'shortlist ;; query type
+ 0 ;; last update, beginning of time ....
+ #f ;; mode
+ )))
+ ;;(map (lambda (testdat)
+ ;; (if (equal? (db:test-get-item-path testdat) "")
+ ;; (db:test-get-testname testdat)
+ ;; (conc (db:test-get-testname testdat)
+ ;; "/"
+ ;; (db:test-get-item-path testdat))))
+ running-tests) ;; calling functions want the entire data
+ '())
+
+
+
+ ;; collection of: for each waiton -
+ ;; if this ref-test-name is an item in an itemized test and mode is itemwait/itemmatch:
+ ;; if waiton is not itemized - if waiton is not both completed and in ok status, add as unmet prerequisite
+ ;; if waiton is itemized:
+ ;; and waiton's items are not expanded, add as unmet prerequisite
+ ;; else if matching waiton item is not both completed and in an ok status, add as unmet prerequisite
+ ;; else
+ ;; if waiton toplevel is not in both completed and ok status, add as unmet prerequisite
+
+ (if (or (not waitons)
+ (null? waitons))
+ '()
+ (let* ((ref-test-itemized-mode (not (null? (lset-intersection eq? mode '(itemmatch itemwait))))) ;; how is this different from using member?
+ (ref-test-toplevel-mode (not (null? (lset-intersection eq? mode '(toplevel)))))
+ (ref-test-is-toplevel (equal? ref-item-path ""))
+ (ref-test-is-item (not ref-test-is-toplevel))
+ (unmet-pre-reqs '())
+ (result '())
+ (unmet-prereq-items '())
+ )
+ (for-each ; waitons
+ (lambda (waitontest-name)
+ ;; by getting the tests with matching name we are looking only at the matching test
+ ;; and related sub items
+ ;; next should be using mt:get-tests-for-run?
+
+ (let (;(waiton-is-itemized ...)
+ ;(waiton-items-are-expanded ...)
+ (waiton-tests (db:get-tests-for-run-state-status dbstruct run-id waitontest-name))
+ (ever-seen #f)
+ (parent-waiton-met #f)
+ (item-waiton-met #f)
+
+ )
+ (for-each ; test expanded from waiton
+ (lambda (waiton-test)
+ (let* ((waiton-state (db:test-get-state waiton-test))
+ (waiton-status (db:test-get-status waiton-test))
+ (waiton-item-path (db:test-get-item-path waiton-test)) ;; BB- this is the upstream itempath
+ (waiton-test-name (db:test-get-testname waiton-test))
+ (waiton-is-toplevel (equal? waiton-item-path ""))
+ (waiton-is-item (not waiton-is-toplevel))
+ (waiton-is-completed (member waiton-state *common:ended-states*))
+ (waiton-is-running (member waiton-state *common:running-states*))
+ (waiton-is-killed (member waiton-state *common:badly-ended-states*))
+ (waiton-is-ok (member waiton-status *common:well-ended-states*))
+ ;; testname-b path-a path-b
+ (same-itempath (db:compare-itempaths ref-test-name waiton-item-path ref-item-path itemmaps)) ;; (equal? ref-item-path waiton-item-path)))
+ (real-ref-test-name (car (string-split ref-test-name "/"))) ;; I THINK ref-test-name SHOULD NEVER HAVE THE ITEM_PATH!
+ (test-and-ref-are-same (equal? real-ref-test-name waiton-test-name)))
+ (debug:print 4 *default-log-port* "waiton-test-name " waiton-test-name " ref-test-name: " ref-test-name " test-and-ref-are-same: " test-and-ref-are-same)
+ (set! ever-seen #t)
+ ;;(BB> "***consider waiton "waiton-test"/"waiton-item-path"***")
+ (cond
+ ;; case 0 - toplevel of an itemized test, at least one item in prereq has completed
+ ((and waiton-is-item ref-test-is-toplevel ref-test-itemized-mode waiton-is-completed)
+ (set! parent-waiton-met #t))
+
+ ;; case 1, non-item (parent test) is
+ ((and waiton-is-toplevel ;; this is the parent test of the waiton being examined
+ waiton-is-completed
+ ;;(BB> "cond1")
+ (or waiton-is-ok ref-test-toplevel-mode)) ;; itemmatch itemwait))))))
+ (set! parent-waiton-met #t))
+ ;; Special case for toplevel and KILLED
+ ((and waiton-is-toplevel ;; this is the parent test
+ waiton-is-killed
+ (member 'toplevel mode))
+ ;;(BB> "cond2")
+ (set! parent-waiton-met #t))
+ ;; For itemwait mode IFF the previous matching item is good the set parent-waiton-met
+ ((and ref-test-itemized-mode ref-test-is-item same-itempath)
+ ;;(BB> "cond3")
+ (if (and waiton-is-completed (or waiton-is-ok ref-test-toplevel-mode))
+ (set! item-waiton-met #t)
+ (set! unmet-prereq-items (cons waiton-test unmet-prereq-items)))
+ (if (and waiton-is-toplevel ;; if upstream rollup test is completed, parent-waiton-met is set
+ (or waiton-is-completed waiton-is-running))
+ (set! parent-waiton-met #t)))
+ ;; normal checking of parent items, any parent or parent item not ok blocks running
+ ((and waiton-is-completed
+ (or waiton-is-ok
+ (member 'toplevel mode)) ;; toplevel does not block on FAIL
+ (and waiton-is-ok (member 'itemmatch mode) ;; itemmatch blocks on not ok ;; TODO: THIS IS PROBABLY A BUG. ITEMMATCH AND ITEMWAIT ARE SYNONYMS!! WHAT HAPPENED OT ITEMWAIT???
+ ))
+ ;;(BB> "cond4")
+ (set! item-waiton-met #t))
+ ((and waiton-is-completed waiton-is-ok same-itempath)
+ ;;(BB> "cond5")
+ (set! item-waiton-met #t))
+ ((and waiton-is-completed waiton-is-ok test-and-ref-are-same) ;; probably from [waitons] table
+ (set! item-waiton-met #t))
+ (else
+ #t
+ ;;(BB> "condelse")
+ ))))
+ waiton-tests)
+ ;; both requirements, parent and item-waiton must be met to NOT add item to
+ ;; prereq's not met list
+ ;; (BB>
+ ;; "\n* waiton-tests "waiton-tests
+ ;; "\n* parent-waiton-met "parent-waiton-met
+ ;; "\n* item-waiton-met "item-waiton-met
+ ;; "\n* ever-seen "ever-seen
+ ;; "\n* ref-test-itemized-mode "ref-test-itemized-mode
+ ;; "\n* unmet-prereq-items "unmet-prereq-items
+ ;; "\n* result (pre) "result
+ ;; "\n* ever-seen "ever-seen
+ ;; "\n")
+
+ (cond
+ ((and ref-test-itemized-mode ref-test-is-item (not (null? unmet-prereq-items)))
+ (set! result (append unmet-prereq-items result)))
+ ((not (or parent-waiton-met item-waiton-met))
+ (set! result (append (if (null? waiton-tests) (list waitontest-name) waiton-tests) result))) ;; appends the string if the full record is not available
+ ;; if the test is not found then clearly the waiton is not met...
+ ;; (if (not ever-seen)(set! result (cons waitontest-name result)))))
+ ((not ever-seen)
+ (set! result (append (if (null? waiton-tests)(list waitontest-name) waiton-tests) result))))))
+ waitons)
+ (delete-duplicates result)))))
+
+;;======================================================================
+;; To sync individual run
+;;======================================================================
+(define (db:get-run-record-ids dbstruct target run keynames)
+ (let* ((backcons (lambda (lst item)(cons item lst)))
+ (all_tests '())
+ (keystr (string-intersperse
+ (map (lambda (key val)
+ (conc key " like '" val "'"))
+ keynames
+ (string-split target "/"))
+ " AND ")
+ )
+ (run-qry (conc "SELECT id FROM runs WHERE " keystr " and runname='" run"'"))
+ ; (test-qry (conc "SELECT id FROM tests WHERE run_id in (" run-qry ") and testname like '" test-patt "'"))
+ (run_ids
+ (db:with-db dbstruct #f #f
+ (lambda (dbdat db)
+ (sqlite3:fold-row backcons '() db run-qry))
+ )
+ )
+ )
+ run_ids)
+)
+
+;;======================================================================
+;; Just for sync, procedures to make sync easy
+;;======================================================================
+
+;; get an alist of run ids and test/run, test_step/run pairs changed since time since-time
+;; '((runs . (1 2 3 ...))(tests . ((5 . 1) (6 . 3) (6 . 2) (7 . 1) ...
+
+;; Retrieves record IDs from the database based on the timestamp of their last update.
+
+;; The function takes two arguments: dbstruct, which represents the database structure, and since-time, which is a timestamp indicating the time of the last update.
+;; The function first defines a few helper functions, including backcons, which takes a list and an item and adds the item to the front of the list.
+;; It then initializes several variables to empty lists: all_tests, all_test_steps, all_test_data, all_run_ids, and all_test_ids.
+;; The function then retrieves a list of IDs for runs that have been changed since since-time using the db:get-changed-run-ids function.
+;; It then filters the full list of run IDs to only include those that match the changed run IDs based on their modulo (num-run-dbs).
+;; For each changed run ID, the function retrieves a list of test IDs, test step IDs, and test data IDs that have been updated since since-time.
+;; It appends these IDs to the appropriate lists (all_tests, all_test_steps, and all_test_data) using the append and map functions.
+;; The function then retrieves a list of run stat IDs that have been updated since since-time.
+;; Finally, the function returns a list of associations between record types and their corresponding IDs: runs, tests, test_steps, test_data, and run_stats.
+;;
+(define (db:get-changed-record-ids dbstruct since-time)
+ ;; no transaction, allow the db to be accessed between the big queries
+ (let* ((backcons (lambda (lst item)(cons item lst)))
+ (all_tests '())
+ (changed_run_dbs (db:get-changed-run-ids since-time)) ;; gets the rundb numbers
+ (all_run_ids
+ (db:with-db dbstruct #f #f
+ (lambda (dbdat db)
+ (sqlite3:fold-row backcons '() db "SELECT id FROM runs"))
+ )
+ )
+ (changed_run_ids (filter (lambda (run) (member (modulo run (num-run-dbs)) changed_run_dbs)) all_run_ids))
+ (run_ids
+ (db:with-db dbstruct #f #f
+ (lambda (dbdat db)
+ (sqlite3:fold-row backcons '() db "SELECT id FROM runs WHERE last_update>=?" since-time))
+ )
+ )
+ )
+ (for-each
+ (lambda (run_id)
+ (set! all_tests
+ (append
+ (map (lambda (x) (cons x run_id))
+ (db:with-db dbstruct run_id #f
+ (lambda (dbdat db)
+ (sqlite3:fold-row backcons '() db "SELECT id FROM tests WHERE run_id=? and last_update>=?" run_id since-time)
+ )
+ )
+ ) all_tests
+ )
+ )
+ )
+ changed_run_ids
+ )
+ (debug:print 2 *default-log-port* "run_ids = " run_ids)
+ (debug:print 2 *default-log-port* "all_tests = " all_tests)
+
+ `((runs . ,run_ids)
+ (tests . ,all_tests)
+ )
+ )
+)
+
+
+(define (db:get-changed-record-test-ids dbstruct since-time run-id)
+ (let* ((backcons (lambda (lst item)(cons item lst)))
+ (all-tests (db:with-db dbstruct run-id #f
+ (lambda (dbdat db)
+ (sqlite3:fold-row backcons '() db "SELECT id FROM tests WHERE run_id=? and last_update>=?" run-id since-time)))))
+
+ all-tests))
+
+(define (db:get-changed-record-run-ids dbstruct since-time)
+ ;; no transaction, allow the db to be accessed between the big queries
+ (let* ((backcons (lambda (lst item)(cons item lst)))
+ (run_ids (db:with-db dbstruct #f #f
+ (lambda (dbdat db)
+ (sqlite3:fold-row backcons '() db "SELECT id FROM runs WHERE last_update>=?" since-time)))))
+ (debug:print 2 *default-log-port* "run_ids = " run_ids)
+ run_ids)
+)
+
+(define (db:get-all-runids dbstruct)
+ (let* ((backcons (lambda (lst item)(cons item lst)))
+ (all_run_ids (db:with-db dbstruct #f #f
+ (lambda (dbdat db)
+ (sqlite3:fold-row backcons '() db "SELECT id FROM runs")))))
+
+all_run_ids))
+
+;;======================================================================
+;; Extract ods file from the db
+;;======================================================================
+
+;; NOT REWRITTEN YET!!!!!
+
+;; runspatt is a comma delimited list of run patterns
+;; keypatt-alist must contain *all* keys with an associated pattern: '( ("KEY1" "%") .. )
+(define (db:extract-ods-file dbstruct outputfile keypatt-alist runspatt pathmod)
+ (assert #f "FATAL: call to db:extract-ods-file which is not ported yet.")
+ (let* ((keysstr (string-intersperse (map car keypatt-alist) ","))
+ (keyqry (string-intersperse (map (lambda (p)(conc (car p) " LIKE ? ")) keypatt-alist) " AND "))
+ (numkeys (length keypatt-alist))
+ (test-ids '())
+ (dbdat (db:get-subdb dbstruct))
+ (db (dbr:dbdat-dbh dbdat))
+ (windows (and pathmod (substring-index "\\" pathmod)))
+ (tempdir (conc "/tmp/" (current-user-name) "/" runspatt "_" (random 10000) "_" (current-process-id)))
+ (runsheader (append (list "Run Id" "Runname") ; 0 1
+ (map car keypatt-alist) ; + N = length keypatt-alist
+ (list "Testname" ; 2
+ "Item Path" ; 3
+ "Description" ; 4
+ "State" ; 5
+ "Status" ; 6
+ "Final Log" ; 7
+ "Run Duration" ; 8
+ "When Run" ; 9
+ "Tags" ; 10
+ "Run Owner" ; 11
+ "Comment" ; 12
+ "Author" ; 13
+ "Test Owner" ; 14
+ "Reviewed" ; 15
+ "Diskfree" ; 16
+ "Uname" ; 17
+ "Rundir" ; 18
+ "Host" ; 19
+ "Cpu Load" ; 20
+ )))
+ (results (list runsheader))
+ (testdata-header (list "Run Id" "Testname" "Item Path" "Category" "Variable" "Value" "Expected" "Tol" "Units" "Status" "Comment"))
+ (mainqry (conc "SELECT
+ t.testname,r.id,runname," keysstr ",t.testname,
+ t.item_path,tm.description,t.state,t.status,
+ final_logf,run_duration,
+ strftime('%m/%d/%Y %H:%M:%S',datetime(t.event_time,'unixepoch'),'localtime'),
+ tm.tags,r.owner,t.comment,
+ author,
+ tm.owner,reviewed,
+ diskfree,uname,rundir,
+ host,cpuload
+ FROM tests AS t JOIN runs AS r ON t.run_id=r.id JOIN test_meta AS tm ON tm.testname=t.testname
+ WHERE runname LIKE ? AND " keyqry ";")))
+ (debug:print 2 *default-log-port* "Using " tempdir " for constructing the ods file. keyqry: " keyqry " keystr: " keysstr " with keys: " (map cadr keypatt-alist)
+ "\n mainqry: " mainqry)
+ ;; "Expected Value"
+ ;; "Value Found"
+ ;; "Tolerance"
+ (apply sqlite3:for-each-row
+ (lambda (test-id . b)
+ (set! test-ids (cons test-id test-ids)) ;; test-id is now testname
+ (set! results (append results ;; note, drop the test-id
+ (list
+ (if pathmod
+ (let* ((vb (apply vector b))
+ (keyvals (let loop ((i 0)
+ (res '()))
+ (if (>= i numkeys)
+ res
+ (loop (+ i 1)
+ (append res (list (vector-ref vb (+ i 2))))))))
+ (runname (vector-ref vb 1))
+ (testname (vector-ref vb (+ 2 numkeys)))
+ (item-path (vector-ref vb (+ 3 numkeys)))
+ (final-log (vector-ref vb (+ 7 numkeys)))
+ (run-dir (vector-ref vb (+ 18 numkeys)))
+ (log-fpath (conc run-dir "/" final-log))) ;; (string-intersperse keyvals "/") "/" testname "/" item-path "/"
+ (debug:print 4 *default-log-port* "log: " log-fpath " exists: " (common:file-exists? log-fpath))
+ (vector-set! vb (+ 7 numkeys) (if (common:file-exists? log-fpath)
+ (let ((newpath (conc pathmod "/"
+ (string-intersperse keyvals "/")
+ "/" runname "/" testname "/"
+ (if (string=? item-path "") "" (conc "/" item-path))
+ final-log)))
+ ;; for now throw away newpath and use the log-fpath conc'd with pathmod
+ (set! newpath (conc pathmod log-fpath))
+ (if windows (string-translate newpath "/" "\\") newpath))
+ (if (debug:debug-mode 1)
+ (conc final-log " not-found")
+ "")))
+ (vector->list vb))
+ b)))))
+ db
+ mainqry
+ runspatt (map cadr keypatt-alist))
+ (debug:print 2 *default-log-port* "Found " (length test-ids) " records")
+ (set! results (list (cons "Runs" results)))
+ ;; now, for each test, collect the test_data info and add a new sheet
+ (for-each
+ (lambda (test-id)
+ (let ((test-data (list testdata-header))
+ (curr-test-name #f))
+ (sqlite3:for-each-row
+ (lambda (run-id testname item-path category variable value expected tol units status comment)
+ (set! curr-test-name testname)
+ (set! test-data (append test-data (list (list run-id testname item-path category variable value expected tol units status comment)))))
+ db
+ ;; "SELECT run_id,testname,item_path,category,variable,td.value AS value,expected,tol,units,td.status AS status,td.comment AS comment FROM test_data AS td INNER JOIN tests ON tests.id=td.test_id WHERE test_id=?;"
+ "SELECT run_id,testname,item_path,category,variable,td.value AS value,td.expected,td.tol,td.units,td.status AS status,td.comment AS comment FROM test_data AS td INNER JOIN tests ON tests.id=td.test_id WHERE testname=?;"
+ test-id)
+ (if curr-test-name
+ (set! results (append results (list (cons curr-test-name test-data)))))
+ ))
+ (sort (delete-duplicates test-ids) string<=))
+ (system (conc "mkdir -p " tempdir))
+ ;; (pp results)
+ (ods:list->ods
+ tempdir
+ (if (string-match (regexp "^[/~]+.*") outputfile) ;; full path?
+ outputfile
+ (begin
+ (debug:print 0 *default-log-port* "WARNING: path given, " outputfile " is relative, prefixing with current directory")
+ (conc (current-directory) "/" outputfile)))
+ results)
+ ;; brutal clean up
+ (dbfile:add-dbdat dbstruct #f dbdat)
+ (system "rm -rf tempdir")))
+
+;; (db:extract-ods-file db "outputfile.ods" '(("sysname" "%")("fsname" "%")("datapath" "%")) "%")
+
+;;======================================================================
+;; moving watch dogs here due to dependencies
+;;======================================================================
+
+;;======================================================================
+;; currently the primary job of the watchdog is to run the sync back to megatest.db from the db in /tmp
+;; if we are on the homehost and we are a server (by definition we are on the homehost if we are a server)
+;;
+(define (common:readonly-watchdog dbstruct)
+ (thread-sleep! 0.05) ;; delay for startup
+ (debug:print-info 13 *default-log-port* "common:readonly-watchdog entered.")
+ ;; sync megatest.db to /tmp/.../megatst.db
+ (let* ((sync-cool-off-duration 3)
+ (golden-mtdb (dbr:dbstruct-mtdb dbstruct))
+ (golden-mtpath (db:dbdat-get-path golden-mtdb))
+ (tmp-mtdb (dbr:dbstruct-tmpdb dbstruct))
+ (tmp-mtpath (db:dbdat-get-path tmp-mtdb)))
+ (debug:print-info 0 *default-log-port* "Read-only periodic sync thread started.")
+ (let loop ((last-sync-time 0))
+ (debug:print-info 13 *default-log-port* "loop top tmp-mtpath="tmp-mtpath" golden-mtpath="golden-mtpath)
+ (let* ((duration-since-last-sync (- (current-seconds) last-sync-time)))
+ (debug:print-info 13 *default-log-port* "duration-since-last-sync="duration-since-last-sync)
+ (if (and (not *time-to-exit*)
+ (< duration-since-last-sync sync-cool-off-duration))
+ (thread-sleep! (- sync-cool-off-duration duration-since-last-sync)))
+ (if (not *time-to-exit*)
+ (let ((golden-mtdb-mtime (file-modification-time golden-mtpath))
+ (tmp-mtdb-mtime (file-modification-time tmp-mtpath)))
+ (if (> golden-mtdb-mtime tmp-mtdb-mtime)
+ (if (< golden-mtdb-mtime (- (current-seconds) 3)) ;; file has NOT been touched in past three seconds, this way multiple servers won't fight to sync back
+ (let ((res (db:multi-db-sync dbstruct 'old2new)))
+ (debug:print-info 13 *default-log-port* "rosync called, " res " records transferred."))))
+ (loop (current-seconds)))
+ #t)))
+ (debug:print-info 0 *default-log-port* "Exiting readonly-watchdog timer, *time-to-exit* = " *time-to-exit*" pid="(current-process-id)" mtpath="golden-mtpath)))
+
+
+;; Get a lock from the no-sync-db for the from-db, then copy the from-db to the to-db, otherwise return #f
+
+(define (db:lock-and-sync no-sync-db from-db to-db)
+ (assert (not *db-sync-in-progress*) "FATAL: db:lock-and-sync called while a sync is in progress.")
+ (let* ((lockdat (db:no-sync-get-lock no-sync-db from-db))
+ (gotlock (car lockdat))
+ (locktime (cdr lockdat)))
+ (if gotlock
+ (begin
+ (file-copy from-db to-db #t)
+ (db:no-sync-del! no-sync-db from-db)
+ #t)
+ (begin
+ (debug:print 0 *default-log-port* "could not get lock for " from-db " from no-sync-db")
+ #f
+ ))))
+
+;; sync for filesystem local db writes
+;;
+(define (db:run-lock-and-sync no-sync-db)
+ (let* ((tmp-area (common:make-tmpdir-name *toppath* ""))
+ (dbfiles (glob (conc tmp-area"/.mtdb/*.db")))
+ (sync-durations (make-hash-table)))
+ ;; (debug:print-info 0 *default-log-port* "lock-and-sync, dbfiles: "dbfiles)
+ (for-each
+ (lambda (file)
+ (let* ((fname (conc (pathname-file file) ".db"))
+ (fulln (conc *toppath*"/.mtdb/"fname))
+ (time1 (if (file-exists? file)
+ (file-modification-time file)
+ (begin
+ (debug:print-info 0 *default-log-port* "Sync - I do not see file "file)
+ 1)))
+ (time2 (if (file-exists? fulln)
+ (file-modification-time fulln)
+ (begin
+ (debug:print-info 0 *default-log-port* "Sync - I do not see file "fulln)
+ 0)))
+ (changed (> time1 time2))
+ (do-cp (cond
+ ((not (file-exists? fulln)) ;; shouldn't happen, but this might recover
+ (debug:print-info 0 *default-log-port* "File "fulln" not found! Copying "fname" to "fulln)
+ #t)
+ (changed ;; (and changed
+ ;; (> (- (current-seconds) time1) 3)) ;; if file is changed and three seconds have passed.
+ #t)
+ ((and changed *time-to-exit*) ;; last copy
+ #t)
+ (else
+ #f))))
+ (if do-cp
+ (let* ((start-time (current-milliseconds)))
+ (debug:print-info 0 *default-log-port* "sync copy file: " fname", delta: " (- time1 time2) " seconds")
+ (db:lock-and-sync no-sync-db file fulln)
+ (hash-table-set! sync-durations (conc fname".db") (- (current-milliseconds) start-time)))
+ #;(debug:print-info 0 *default-log-port* "skipping sync..."))))
+ dbfiles)
+ (hash-table->alist sync-durations)))
+
+;; straight forward copy based sync
+;; 1. for each .db fil
+;; 2. next if file changed since last sync cycle
+;; 2. next if time delta /tmp file to MTRA less than 3 seconds
+;; 3. get a lock for the file in nosyncdb
+;; 4. copy the file
+;; 5. when copy is done release the lock
+;;
+;; DONE
+(define (server:writable-watchdog-copysync dbstruct)
+ (thread-sleep! 0.05) ;; delay for startup
+ (let ((legacy-sync (common:run-sync?))
+ (sync-stale-seconds (configf:lookup-number *configdat* "server" "sync-stale-seconds" default: 300))
+ (debug-mode (debug:debug-mode 1))
+ (last-time (current-seconds)) ;; last time through the sync loop
+ (no-sync-db (db:open-no-sync-db))
+ (sync-duration 0) ;; run time of the sync in milliseconds
+ (tmp-area (common:make-tmpdir-name *toppath* "")))
+ ;; Sync moved to http-transport keep-running loop
+ (debug:print-info 2 *default-log-port* "Periodic copy-based sync thread started. syncer is copy-sync, tmp-area is " tmp-area)
+ (debug:print-info 3 *default-log-port* "watchdog starting. syncer is copy-sync pid="(current-process-id));; " this-wd-num="this-wd-num)
+
+ (if (and legacy-sync (not *time-to-exit*))
+ (begin
+ (debug:print-info 0 *default-log-port* "Server running, periodic copy-based sync started.")
+ (let loop ()
+
+ ;; run the sync and print out durations
+ (debug:print-info 0 *default-log-port* "Sync durations: "(db:run-lock-and-sync no-sync-db))
+ ;; keep going unless time to exit
+ ;;
+ (if (not *time-to-exit*)
+ (let delay-loop ((count 0))
+ ;;(debug:print-info 13 *default-log-port* "delay-loop top; count="count" pid="(current-process-id)" this-wd-num="this-wd-num" *time-to-exit*="*time-to-exit*)
+
+ (if (and (not *time-to-exit*)
+ (< count 6)) ;; was 11, changing to 4.
+ (begin
+ (thread-sleep! 1)
+ (delay-loop (+ count 1))))
+ (if (not *time-to-exit*) (loop))))
+
+ ;; ==> ;; time to exit, close the no-sync db here
+ ;; ==> (db:no-sync-close-db no-sync-db stmt-cache)
+ (if (common:low-noise-print 30)
+ (debug:print-info 0 *default-log-port* "Exiting watchdog timer, *time-to-exit* = "
+ *time-to-exit*" pid="(current-process-id) )))))))
+
+
+(define (server:writable-watchdog-deltasync dbstruct)
+ ;; This is awful complex and convoluted. Plan to redo?
+ ;; for now ... skip it.
+
+ (thread-sleep! 0.05) ;; delay for startup
+ (let ((legacy-sync (common:run-sync?)))
+ (sync-stale-seconds (configf:lookup-number *configdat* "server" "sync-stale-seconds" default: 300))
+ (debug-mode (debug:debug-mode 1))
+ (last-time (current-seconds))
+ (no-sync-db (db:open-no-sync-db))
+ (stmt-cache #f) ;; (dbr:dbstruct-stmt-cache dbstruct))
+ (sync-duration 0) ;; run time of the sync in milliseconds
+ (subdbs (hash-table-values (dbr:dbstruct-subdbs dbstruct))))
+ (debug:print-info 2 *default-log-port* "Periodic sync thread started.")
+ (debug:print-info 3 *default-log-port* "watchdog starting. legacy-sync is " legacy-sync" pid="(current-process-id) );; " this-wd-num="this-wd-num)
+
+ (if (and legacy-sync (not *time-to-exit*))
+ (begin
+ (debug:print-info 0 *default-log-port* "Server running, periodic sync started.")
+ (let loop ()
+ ;; sync for filesystem local db writes
+ ;;
+ (mutex-lock! *db-multi-sync-mutex*)
+ (let* ((start-file (conc tmp-area "/.start-sync"))
+ (end-file (conc tmp-area "/.end-sync"))
+
+ (need-sync (>= *db-last-access* *db-last-sync*)) ;; no sync since last write
+ (sync-in-progress *db-sync-in-progress*)
+ (min-intersync-delay (configf:lookup-number *configdat* "server" "minimum-intersync-delay" default: 5))
+ (should-sync (and (not *time-to-exit*)
+ (> (- (current-seconds) *db-last-sync*) min-intersync-delay))) ;; sync every five seconds minimum, deprecated logic, can probably be removed
+ (start-time (current-seconds))
+ (cpu-load-adj (alist-ref 'adj-proc-load (common:get-normalized-cpu-load #f)))
+ (mt-mod-time (file-modification-time mtpath))
+ (last-sync-start (if (common:file-exists? start-file)
+ (file-modification-time start-file)
+ 0))
+ (last-sync-end (if (common:file-exists? end-file)
+ (file-modification-time end-file)
+ 10))
+ (sync-period (+ 3 (* cpu-load-adj 30))) ;; as adjusted load increases increase the sync period
+ (recently-synced (and (< (- start-time mt-mod-time) sync-period) ;; not useful if sync didn't modify megatest.db!
+ (< mt-mod-time last-sync-start)))
+ (sync-done (<= last-sync-start last-sync-end))
+ (sync-stale (> start-time (+ last-sync-start sync-stale-seconds)))
+ (will-sync (and (not *time-to-exit*) ;; do not start a sync if we are in the process of exiting
+ (or need-sync should-sync)
+ (or sync-done sync-stale)
+ (not sync-in-progress)
+ (not recently-synced))))
+ (debug:print-info 13 *default-log-port* "WD writable-watchdog top of loop. need-sync="need-sync" sync-in-progress=" sync-in-progress
+ " should-sync="should-sync" start-time="start-time" mt-mod-time="mt-mod-time" recently-synced="recently-synced" will-sync="will-sync
+ " sync-done=" sync-done " sync-period=" sync-period)
+ (if (and (> sync-period 5)
+ (common:low-noise-print 30 "sync-period"))
+ (debug:print-info 0 *default-log-port* "Increased sync period due to long sync times, sync took: " sync-period " seconds."))
+ ;; (if recently-synced (debug:print-info 0 *default-log-port* "Skipping sync due to recently-synced flag=" recently-synced))
+ ;; (debug:print-info 0 *default-log-port* "need-sync: " need-sync " sync-in-progress: " sync-in-progress " should-sync: " should-sync " will-sync: " will-sync)
+ (if will-sync (set! *db-sync-in-progress* #t))
+ (mutex-unlock! *db-multi-sync-mutex*)
+ (if will-sync
+ (let (;; (max-sync-duration (configf:lookup-number *configdat* "server" "max-sync-duration")) ;; KEEPING THIS AVAILABLE BUT SHOULD NOT USE, I'M PRETTY SURE IT DOES NOT WORK!
+ (sync-start (current-milliseconds)))
+ (with-output-to-file start-file (lambda ()(print (current-process-id))))
+
+ ;; put lock here
+
+ ;; (if (or (not max-sync-duration)
+ ;; (< sync-duration max-sync-duration)) ;; NOTE: db:sync-to-megatest.db keeps track of time of last sync and syncs incrementally
+
+ ;;
+
+ (for-each
+ (lambda (subdb)
+ (let* (;;(dbstruct (db:setup))
+ (mtdb (dbr:subdb-mtdb subdb))
+ (mtpath (db:dbdat-get-path mtdb))
+ (tmp-area (common:make-tmpdir-name *toppath* ""))
+ (res (db:sync-to-megatest.db dbstruct no-sync-db: no-sync-db))) ;; did we sync any data? If so need to set the db touched flag to keep the server alive
+ (set! sync-duration (- (current-milliseconds) sync-start))
+ (if (> res 0) ;; some records were transferred, keep the db alive
+ (begin
+ (mutex-lock! *heartbeat-mutex*)
+ (set! *db-last-access* (current-seconds))
+ (mutex-unlock! *heartbeat-mutex*)
+ (debug:print-info 0 *default-log-port* "sync called, " res " records transferred."))
+ (debug:print-info 2 *default-log-port* "sync called but zero records transferred")))
+ )
+ subdbs)))
+
+ (if will-sync
+ (begin
+ (mutex-lock! *db-multi-sync-mutex*)
+ (set! *db-sync-in-progress* #f)
+ (set! *db-last-sync* start-time)
+ (with-output-to-file end-file (lambda ()(print (current-process-id))))
+
+ ;; release lock here
+
+ (mutex-unlock! *db-multi-sync-mutex*)))
+ (if (and debug-mode
+ (> (- start-time last-time) 60))
+ (begin
+ (set! last-time start-time)
+ (debug:print-info 4 *default-log-port* "timestamp -> " (seconds->time-string (current-seconds)) ", time since start -> " (seconds->hr-min-sec (- (current-seconds) *time-zero*))))))
+
+ ;; keep going unless time to exit
+ ;;
+ (if (not *time-to-exit*)
+ (let delay-loop ((count 0))
+ ;;(debug:print-info 13 *default-log-port* "delay-loop top; count="count" pid="(current-process-id)" this-wd-num="this-wd-num" *time-to-exit*="*time-to-exit*)
+
+ (if (and (not *time-to-exit*)
+ (< count 6)) ;; was 11, changing to 4.
+ (begin
+ (thread-sleep! 1)
+ (delay-loop (+ count 1))))
+ (if (not *time-to-exit*) (loop))))
+
+;; ;; time to exit, close the no-sync db here
+;; (db:no-sync-close-db no-sync-db stmt-cache)
+ (if (common:low-noise-print 30)
+ (debug:print-info 0 *default-log-port* "Exiting watchdog timer, *time-to-exit* = " *time-to-exit*" pid="(current-process-id) ))))
+))
+
+(define (std-exit-procedure)
+ ;;(common:telemetry-log-close)
+ (on-exit (lambda () 0)) ;; why is this here?
+ ;;(debug:print-info 13 *default-log-port* "std-exit-procedure called; *time-to-exit*="*time-to-exit*)
+ (let ((no-hurry (if *time-to-exit* ;; hurry up
+ #f
+ (begin
+ (set! *time-to-exit* #t)
+ #t))))
+ (debug:print-info 4 *default-log-port* "starting exit process, finalizing databases.")
+ (if (and no-hurry
+ (debug:debug-mode 18))
+ (dbmod:print-db-stats))
+ (let ((th1 (make-thread (lambda () ;; thread for cleaning up, give it five seconds
+ (if *dbstruct-dbs* (db:close-all *dbstruct-dbs*)) ;; one second allocated
+ (if (list? *on-exit-procs*)
+ (for-each
+ (lambda (proc)
+ (proc))
+ *on-exit-procs*))
+ (if *task-db*
+ (let ((db (cdr *task-db*)))
+ (if (sqlite3:database? db)
+ (begin
+ (sqlite3:interrupt! db)
+ (sqlite3:finalize! db #t)
+ ;; (vector-set! *task-db* 0 #f)
+ (set! *task-db* #f)))))
+ (if (and *no-sync-db*
+ (sqlite3:database? *no-sync-db*))
+ (sqlite3:finalize! *no-sync-db* #t))
+ (if (and (not (args:get-arg "-server"))
+ *runremote*
+ (eq? (rmt:transport-mode) 'http))
+ (begin
+ (debug:print-info 0 *default-log-port* "Closing all client connections...")
+ (http-transport:close-connections *runremote*)
+ #;(http-client#close-all-connections!)))
+ ;; (if (and *runremote*
+ ;; (remote-conndat *runremote*))
+ ;; (begin
+ ;; (http-client#close-all-connections!))) ;; for http-client
+ (if (not (eq? *default-log-port* (current-error-port)))
+ (close-output-port *default-log-port*))
+ (set! *default-log-port* (current-error-port))) "Cleanup db exit thread"))
+ (th2 (make-thread (lambda ()
+ (debug:print 4 *default-log-port* "Attempting clean exit. Please be patient and wait a few seconds...")
+ (if no-hurry
+ (begin
+ (thread-sleep! 5)) ;; give the clean up few seconds to do it's stuff
+ (begin
+ (thread-sleep! 2)))
+ (debug:print 4 *default-log-port* " ... done")
+ )
+ "clean exit")))
+ (thread-start! th1)
+ (thread-start! th2)
+ (thread-join! th1)
+ )
+ )
+
+ 0)
+
+)
ADDED fsmod.scm
Index: fsmod.scm
==================================================================
--- /dev/null
+++ fsmod.scm
@@ -0,0 +1,105 @@
+;;======================================================================
+;; Copyright 2017, 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 .
+
+;;======================================================================
+
+;;======================================================================
+;; Megatestmod:
+;;
+;; Put things here don't fit anywhere else
+;;======================================================================
+
+(declare (unit fsmod))
+(declare (uses debugprint))
+(declare (uses mtargs))
+
+(use srfi-69)
+
+(module fsmod
+ *
+
+(import scheme)
+(cond-expand
+ (chicken-4
+
+ (import chicken
+ ports
+ (prefix base64 base64:)
+
+ (prefix sqlite3 sqlite3:)
+ data-structures
+ extras
+ files
+ matchable
+ md5
+ message-digest
+ pathname-expand
+ posix
+ posix-extras
+ regex
+ regex-case
+ sparse-vectors
+ srfi-1
+ srfi-18
+ srfi-69
+ typed-records
+ z3
+
+ debugprint
+ (prefix mtargs args:)
+ )
+ (use srfi-69))
+ (chicken-5
+ (import (prefix sqlite3 sqlite3:)
+ ;; data-structures
+ ;; extras
+ ;; files
+ ;; posix
+ ;; posix-extras
+ chicken.base
+ chicken.condition
+ chicken.file
+ chicken.file.posix
+ chicken.io
+ chicken.pathname
+ chicken.port
+ chicken.process
+ chicken.process-context
+ chicken.process-context.posix
+ chicken.sort
+ chicken.string
+ chicken.time
+ chicken.time.posix
+
+ matchable
+ md5
+ message-digest
+ pathname-expand
+ regex
+ regex-case
+ srfi-1
+ srfi-18
+ srfi-69
+ typed-records
+ system-information
+
+ debugprint
+ )))
+
+
+)
Index: megatest.scm
==================================================================
--- megatest.scm
+++ megatest.scm
@@ -63,10 +63,18 @@
(declare (uses tcp-transportmod.import))
(declare (uses apimod))
(declare (uses apimod.import))
(declare (uses rmtmod))
(declare (uses rmtmod.import))
+(declare (uses fsmod))
+(declare (uses fsmod.import))
+(declare (uses cpumod))
+(declare (uses cpumod.import))
+(declare (uses mtmod))
+(declare (uses mtmod.import))
+(declare (uses megatestmod))
+(declare (uses megatestmod.import))
;; (declare (uses debugprint))
;; (declare (uses debugprint.import))
;; (declare (uses ftail))
Index: megatestmod.scm
==================================================================
--- megatestmod.scm
+++ megatestmod.scm
@@ -117,89 +117,11 @@
(pathname-directory
(pathname-directory
(pathname-directory exe-path))))
#f)))
-;;======================================================================
-;; testsuite and area utilites
-;;======================================================================
-
-(define (get-testsuite-name toppath configdat)
- (or (lookup configdat "setup" "area-name")
- (lookup configdat "setup" "testsuite")
- (get-environment-variable "MT_TESTSUITE_NAME")
- (if (string? toppath)
- (pathname-file toppath)
- #f)))
-
-;; need generic find-record-with-var-nmatching-val
-;;
-(define (path->area-record cfgdat path)
- (let* ((areadat (get-cfg-areas cfgdat))
- (all (filter (lambda (x)
- (let* ((keyvals (cdr x))
- (pth (alist-ref 'path keyvals)))
- (equal? path pth)))
- areadat)))
- (if (null? all)
- #f
- (car all)))) ;; return first match
-
-(define (get-area-name configdat toppath #!optional (short #f))
- ;; look up my area name in areas table (future)
- ;; generate auto name
- (conc (get-area-path-signature toppath short)
- "-"
- (get-testsuite-name toppath configdat)))
-
-;; given a config return an alist of alists
-;; area-name => data
-;;
-(define (get-cfg-areas cfgdat)
- (let ((adat (get-section cfgdat "areas")))
- (map (lambda (entry)
- `(,(car entry) .
- ,(val->alist (cadr entry))))
- adat)))
-
-;;======================================================================
-;; redefine for future cleanup (converge on area-name, the more generic
-;;
-(define common:get-area-name common:get-testsuite-name)
-
-(define (common:get-db-tmp-area . junk)
- (if *db-cache-path*
- *db-cache-path*
- (if *toppath* ;; common:get-create-writeable-dir
- (handle-exceptions
- exn
- (begin
- (debug:print-error 0 *default-log-port* "Couldn't create path to " *db-cache-path* ", exn=" exn)
- (exit 1))
- (let* ((toppath (common:real-path *toppath*))
- (tsname (common:get-testsuite-name))
- (dbpath (common:get-create-writeable-dir
- (list (conc "/tmp/" (current-user-name)
- "/megatest_localdb/"
- tsname "/"
- (string-translate toppath "/" "."))
- (conc "/tmp/" (current-process-id) ;; just in case we have an issue with the dir by own user name
- "/"(current-user-name) "/megatest_localdb/"
- tsname
- (string-translate toppath "/" "."))
- ))))
- (set! *db-cache-path* dbpath)
- ;; ensure megatest area has .mtdb
- (let ((dbarea (conc *toppath* "/.mtdb")))
- (if (not (file-exists? dbarea))
- (create-directory dbarea)))
- ;; ensure tmp area has .mtdb
- (let ((dbarea (conc dbpath "/.mtdb")))
- (if (not (file-exists? dbarea))
- (create-directory dbarea)))
- dbpath))
- #f)))
+
;;======================================================================
;; T A R G E T S , S T A T E , S T A T U S ,
;; R U N N A M E A N D T E S T P A T T
;;======================================================================
@@ -270,14 +192,10 @@
(args:get-arg ":runname")
(getenv "MT_RUNNAME"))))
;; (if res (set-environment-variable "MT_RUNNAME" res)) ;; not sure if this is a good idea. side effect and all ...
res))
-(define (common:get-fields cfgdat)
- (let ((fields (hash-table-ref/default cfgdat "fields" '())))
- (map car fields)))
-
(define (common:args-get-target #!key (split #f)(exit-if-bad #f))
(let* ((keys (if (hash-table? *configdat*) (common:get-fields *configdat*) '()))
(numkeys (length keys))
(target (or (args:get-arg "-reqtarg")
(args:get-arg "-target")
ADDED mtmod.scm
Index: mtmod.scm
==================================================================
--- /dev/null
+++ mtmod.scm
@@ -0,0 +1,205 @@
+;;======================================================================
+;; Copyright 2017, 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 .
+
+;;======================================================================
+
+;;======================================================================
+;; Megatestmod:
+;;
+;; Put things here don't fit anywhere else
+;;======================================================================
+
+(declare (unit mtmod))
+(declare (uses debugprint))
+(declare (uses mtargs))
+(declare (uses commonmod))
+(declare (uses configfmod))
+(declare (uses tcp-transportmod))
+
+(use srfi-69)
+
+(module mtmod
+ *
+
+(import scheme)
+(cond-expand
+ (chicken-4
+
+ (import chicken
+ ports
+ (prefix base64 base64:)
+
+ (prefix sqlite3 sqlite3:)
+ data-structures
+ extras
+ files
+ matchable
+ md5
+ message-digest
+ pathname-expand
+ posix
+ posix-extras
+ regex
+ regex-case
+ sparse-vectors
+ srfi-1
+ srfi-18
+ srfi-69
+ typed-records
+ z3
+
+ debugprint
+ commonmod
+ configfmod
+ tcp-transportmod
+ (prefix mtargs args:)
+ )
+ (use srfi-69))
+ (chicken-5
+ (import (prefix sqlite3 sqlite3:)
+ ;; data-structures
+ ;; extras
+ ;; files
+ ;; posix
+ ;; posix-extras
+ chicken.base
+ chicken.condition
+ chicken.file
+ chicken.file.posix
+ chicken.io
+ chicken.pathname
+ chicken.port
+ chicken.process
+ chicken.process-context
+ chicken.process-context.posix
+ chicken.sort
+ chicken.string
+ chicken.time
+ chicken.time.posix
+
+ matchable
+ md5
+ message-digest
+ pathname-expand
+ regex
+ regex-case
+ srfi-1
+ srfi-18
+ srfi-69
+ typed-records
+ system-information
+
+ debugprint
+ )))
+
+(define (common:get-fields cfgdat)
+ (let ((fields (hash-table-ref/default cfgdat "fields" '())))
+ (map car fields)))
+
+
+;;======================================================================
+;; testsuite and area utilites
+;;======================================================================
+
+(define (get-testsuite-name toppath configdat)
+ (or (lookup configdat "setup" "area-name")
+ (lookup configdat "setup" "testsuite")
+ (get-environment-variable "MT_TESTSUITE_NAME")
+ (if (string? toppath)
+ (pathname-file toppath)
+ #f)))
+
+(define (common:get-testsuite-name)
+ (or (configf:lookup *configdat* "setup" "area-name") ;; megatest is a flexible tool, testsuite is too limiting a description.
+ (configf:lookup *configdat* "setup" "testsuite" )
+ (getenv "MT_TESTSUITE_NAME")
+ (pathname-file (or (if (string? *toppath* )
+ (pathname-file *toppath*)
+ #f)
+ (common:get-toppath #f)))
+ "please-set-setup-area-name")) ;; (pathname-file (current-directory)))))
+
+;; need generic find-record-with-var-nmatching-val
+;;
+(define (path->area-record cfgdat path)
+ (let* ((areadat (get-cfg-areas cfgdat))
+ (all (filter (lambda (x)
+ (let* ((keyvals (cdr x))
+ (pth (alist-ref 'path keyvals)))
+ (equal? path pth)))
+ areadat)))
+ (if (null? all)
+ #f
+ (car all)))) ;; return first match
+
+(define (get-area-name configdat toppath #!optional (short #f))
+ ;; look up my area name in areas table (future)
+ ;; generate auto name
+ (conc (get-area-path-signature toppath short)
+ "-"
+ (get-testsuite-name toppath configdat)))
+
+;; given a config return an alist of alists
+;; area-name => data
+;;
+(define (get-cfg-areas cfgdat)
+ (let ((adat (get-section cfgdat "areas")))
+ (map (lambda (entry)
+ `(,(car entry) .
+ ,(val->alist (cadr entry))))
+ adat)))
+
+;;======================================================================
+;; redefine for future cleanup (converge on area-name, the more generic
+;;
+(define common:get-area-name common:get-testsuite-name)
+
+(define (common:get-db-tmp-area . junk)
+ (if *db-cache-path*
+ *db-cache-path*
+ (if *toppath* ;; common:get-create-writeable-dir
+ (handle-exceptions
+ exn
+ (begin
+ (debug:print-error 0 *default-log-port* "Couldn't create path to " *db-cache-path* ", exn=" exn)
+ (exit 1))
+ (let* ((toppath (common:real-path *toppath*))
+ (tsname (common:get-testsuite-name))
+ (dbpath (common:get-create-writeable-dir
+ (list (conc "/tmp/" (current-user-name)
+ "/megatest_localdb/"
+ tsname "/"
+ (string-translate toppath "/" "."))
+ (conc "/tmp/" (current-process-id) ;; just in case we have an issue with the dir by own user name
+ "/"(current-user-name) "/megatest_localdb/"
+ tsname
+ (string-translate toppath "/" "."))
+ ))))
+ (set! *db-cache-path* dbpath)
+ ;; ensure megatest area has .mtdb
+ (let ((dbarea (conc *toppath* "/.mtdb")))
+ (if (not (file-exists? dbarea))
+ (create-directory dbarea)))
+ ;; ensure tmp area has .mtdb
+ (let ((dbarea (conc dbpath "/.mtdb")))
+ (if (not (file-exists? dbarea))
+ (create-directory dbarea)))
+ dbpath))
+ #f)))
+
+)
Index: rmtmod.scm
==================================================================
--- rmtmod.scm
+++ rmtmod.scm
@@ -20,32 +20,33 @@
(declare (unit rmtmod))
(declare (uses debugprint))
(declare (uses commonmod))
(declare (uses dbfile)) ;; needed for records
-
-;; (declare (uses apimod))
-;; (declare (uses apimod.import))
-;; (declare (uses ulex))
-
-;; (include "ulex/ulex.scm")
+(declare (uses dbmod))
+(declare (uses mtmod))
+(declare (uses tcp-transportmod))
(module rmtmod
*
-(import scheme chicken data-structures extras matchable srfi-69)
+(import scheme chicken data-structures extras matchable srfi-1 srfi-69)
(import (prefix sqlite3 sqlite3:) posix typed-records srfi-18)
-(import commonmod dbfile debugprint) ;; (prefix commonmod cmod:))
-;; (import apimod)
-;; (import (prefix ulex ulex:))
+(import commonmod
+ tcp-transportmod
+ dbfile
+ dbmod
+ debugprint
+ mtmod)
(include "db_records.scm")
(defstruct alldat
(areapath #f)
(ulexdat #f)
)
+
;; hold the send-receive proc in this parameter
(define rmtmod:send-receive #f) ;; (make-parameter #f))
;;======================================================================
Index: server.scm
==================================================================
--- server.scm
+++ server.scm
@@ -39,5 +39,59 @@
(prefix mtargs args:))
(include "common_records.scm")
(include "db_records.scm")
+(define (db:kill-servers)
+ (let* ((tl (launch:setup)) ;; need this to initialize *toppath*
+ (servdir (conc *toppath* "/.servinfo"))
+ (servfiles (glob (conc servdir "/*:*.db")))
+ (fmtstr "~10a~22a~10a~25a~25a~8a\n")
+ (dbfiles (append (glob (conc *toppath* "/.mtdb/main.db")) (glob (conc *toppath* "/.mtdb/?.db"))(glob (conc *toppath* "/.mtdb/??.db"))))
+ (ttdat (make-tt areapath: *toppath*))
+ )
+ (format #t fmtstr "DB" "host:port" "PID" "age" "last mod" "state")
+ (for-each
+ (lambda (dbfile)
+ (let* (
+ (dbfname (conc (pathname-file dbfile) ".db"))
+ (sfiles (tt:find-server *toppath* dbfname))
+ )
+ (for-each
+ (lambda (sfile)
+ (let (
+ (sinfos (tt:get-server-info-sorted ttdat dbfname))
+ )
+ (for-each
+ (lambda (sinfo)
+ (let* (
+ (db (list-ref sinfo 5))
+ (pid (list-ref sinfo 4))
+ (host (list-ref sinfo 0))
+ (port (list-ref sinfo 1))
+ (server-id (list-ref sinfo 3))
+ (age (seconds->hr-min-sec (- (current-seconds) (list-ref sinfo 2))))
+ (last-mod (seconds->string (list-ref sinfo 2)))
+ (killed (system (conc "ssh " host " kill " pid " > /dev/null")))
+ (dummy2 (sleep 1))
+ (state (if (> (system (conc "ssh " host " ps " pid " > /dev/null")) 0) "dead" "alive"))
+ )
+ (format #t fmtstr db (conc host ":" port) pid age last-mod state)
+ (system (conc "rm " sfile))
+ )
+ )
+ sinfos
+ )
+ )
+ )
+ sfiles
+ )
+ )
+ )
+ dbfiles
+ )
+ ;; remove this db, because otherwise metadata contains records for old servers, and this causes a problem with db:no-sync-get-lock-with-id.
+ (if (file-exists? (conc *toppath* "/.mtdb/no-sync.db"))
+ (delete-file (conc *toppath* "/.mtdb/no-sync.db"))
+ )
+ )
+)
Index: servermod.scm
==================================================================
--- servermod.scm
+++ servermod.scm
@@ -875,20 +875,10 @@
(debug:print-error 0 *default-log-port* "failed to remove " fullname ", exn=" exn)
(delete-file* fullname)))))
files)
(debug:print-info 0 *default-log-port* "Deleted " (length files) " files from logs, keeping " max-allowed " files."))))))
-(define (common:get-testsuite-name)
- (or (configf:lookup *configdat* "setup" "area-name") ;; megatest is a flexible tool, testsuite is too limiting a description.
- (configf:lookup *configdat* "setup" "testsuite" )
- (getenv "MT_TESTSUITE_NAME")
- (pathname-file (or (if (string? *toppath* )
- (pathname-file *toppath*)
- #f)
- (common:get-toppath #f)))
- "please-set-setup-area-name")) ;; (pathname-file (current-directory)))))
-
(define (common:wait-for-homehost-load maxnormload msg)
(let loop ((start-time (current-seconds))) ;; we saw some instances of this being called before *toppath* was set. This might be an early setup race. This delay should help but it is impossible to test...
(if (not *toppath*)
(begin
(debug:print 0 *default-log-port* "ERROR: common:wait-for-homehost-load called before *toppath* set.")