Index: Makefile
==================================================================
--- Makefile
+++ Makefile
@@ -22,17 +22,21 @@
CSCOPTS=
INSTALL=install
SRCFILES = common.scm items.scm launch.scm ods.scm runconfig.scm \
server.scm configf.scm db.scm keys.scm margs.scm \
process.scm runs.scm tasks.scm tests.scm genexample.scm \
- http-transport.scm filedb.scm tdb.scm client.scm mt.scm \
- ezsteps.scm lock-queue.scm sdb.scm rmt.scm api.scm \
+ http-transport.scm tdb.scm client.scm mt.scm \
+ ezsteps.scm lock-queue.scm rmt.scm api.scm \
subrun.scm portlogger.scm archive.scm env.scm \
diff-report.scm cgisetup/models/pgdb.scm
# module source files
-MSRCFILES = dbmod.scm
+MSRCFILES = dbmod.scm dbfile.scm debugprint.scm mtargs.scm
+
+mofiles/dbfile.o : mofiles/debugprint.o
+mofiles/debugprint.o : mofiles/mtargs.o
+
# ftail.scm rmtmod.scm commonmod.scm removed
# MSRCFILES = ducttape-lib.scm pkts.scm stml2.scm cookie.scm mutils.scm \
# mtargs.scm commonmod.scm dbmod.scm adjutant.scm ulex.scm \
# rmtmod.scm apimod.scm
@@ -162,19 +166,19 @@
monitor.o dashboard.o archive.o megatest.o : db_records.scm megatest-fossil-hash.scm
tests.o runs.o dashboard.o dashboard-tests.o dashboard-context-menu.o dashboard-main.o : run_records.scm
db.o ezsteps.o keys.o launch.o megatest.o monitor.o runs-for-ref.o runs.o tests.o : key_records.scm
-db.o api.o : mofiles/dbmod.o
+db.o api.o : mofiles/dbmod.o mofiles/dbfile.o mofiles/debugprint.o
tests.o tasks.o dashboard-tasks.o : task_records.scm
runs.o : test_records.scm
megatest.o : megatest-fossil-hash.scm megatest-version.scm
-rmt.scm client.scm common.scm configf.scm dashboard-guimonitor.scm dashboard-tests.scm dashboard.scm db.scm dcommon.scm ezsteps.scm fs-transport.scm http-transport.scm index-tree.scm items.scm keys.scm launch.scm megatest.scm monitor.scm mt.scm newdashboard.scm runconfig.scm runs.scm server.scm tdb.scm tests.scm tree.scm : common_records.scm megatest-version.scm
+rmt.scm client.scm common.scm configf.scm dashboard-guimonitor.scm dashboard-tests.scm dashboard.scm db.scm dcommon.scm ezsteps.scm http-transport.scm index-tree.scm items.scm keys.scm launch.scm megatest.scm monitor.scm mt.scm newdashboard.scm runconfig.scm runs.scm server.scm tdb.scm tests.scm tree.scm : common_records.scm megatest-version.scm
common_records.scm : altdb.scm
# mofiles/stml2.o : mofiles/cookie.o
# configf.o : mofiles/commonmod.o
@@ -455,12 +459,12 @@
fi
if csi -ne '(use postgresql)';then \
echo "(use postgresql)(hash-table-set! *available-db* 'postgresql #t)" >> altdb.scm;\
fi
-portlogger-example : portlogger-example.scm api.o archive.o client.o common.o configf.o dashboard-tests.o dashboard-context-menu.o db.o dcommon.o ezsteps.o filedb.o genexample.o gutils.o http-transport.o items.o keys.o launch.o lock-queue.o margs.o mt.o ods.o portlogger.o process.o rmt.o runconfig.o runs.o sdb.o server.o synchash.o tasks.o tdb.o tests.o tree.o
- csc $(CSCOPTS) portlogger-example.scm api.o archive.o client.o common.o configf.o dashboard-tests.o dashboard-context-menu.o db.o dcommon.o ezsteps.o filedb.o genexample.o gutils.o http-transport.o items.o keys.o launch.o lock-queue.o margs.o mt.o ods.o portlogger.o process.o rmt.o runconfig.o runs.o sdb.o server.o synchash.o tasks.o tdb.o tests.o tree.o
+portlogger-example : portlogger-example.scm api.o archive.o client.o common.o configf.o dashboard-tests.o dashboard-context-menu.o db.o dcommon.o ezsteps.o genexample.o gutils.o http-transport.o items.o keys.o launch.o lock-queue.o margs.o mt.o ods.o portlogger.o process.o rmt.o runconfig.o runs.o server.o synchash.o tasks.o tdb.o tests.o tree.o
+ csc $(CSCOPTS) portlogger-example.scm api.o archive.o client.o common.o configf.o dashboard-tests.o dashboard-context-menu.o db.o dcommon.o ezsteps.o genexample.o gutils.o http-transport.o items.o keys.o launch.o lock-queue.o margs.o mt.o ods.o portlogger.o process.o rmt.o runconfig.o runs.o server.o synchash.o tasks.o tdb.o tests.o tree.o
# create a pdf dot graphviz diagram from notations in rmt.scm
rmt.pdf : rmt.scm
grep ';;DOT' rmt.scm | sed -e 's/.*;;DOT //' > rmt.dot;dot -Tpdf rmt.dot -o rmt.pdf
Index: api.scm
==================================================================
--- api.scm
+++ api.scm
@@ -24,13 +24,15 @@
(declare (unit api))
(declare (uses rmt))
(declare (uses db))
(declare (uses dbmod))
+(declare (uses dbfile))
(declare (uses tasks))
(import dbmod)
+(import dbfile)
;; allow these queries through without starting a server
;;
(define api:read-only-queries
'(get-key-val-pairs
@@ -144,10 +146,11 @@
;; - keep it simple, only return the actual result of the call, i.e. no meta info here
;;
;; - returns #( flag result )
;;
(define (api:execute-requests dbstruct dat)
+ (db:open-no-sync-db) ;; sets *no-sync-db*
(handle-exceptions
exn
(let ((call-chain (get-call-chain)))
(debug:print 0 *default-log-port* "WARNING: api:execute-requests received an exception from peer, dat=" dat ", exn=" exn)
(print-call-chain (current-error-port))
@@ -342,11 +345,11 @@
((have-incompletes?) (apply db:have-incompletes? dbstruct params))
((login) (apply db:login dbstruct params))
((general-call) (let ((stmtname (car params))
(run-id (cadr params))
(realparams (cddr params)))
- (db:general-call dbstruct stmtname realparams)))
+ (db:general-call dbstruct run-id stmtname realparams)))
((sdb-qry) (apply sdb:qry params))
((ping) (current-process-id))
((get-changed-record-ids) (apply db:get-changed-record-ids dbstruct params))
((get-run-record-ids) (apply db:get-run-record-ids dbstruct params))
;; TESTMETA
Index: archive.scm
==================================================================
--- archive.scm
+++ archive.scm
@@ -397,11 +397,11 @@
(bup-restore-params (list "-d" archive-path "restore" "-C" *toppath* archive-internal-path)))
(debug:print-info 2 *default-log-port* "Restoring archived data to " *toppath* " from archive in " archive-path " ... " archive-internal-path)
(run-n-wait bup-exe params: bup-restore-params print-cmd: "Running:"))
(sleep 2)
(db:multi-db-sync
- (db:setup #f)
+ (db:setup #t) ;; (db:setup-db *dbstruct-dbs* *toppath* #f)
'killservers
;'dejunk
;'adj-testids
'old2new
)
ADDED attic/filedb.scm
Index: attic/filedb.scm
==================================================================
--- /dev/null
+++ attic/filedb.scm
@@ -0,0 +1,255 @@
+;; Copyright 2006-2011, 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 .
+;;
+
+;; (require-extension synch sqlite3 posix srfi-13 srfi-1 utils regex)
+(use sqlite3 srfi-1 posix regex srfi-69 srfi-13 posix-extras)
+(import (prefix sqlite3 sqlite3:))
+
+(declare (unit filedb))
+
+(include "fdb_records.scm")
+;; (include "settings.scm")
+
+(define (filedb:open-db dbpath)
+ (let* ((fdb (make-filedb:fdb))
+ (dbexists (common:file-exists? dbpath))
+ (db (sqlite3:open-database dbpath)))
+ (filedb:fdb-set-db! fdb db)
+ (filedb:fdb-set-dbpath! fdb dbpath)
+ (filedb:fdb-set-pathcache! fdb (make-hash-table))
+ (filedb:fdb-set-idcache! fdb (make-hash-table))
+ (filedb:fdb-set-partcache! fdb (make-hash-table))
+ (sqlite3:set-busy-handler! db (make-busy-timeout 136000))
+ (if (not dbexists)
+ (begin
+ (sqlite3:execute db "PRAGMA synchronous = OFF;")
+ (sqlite3:execute db "CREATE TABLE names (id INTEGER PRIMARY KEY,name TEST);") ;; for future use - change path in paths table to path_id
+ (sqlite3:execute db "CREATE INDEX name_index ON names (name);")
+ ;; NB// We store a useful subset of file attributes but do not attempt to store all
+ (sqlite3:execute db "CREATE TABLE paths (id INTEGER PRIMARY KEY,
+ path TEXT,
+ parent_id INTEGER,
+ mode INTEGER DEFAULT -1,
+ uid INTEGER DEFAULT -1,
+ gid INTEGER DEFAULT -1,
+ size INTEGER DEFAULT -1,
+ mtime INTEGER DEFAULT -1);")
+ (sqlite3:execute db "CREATE INDEX path_index ON paths (path,parent_id);")
+ (sqlite3:execute db "CREATE TABLE bases (id INTEGER PRIMARY KEY,base TEXT, updated TIMESTAMP);")))
+ ;; close the sqlite3 db and open it as needed
+ (filedb:finalize-db! fdb)
+ (filedb:fdb-set-db! fdb #f)
+ fdb))
+
+(define (filedb:reopen-db fdb)
+ (let ((db (sqlite3:open-database (filedb:fdb-get-dbpath fdb))))
+ (filedb:fdb-set-db! fdb db)
+ (sqlite3:set-busy-handler! db (make-busy-timeout 136000))))
+
+(define (filedb:finalize-db! fdb)
+ (sqlite3:finalize! (filedb:fdb-get-db fdb)))
+
+(define (filedb:get-current-time-string)
+ (string-chomp (time->string (seconds->local-time (current-seconds)))))
+
+(define (filedb:get-base-id db path)
+ (let ((stmt (sqlite3:prepare db "SELECT id FROM bases WHERE base=?;"))
+ (id-num #f))
+ (sqlite3:for-each-row
+ (lambda (num) (set! id-num num)) stmt path)
+ (sqlite3:finalize! stmt)
+ id-num))
+
+(define (filedb:get-path-id db path parent)
+ (let ((stmt (sqlite3:prepare db "SELECT id FROM paths WHERE path=? AND parent_id=?;"))
+ (id-num #f))
+ (sqlite3:for-each-row
+ (lambda (num) (set! id-num num)) stmt path parent)
+ (sqlite3:finalize! stmt)
+ id-num))
+
+(define (filedb:add-base db path)
+ (let ((existing (filedb:get-base-id db path)))
+ (if existing #f
+ (begin
+ (sqlite3:execute db "INSERT INTO bases (base,updated) VALUES (?,?);" path (filedb:get-current-time-string))))))
+
+;; index value field notes
+;; 0 inode number st_ino
+;; 1 mode st_mode bitfield combining file permissions and file type
+;; 2 number of hard links st_nlink
+;; 3 UID of owner st_uid as with file-owner
+;; 4 GID of owner st_gid
+;; 5 size st_size as with file-size
+;; 6 access time st_atime as with file-access-time
+;; 7 change time st_ctime as with file-change-time
+;; 8 modification time st_mtime as with file-modification-time
+;; 9 parent device ID st_dev ID of device on which this file resides
+;; 10 device ID st_rdev device ID for special files (i.e. the raw major/minor number)
+;; 11 block size st_blksize
+;; 12 number of blocks allocated st_blocks
+
+(define (filedb:add-path-stat db path parent statinfo)
+ (let ((stmt (sqlite3:prepare db "INSERT INTO paths (path,parent_id,mode,uid,gid,size,mtime) VALUES (?,?,?,?,?,?,?);")))
+ (sqlite3:execute stmt
+ path
+ parent
+ (vector-ref statinfo 1) ;; mode
+ (vector-ref statinfo 3) ;; uid
+ (vector-ref statinfo 4) ;; gid
+ (vector-ref statinfo 5) ;; size
+ (vector-ref statinfo 8) ;; mtime
+ )
+ (sqlite3:finalize! stmt))) ;; (filedb:get-current-time-string))))
+
+(define (filedb:add-path db path parent)
+ (let ((stmt (sqlite3:prepare db "INSERT INTO paths (path,parent_id) VALUES (?,?);")))
+ (sqlite3:execute stmt path parent)
+ (sqlite3:finalize! stmt)))
+
+(define (filedb:register-path fdb path #!key (save-stat #f))
+ (let* ((db (filedb:fdb-get-db fdb))
+ (pathcache (filedb:fdb-get-pathcache fdb))
+ (stat (if save-stat (file-stat path #t)))
+ (id (hash-table-ref/default pathcache path #f)))
+ (if (not db)(filedb:reopen-db fdb))
+ (if id id
+ (let ((plist (string-split path "/")))
+ (let loop ((head (car plist))
+ (tail (cdr plist))
+ (parent 0))
+ (let ((id (filedb:get-path-id db head parent))
+ (done (null? tail)))
+ (if id ;; we'll have a id if the path is already registered
+ (if done
+ (begin
+ (hash-table-set! pathcache path id)
+ id) ;; return the last path id for a result
+ (loop (car tail)(cdr tail) id))
+ (begin ;; add the path and then repeat the loop with the same data
+ (if save-stat
+ (filedb:add-path-stat db head parent stat)
+ (filedb:add-path db head parent))
+ (loop head tail parent)))))))))
+
+(define (filedb:update-recursively fdb path #!key (save-stat #f))
+ (let ((p (open-input-pipe (string-append "find -L " path)))) ;; (resolve-pathname path)))) ;; (string-append "find " path))))
+ (print "processed 0 files...")
+ (let loop ((l (read-line p))
+ (lc 0)) ;; line count
+ (if (eof-object? l)
+ (begin
+ (print " " lc " files")
+ (close-input-port p))
+ (begin
+ (filedb:register-path fdb l save-stat: save-stat) ;; (get-real-path l)) ;; don't like losing the original path info
+ (if (= (modulo lc 100) 0)
+ (print " " lc " files"))
+ (loop (read-line p)(+ lc 1)))))))
+
+(define (filedb:update fdb path #!key (save-stat #f))
+ ;; first get the realpath and add it to the bases table
+ (let ((real-path path) ;; (filedb:get-real-path path))
+ (db (filedb:fdb-get-db fdb)))
+ (filedb:add-base db real-path)
+ (filedb:update-recursively fdb path save-stat: save-stat)))
+
+;; not used and broken
+;;
+(define (filedb:get-real-path path)
+ (let* ((p (open-input-pipe (string-append real-path " " (regexp-escape path))))
+ (pth (read-line p)))
+ (if (eof-object? pth) path
+ (begin
+ (close-input-port p)
+ pth))))
+
+(define (filedb:drop-base fdb path)
+ (print "Sorry, I don't do anything yet"))
+
+(define (filedb:find-all fdb pattern action)
+ (let* ((db (filedb:fdb-get-db fdb))
+ (stmt (sqlite3:prepare db "SELECT id FROM paths WHERE path like ?;"))
+ (result '()))
+ (sqlite3:for-each-row
+ (lambda (num)
+ (action num)
+ (set! result (cons num result))) stmt pattern)
+ (sqlite3:finalize! stmt)
+ result))
+
+(define (filedb:get-path-record fdb id)
+ (let* ((db (filedb:fdb-get-db fdb))
+ (partcache (filedb:fdb-get-partcache fdb))
+ (dat (hash-table-ref/default partcache id #f)))
+ (if dat dat
+ (let ((stmt (sqlite3:prepare db "SELECT path,parent_id FROM paths WHERE id=?;"))
+ (result #f))
+ (sqlite3:for-each-row
+ (lambda (path parent_id)(set! result (list path parent_id))) stmt id)
+ (hash-table-set! partcache id result)
+ (sqlite3:finalize! stmt)
+ result))))
+
+(define (filedb:get-children fdb parent-id)
+ (let* ((db (filedb:fdb-get-db fdb))
+ (res '()))
+ (sqlite3:for-each-row
+ (lambda (id path parent-id)
+ (set! res (cons (vector id path parent-id) res)))
+ db "SELECT id,path,parent_id FROM paths WHERE parent_id=?;"
+ parent-id)
+ res))
+
+;; retrieve all that have children and those without
+;; children that match patt
+(define (filedb:get-children-patt fdb parent-id search-patt)
+ (let* ((db (filedb:fdb-get-db fdb))
+ (res '()))
+ ;; first get the children that have no children
+ (sqlite3:for-each-row
+ (lambda (id path parent-id)
+ (set! res (cons (vector id path parent-id) res)))
+ db "SELECT id,path,parent_id FROM paths WHERE parent_id=? AND
+ (id IN (SELECT parent_id FROM paths) OR path LIKE ?);"
+ parent-id search-patt)
+ res))
+
+(define (filedb:get-path fdb id)
+ (let* ((db (filedb:fdb-get-db fdb))
+ (idcache (filedb:fdb-get-idcache fdb))
+ (path (hash-table-ref/default idcache id #f)))
+ (if (not db)(filedb:reopen-db fdb))
+ (if path path
+ (let loop ((curr-id id)
+ (path ""))
+ (let ((path-record (filedb:get-path-record fdb curr-id)))
+ (if (not path-record) #f ;; this id has no path
+ (let* ((parent-id (list-ref path-record 1))
+ (pname (list-ref path-record 0))
+ (newpath (string-append "/" pname path)))
+ (if (= parent-id 0) ;; fields 0=path, 1=parent. root parent=0
+ (begin
+ (hash-table-set! idcache id newpath)
+ newpath)
+ (loop parent-id newpath)))))))))
+
+(define (filedb:search db pattern)
+ (let ((action (lambda (id)(print (filedb:get-path db id)))))
+ (filedb:find-all db pattern action)))
+
ADDED attic/ftail.scm
Index: attic/ftail.scm
==================================================================
--- /dev/null
+++ attic/ftail.scm
@@ -0,0 +1,108 @@
+;;======================================================================
+;; 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 .
+
+;;======================================================================
+
+(declare (unit ftail))
+
+(module ftail
+ (
+ open-tail-db
+ tail-write
+ tail-get-fid
+ file-tail
+ )
+
+(import scheme chicken data-structures extras)
+(use (prefix sqlite3 sqlite3:) posix typed-records)
+
+(define (open-tail-db )
+ (let* ((basedir (create-directory (conc "/tmp/" (current-user-name))))
+ (dbpath (conc basedir "/megatest_logs.db"))
+ (dbexists (file-exists? dbpath))
+ (db (sqlite3:open-database dbpath))
+ (handler (sqlite3:make-busy-timeout 136000)))
+ (sqlite3:set-busy-handler! db handler)
+ (sqlite3:execute db "PRAGMA synchronous = 0;")
+ (if (not dbexists)
+ (begin
+ (sqlite3:execute db "CREATE TABLE IF NOT EXISTS log_files (id INTEGER PRIMARY KEY,filename TEXT,event_time TIMESTAMP DEFAULT (strftime('%s','now')));")
+ (sqlite3:execute db "CREATE TABLE IF NOT EXISTS log_data (id INTEGER PRIMARY KEY,fid INTEGER,line TEXT,event_time TIMESTAMP DEFAULT (strftime('%s','now')));")
+ ))
+ db))
+
+(define (tail-write db fid lines)
+ (sqlite3:with-transaction
+ db
+ (lambda ()
+ (for-each
+ (lambda (line)
+ (sqlite3:execute db "INSERT INTO log_data (fid,line) VALUES (?,?);" fid line))
+ lines))))
+
+(define (tail-get-fid db fname)
+ (let ((fid (handle-exceptions
+ exn
+ #f
+ (sqlite3:first-result db "SELECT id FROM log_files WHERE filename=?;" fname))))
+ (if fid
+ fid
+ (begin
+ (sqlite3:execute db "INSERT INTO log_files (filename) VALUES (?);" fname)
+ (tail-get-fid db fname)))))
+
+(define (file-tail fname #!key (db-in #f))
+ (let* ((inp (open-input-file fname))
+ (db (or db-in (open-tail-db)))
+ (fid (tail-get-fid db fname)))
+ (let loop ((inl (read-line inp))
+ (lines '())
+ (lastwr (current-seconds)))
+ (if (eof-object? inl)
+ (let ((timed-out (> (- (current-seconds) lastwr) 60)))
+ (if timed-out (tail-write db fid (reverse lines)))
+ (sleep 1)
+ (if timed-out
+ (loop (read-line inp) '() (current-seconds))
+ (loop (read-line inp) lines lastwr)))
+ (let* ((savelines (> (length lines) 19)))
+ ;; (print inl)
+ (if savelines (tail-write db fid (reverse lines)))
+ (loop (read-line inp)
+ (if savelines
+ '()
+ (cons inl lines))
+ (if savelines
+ (current-seconds)
+ lastwr)))))))
+
+;; offset -20 means get last 20 lines
+;;
+(define (tail-get-lines db fid offset count)
+ (if (> offset 0)
+ (sqlite3:map-row (lambda (id line)
+ (vector id line))
+ db
+ "SELECT id,line FROM log_data WHERE fid=? OFFSET ? LIMIT ?;" fid offset count)
+ (reverse ;; get N from the end
+ (sqlite3:map-row (lambda (id line)
+ (vector id line))
+ db
+ "SELECT id,line FROM log_data WHERE fid=? ORDER BY id DESC LIMIT ?;" fid (abs offset)))))
+
+)
ADDED attic/sdb.scm
Index: attic/sdb.scm
==================================================================
--- /dev/null
+++ attic/sdb.scm
@@ -0,0 +1,116 @@
+;;======================================================================
+;; Copyright 2006-2013, 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 .
+
+;;======================================================================
+
+;;======================================================================
+;; Simple persistant strings lookup table. Keep out of the main db
+;; so writes/reads don't slow down central access.
+;;======================================================================
+
+(require-extension (srfi 18) extras)
+(use sqlite3 srfi-1 posix regex regex-case srfi-69 csv-xml s11n md5 message-digest base64)
+(import (prefix sqlite3 sqlite3:))
+(import (prefix base64 base64:))
+
+(declare (unit sdb))
+
+;;
+(define (sdb:open fname)
+ (let* ((dbpath (pathname-directory fname))
+ (dbexists (let ((fe (common:file-exists? fname)))
+ (if fe
+ fe
+ (begin
+ (create-directory dbpath #t)
+ #f))))
+ (sdb (sqlite3:open-database fname))
+ (handler (make-busy-timeout 136000)))
+ (sqlite3:set-busy-handler! sdb handler)
+ (if (not dbexists)
+ (sdb:initialize sdb))
+ (sqlite3:execute sdb "PRAGMA synchronous = 1;")
+ sdb))
+
+(define (sdb:initialize sdb)
+ (sqlite3:execute sdb "CREATE TABLE IF NOT EXISTS strs
+ (id INTEGER PRIMARY KEY,
+ str TEXT,
+ CONSTRAINT str UNIQUE (str));")
+ (sqlite3:execute sdb "CREATE INDEX IF NOT EXISTS strindx ON strs (str);"))
+
+;; (define sumup (let ((a 0))(lambda (x)(set! a (+ x a)) a)))
+
+(define (sdb:register-string sdb str)
+ (sqlite3:execute sdb "INSERT OR IGNORE INTO strs (str) VALUES (?);" str))
+
+(define (sdb:string->id sdb str-cache str)
+ (let ((id (hash-table-ref/default str-cache str #f)))
+ (if (not id)
+ (sqlite3:for-each-row
+ (lambda (sid)
+ (set! id sid)
+ (hash-table-set! str-cache str id))
+ sdb
+ "SELECT id FROM strs WHERE str=?;" str))
+ id))
+
+(define (sdb:id->string sdb id-cache id)
+ (let ((str (hash-table-ref/default id-cache id #f)))
+ (if (not str)
+ (sqlite3:for-each-row
+ (lambda (istr)
+ (set! str istr)
+ (hash-table-set! id-cache id str))
+ sdb
+ "SELECT str FROM strs WHERE id=?;" id))
+ str))
+
+;; Numbers get passed though in both directions
+;;
+(define (make-sdb:qry fname)
+ (let ((sdb #f)
+ (scache (make-hash-table))
+ (icache (make-hash-table)))
+ (lambda (cmd var)
+ (case cmd
+ ((setup) (set! sdb (if (not sdb)
+ (sdb:open (if var var fname)))))
+ ((setdb) (set! sdb var))
+ ((getdb) sdb)
+ ((finalize) (if sdb
+ (begin
+ (sqlite3:finalize! sdb)
+ (set! sdb #f))))
+ ((getid) (let ((id (if (or (number? var)
+ (string->number var))
+ var
+ (sdb:string->id sdb scache var))))
+ (if id
+ id
+ (begin
+ (sdb:register-string sdb var)
+ (sdb:string->id sdb scache var)))))
+ ((getstr) (if (or (number? var)
+ (string->number var))
+ (sdb:id->string sdb icache var)
+ var))
+ ((passid) var)
+ ((passstr) var)
+ (else #f)))))
+
Index: common.scm
==================================================================
--- common.scm
+++ common.scm
@@ -135,11 +135,11 @@
(define *default-log-port* (current-error-port))
(define *time-zero* (current-seconds)) ;; for the watchdog
(define *default-area-tag* "local")
;; DATABASE
-(define *dbstruct-db* #f) ;; used to cache the dbstruct in db:setup. Goal is to remove this.
+;; (define *dbstruct-dbs* #f) ;; used to cache the dbstruct in db:setup. Goal is to remove this.
;; db stats
(define *db-stats* (make-hash-table)) ;; hash of vectors < count duration-total >
(define *db-stats-mutex* (make-mutex))
;; db access
(define *db-last-access* (current-seconds)) ;; last db access, used in server
@@ -149,17 +149,17 @@
(define *db-sync-in-progress* #f) ;; if there is a sync in progress do not try to start another
(define *db-multi-sync-mutex* (make-mutex)) ;; protect access to *db-sync-in-progress*, *db-last-sync*
;; task db
(define *task-db* #f) ;; (vector db path-to-db)
(define *db-access-allowed* #t) ;; flag to allow access
-(define *db-access-mutex* (make-mutex))
+;; (define *db-access-mutex* (make-mutex)) ;; moved to dbfile
(define *db-transaction-mutex* (make-mutex))
(define *db-cache-path* #f)
(define *db-with-db-mutex* (make-mutex))
(define *db-api-call-time* (make-hash-table)) ;; hash of command => (list of times)
;; no sync db
-(define *no-sync-db* #f)
+;; (define *no-sync-db* #f) ;; moved to dbfile
;; SERVER
(define *my-client-signature* #f)
(define *transport-type* 'http) ;; override with [server] transport http|rpc|nmsg
(define *runremote* #f) ;; if set up for server communication this will hold
@@ -402,11 +402,12 @@
;;======================================================================
;; Move me elsewhere ...
;; RADT => Why do we meed the version check here, this is called only if version misma
;;
(define (common:cleanup-db dbstruct #!key (full #f))
- (apply db:multi-db-sync
+ (debug:print 0 *default-log-port* "WARNING: common:cleanup-db has NOT been reimplemented yet! Please fix!")
+ #;(apply db:multi-db-sync
dbstruct
'schema
;; 'new2old
'killservers
'adj-target
@@ -591,13 +592,13 @@
;;
(define (common:exit-on-version-changed)
(if (common:on-homehost?)
(if (common:api-changed?)
(let* ((mtconf (conc (get-environment-variable "MT_RUN_AREA_HOME") "/megatest.config"))
- (dbfile (conc (get-environment-variable "MT_RUN_AREA_HOME") "/megatest.db"))
- (read-only (not (file-write-access? dbfile)))
- (dbstruct (db:setup #t)))
+ (dbfile (conc (get-environment-variable "MT_RUN_AREA_HOME") "/megatest.db"))
+ (read-only (not (file-write-access? dbfile)))
+ (dbstruct (db:setup #t))) ;; (db:setup-db *dbstruct-dbs* *toppath* #f))) ;; #t)))
(debug:print 0 *default-log-port*
"WARNING: Version mismatch!\n"
" expected: " (common:version-signature) "\n"
" got: " (common:get-last-run-version))
(cond
@@ -979,10 +980,18 @@
"/megatest_localdb/"
tsname
(string-translate *toppath* "/" "."))
))))
(set! *db-cache-path* dbpath)
+ ;; ensure megatest area has .db
+ (let ((dbarea (conc *toppath* "/.db")))
+ (if (not (file-exists? dbarea))
+ (create-directory dbarea)))
+ ;; ensure tmp area has .db
+ (let ((dbarea (conc dbpath "/.db")))
+ (if (not (file-exists? dbarea))
+ (create-directory dbarea)))
dbpath))
#f)))
(define (common:get-area-path-signature)
(message-digest-string (md5-primitive) *toppath*))
@@ -999,118 +1008,10 @@
(args:get-arg "-server")))
(define (common:human-time)
(time->string (seconds->local-time (current-seconds)) "%Y-%m-%d %H:%M:%S"))
-;;======================================================================
-;; 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)))
-
-;;======================================================================
-;; TODO: for multiple areas, we will have multiple watchdogs; and multiple threads to manage
-(define (common:watchdog)
- (debug:print-info 13 *default-log-port* "common:watchdog entered.")
- (if (launch:setup)
- (if (common:on-homehost?)
- (let ((dbstruct (db:setup #t)))
- (debug:print-info 13 *default-log-port* "after db:setup with dbstruct=" dbstruct)
- (cond
- ((dbr:dbstruct-read-only dbstruct)
- (debug:print-info 13 *default-log-port* "loading read-only watchdog")
- (common:readonly-watchdog dbstruct))
- (else
- (debug:print-info 13 *default-log-port* "loading writable-watchdog.")
- (let* ((syncer (or (configf:lookup *configdat* "server" "sync-method") "brute-force-sync")))
- (cond
- ((equal? syncer "brute-force-sync")
- (server:writable-watchdog-bruteforce dbstruct))
- ((equal? syncer "delta-sync")
- (server:writable-watchdog-deltasync dbstruct))
- (else
- (debug:print-error 0 *default-log-port* "Unknown server/sync-method specified ("syncer") - valid values are brute-force-sync and delta-sync.")
- (exit 1)))
- ;;(debug:print 1 *default-log-port* "INFO: ["(common:human-time)"] Syncer started (method="syncer")")
- )))
- (debug:print-info 13 *default-log-port* "watchdog done."))
- (debug:print-info 13 *default-log-port* "no need for watchdog on non-homehost"))))
-
-
-(define (std-exit-procedure)
- ;;(common:telemetry-log-close)
- (on-exit (lambda () 0))
- ;;(debug:print-info 13 *default-log-port* "std-exit-procedure called; *time-to-exit*="*time-to-exit*)
- (let ((no-hurry (if *time-to-exit* ;; hurry up
- #f
- (begin
- (set! *time-to-exit* #t)
- #t))))
- (debug:print-info 4 *default-log-port* "starting exit process, finalizing databases.")
- (if (and no-hurry (debug:debug-mode 18))
- (rmt:print-db-stats))
- (let ((th1 (make-thread (lambda () ;; thread for cleaning up, give it five seconds
- (if *dbstruct-db* (db:close-all *dbstruct-db*)) ;; one second allocated
- (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)))))
- (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)
(define (std-signal-handler signum)
;; (signal-mask! signum)
(set! *time-to-exit* #t)
;;(debug:print-info 13 *default-log-port* "got signal "signum)
ADDED configfmod.scm
Index: configfmod.scm
==================================================================
--- /dev/null
+++ configfmod.scm
@@ -0,0 +1,75 @@
+;;======================================================================
+;; 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 .
+
+;;======================================================================
+
+(declare (unit configfmod))
+;; (declare (uses mtargs))
+;; (declare (uses debugprint))
+;; (declare (uses keysmod))
+
+(module configfmod
+*
+
+(import srfi-1
+
+;; scheme
+;;
+;; big-chicken ;; more of a reminder than anything ...
+;; chicken.base
+;; chicken.condition
+;; chicken.file
+;; chicken.io
+;; chicken.pathname
+;; chicken.port
+;; chicken.pretty-print
+;; chicken.process
+;; chicken.process-context
+;; chicken.process-context.posix
+;; chicken.sort
+;; chicken.string
+;; chicken.time
+;; chicken.eval
+;;
+;; debugprint
+;; (prefix mtargs args:)
+;; pkts
+;; keysmod
+;;
+;; (prefix base64 base64:)
+;; (prefix dbi dbi:)
+;; (prefix sqlite3 sqlite3:)
+;; (srfi 18)
+;; directory-utils
+;; format
+;; matchable
+;; md5
+;; message-digest
+;; regex
+;; regex-case
+;; sparse-vectors
+;; srfi-1
+;; srfi-13
+;; srfi-69
+;; stack
+;; typed-records
+;; z3
+
+ )
+)
+
Index: dashboard.scm
==================================================================
--- dashboard.scm
+++ dashboard.scm
@@ -159,11 +159,11 @@
;; create a watch dog to move changes from lt/.db/*.db to megatest.db
;;
;;;(if (file-write-access? (conc *toppath* "/megatest.db"))
;;(debug:print-info 13 *default-log-port* "Before common:watchdog spawn")
-(thread-start! (make-thread common:watchdog "Watchdog thread"))
+;; (thread-start! (make-thread common:watchdog "Watchdog thread"))
;;(debug:print-info 13 *default-log-port* "After common:watchdog spawn")
;; (if (not (args:get-arg "-use-db-cache"))
;; (begin
;; (debug:print-info 0 *default-log-port* "Forcing db-cache mode due to read-only access to megatest.db")
;; (hash-table-set! args:arg-hash "-use-db-cache" #t)));;;)
@@ -3360,11 +3360,11 @@
(begin
(debug:print 0 *default-log-port* "ERROR: I only know sqlite3 databases for now: " dbstr)
#f)))))
(if (and dbpth (file-read-access? dbpth))
(let ((db (sqlite3:open-database dbpth))) ;; (open-database dbpth)))
- (sqlite3:set-busy-handler! db (make-busy-timeout 10000))
+ (sqlite3:set-busy-handler! db (sqlite3:make-busy-timeout 10000))
db)
#f)))
;; sqlite3:path tablename timefieldname varfieldname field1 field2 ...
;;
Index: db.scm
==================================================================
--- db.scm
+++ db.scm
@@ -22,17 +22,36 @@
;; Database access
;;======================================================================
;; dbstruct vector containing all the relevant dbs like main.db, megatest.db, run.db etc
-(use (srfi 18) extras tcp stack)
-(use sqlite3 srfi-1 posix regex regex-case srfi-69 csv-xml s11n md5 message-digest base64 format dot-locking z3 typed-records matchable)
-(import (prefix sqlite3 sqlite3:))
-(import (prefix base64 base64:))
+(use (srfi 18)
+ extras
+ tcp
+ stack
+ (prefix sqlite3 sqlite3:)
+ srfi-1
+ posix
+ regex
+ regex-case
+ srfi-69
+ csv-xml
+ s11n
+ md5
+ message-digest
+ (prefix base64 base64:)
+ format
+ dot-locking
+ z3
+ typed-records
+ matchable)
(declare (unit db))
(declare (uses common))
+(declare (uses dbmod))
+;; (declare (uses debugprint))
+(declare (uses dbfile))
(declare (uses keys))
(declare (uses ods))
(declare (uses client))
(declare (uses mt))
@@ -42,44 +61,21 @@
(include "run_records.scm")
(define *number-of-writes* 0)
(define *number-non-write-queries* 0)
-;;======================================================================
-;; R E C O R D S
-;;======================================================================
-
-;; each db entry is a pair ( db . dbfilepath )
-;; I propose this record evolves into the area record
-;;
-(defstruct dbr:dbstruct
- (tmpdb #f)
- (dbstack #f) ;; stack for tmp db handles, do not initialize with a stack
- (mtdb #f)
- (refndb #f)
- (homehost #f) ;; not used yet
- (on-homehost #f) ;; not used yet
- (read-only #f)
- (stmt-cache (make-hash-table))
- ) ;; goal is to converge on one struct for an area but for now it is too confusing
-
+(import dbmod)
+(import dbfile)
;; record for keeping state,status and count for doing roll-ups in
;; iterated tests
;;
(defstruct dbr:counts
(state #f)
(status #f)
(count 0))
-;;======================================================================
-;; alist-of-alists
-;;======================================================================
-;;
-;; (define (db:aa-set! dat key1 key2 val)
-;; (let loop ((
-
;;======================================================================
;; hash of hashs
;;======================================================================
@@ -94,13 +90,14 @@
(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))))
-(define (db:get-cache-stmth dbstruct db stmt)
- (let* ((stmt-cache (dbr:dbstruct-stmt-cache dbstruct))
- (stmth (db:hoh-get stmt-cache db stmt)))
+(define (db:get-cache-stmth dbdat run-id db stmt)
+ (let* (;; (dbdat (dbfile:get-dbdat dbstruct run-id))
+ (stmt-cache (dbr:dbdat-stmt-cache dbdat))
+ (stmth (db:hoh-get stmt-cache db stmt)))
(or stmth
(let* ((newstmth (sqlite3:prepare db stmt)))
(db:hoh-set! stmt-cache db stmt newstmth)
newstmth))))
@@ -127,108 +124,128 @@
(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: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:setup do-sync)
+ (assert *toppath* "FATAL: db:setup called before launch:setup has been run.")
+ (let* ((tmpdir (common:get-db-tmp-area)))
+ (dbfile:setup do-sync *toppath* tmpdir)))
+
+;; 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 inmem
;; if db not open, open inmem, rundb and sync then return inmem
;; inuse gets set automatically for rundb's
;;
-(define (db:get-db dbstruct) ;; run-id)
- (if (stack? (dbr:dbstruct-dbstack dbstruct))
- (if (stack-empty? (dbr:dbstruct-dbstack dbstruct))
- (let ((newdb (db:open-megatest-db path: (db:dbfile-path))))
- ;; (stack-push! (dbr:dbstruct-dbstack dbstruct) newdb)
- newdb)
- (stack-pop! (dbr:dbstruct-dbstack dbstruct)))
- (db:open-db dbstruct)))
-
-;; ;; legacy handling of structure for managing db's. Refactor this into dbr:?
-(define (db:dbdat-get-db dbdat)
- (if (pair? dbdat)
- (car dbdat)
- dbdat))
-
-(define (db:dbdat-get-path dbdat)
- (if (pair? dbdat)
- (cdr dbdat)
- #f))
+;; (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:open-db dbstruct run-id)
+ (let* ((dbdat (dbfile:open-db dbstruct run-id db:initialize-main-db)))
+ (set! *db-write-access* (not (dbr:dbdat-read-only dbdat)))
+ dbdat))
;; (db:with-db dbstruct run-id sqlite3:exec "select blah fgrom blaz;")
;; r/w is a flag to indicate if the db is modified by this query #t = yes, #f = no
;;
(define (db:with-db dbstruct run-id r/w proc . params)
(let* ((have-struct (dbr:dbstruct? dbstruct))
- (dbdat (if have-struct
- (db:get-db dbstruct)
+ (dbdat (if have-struct ;; this stuff just allows us to call with a db handle directly
+ (db:open-db dbstruct run-id) ;; (dbfile:get-subdb dbstruct run-id)
#f))
- (db (if have-struct
- (db:dbdat-get-db dbdat)
+ (db (if have-struct ;; this stuff just allows us to call with a db handle directly
+ (dbr:dbdat-dbh dbdat)
dbstruct))
- (fname (db:dbdat-get-path dbdat))
+ (fname (if dbdat
+ (dbr:dbdat-dbfile dbdat)
+ "nofilenameavailable"))
+ (subdb (if have-struct
+ (dbfile:get-subdb dbstruct run-id)
+ #f))
(use-mutex (> *api-process-request-count* 25))) ;; was 25
(if (and use-mutex
(common:low-noise-print 120 "over-50-parallel-api-requests"))
(debug:print-info 0 *default-log-port* *api-process-request-count* " parallel api requests being processed in process " (current-process-id) ", throttling access"))
(if (common:low-noise-print 600 (conc "parallel-api-requests" *max-api-process-requests*))
(debug:print-info 2 *default-log-port* "Parallel api request count: " *api-process-request-count* " max parallel requests: " *max-api-process-requests*))
(condition-case
- (begin
- (if use-mutex (mutex-lock! *db-with-db-mutex*))
- (let ((res (apply proc db params)))
- (if use-mutex (mutex-unlock! *db-with-db-mutex*))
- ;; (if (vector? dbstruct)(db:done-with dbstruct run-id r/w))
- (if dbdat (stack-push! (dbr:dbstruct-dbstack dbstruct) dbdat))
- res))
- (exn (io-error)
- (db:generic-error-printout exn "ERROR: i/o error with " fname ". Check permissions, disk space etc. and try again."))
- (exn (corrupt)
- (db:generic-error-printout exn "ERROR: database " fname " is corrupt. Repair it to proceed."))
- (exn (busy)
- (db:generic-error-printout exn "ERROR: database " fname
- " is locked. Try copying to another location, remove original and copy back."))
- (exn (permission)(db:generic-error-printout exn "ERROR: database " fname " has some permissions problem."))
- (exn ()
- (db:generic-error-printout exn "ERROR: Unknown error with database " fname " message: "
- ((condition-property-accessor 'exn 'message) exn))))))
-
-;;======================================================================
-;; K E E P F I L E D B I N dbstruct
-;;======================================================================
-
-;; (define (db:get-filedb dbstruct run-id)
-;; (let ((db (vector-ref dbstruct 2)))
-;; (if db
-;; db
-;; (let ((fdb (filedb:open-db (conc *toplevel* "/db/files.db"))))
-;; (vector-set! dbstruct 2 fdb)
-;; fdb))))
-;;
-;; ;; Can also be used to save arbitrary strings
-;; ;;
-;; (define (db:save-path dbstruct path)
-;; (let ((fdb (db:get-filedb dbstruct)))b
-;; (filedb:register-path fdb path)))
-;;
-;; ;; Use to get a path. To get an arbitrary string see next define
-;; ;;
-;; (define (db:get-path dbstruct id)
-;; (let ((fdb (db:get-filedb dbstruct)))
-;; (filedb:get-path db id)))
+ (begin
+ (if use-mutex (mutex-lock! *db-with-db-mutex*))
+ (let ((res (apply proc dbdat db params)))
+ (if use-mutex (mutex-unlock! *db-with-db-mutex*))
+ ;; (if (vector? dbstruct)(db:done-with dbstruct run-id r/w))
+ (if dbdat (stack-push! (dbr:subdb-dbstack subdb) dbdat))
+ res))
+ (exn (io-error)
+ (db:generic-error-printout exn "ERROR: i/o error with " fname ". Check permissions, disk space etc. and try again."))
+ (exn (corrupt)
+ (db:generic-error-printout exn "ERROR: database " fname " is corrupt. Repair it to proceed."))
+ (exn (busy)
+ (db:generic-error-printout exn "ERROR: database " fname
+ " is locked. Try copying to another location, remove original and copy back."))
+ (exn (permission)(db:generic-error-printout exn "ERROR: database " fname " has some permissions problem."))
+ (exn ()
+ (db:generic-error-printout exn "ERROR: Unknown error with database " fname " message: "
+ ((condition-property-accessor 'exn 'message) exn))))))
+
;; NB// #f => return dbdir only
;; (was planned to be; zeroth db with name=main.db)
;;
;; If run-id is #f return to create and retrieve the path where the db will live.
@@ -242,12 +259,12 @@
;; open an sql database inside a file lock
;; returns: db existed-prior-to-opening
;; RA => Returns a db handler; sets the lock if opened in writable mode
;;
;; (define *db-open-mutex* (make-mutex))
-
-(define (db:lock-create-open fname initproc)
+;;
+#;(define (db:lock-create-open fname initproc)
(let* ((parent-dir (or (pathname-directory fname)(current-directory))) ;; no parent? go local
(raw-fname (pathname-file fname))
(dir-writable (file-write-access? parent-dir))
(file-exists (common:file-exists? fname))
(file-write (if file-exists
@@ -312,182 +329,136 @@
(exn (busy) (debug:print 0 *default-log-port* "ERROR: database " fname " is locked. Try copying to another location, remove original and copy back."))
(exn (permission)(debug:print 0 *default-log-port* "ERROR: database " fname " has some permissions problem."))
(exn () (debug:print 0 *default-log-port* "ERROR: Unknown error with database " fname " message: " ((condition-property-accessor 'exn 'message) exn))))
)))
-
;; This routine creates the db if not already present. It is only called if the db is not already opened
;;
-(define (db:open-db dbstruct #!key (areapath #f)(do-sync #t)) ;; TODO: actually use areapath
- (let ((tmpdb-stack (dbr:dbstruct-dbstack dbstruct))) ;; RA => Returns the first reference in dbstruct
+#;(define (db:open-db dbstruct run-id #!key (areapath #f)(do-sync #t))
+ (let* ((subdb (dbfile:get-subdb dbstruct run-id))
+ (tmpdb-stack (dbr:subdb-dbstack subdb)))
(if (stack? tmpdb-stack)
- (db:get-db tmpdb-stack) ;; get previously opened db (will create new db handle if all in the stack are already used
+ (db:get-subdb tmpdb-stack run-id) ;; get previously opened db (will create new db handle if all in the stack are already used
(let* ((max-stale-tmp (configf:lookup-number *configdat* "server" "filling-db-max-stale-seconds" default: 10))
- (dbpath (db:dbfile-path )) ;; path to tmp db area
+ (dbpath (db:dbfile-path)) ;; path to tmp db area
+ (dbname (db:run-id->dbname run-id))
(dbexists (common:file-exists? dbpath))
- (tmpdbfname (conc dbpath "/megatest.db"))
+ (mtdbfname (conc *toppath* "/"dbname))
+ (mtdbexists (common:file-exists? mtdbfname))
+ (mtdbmodtime (if mtdbexists (common:lazy-sqlite-db-modification-time mtdbfname) #f))
+ (mtdb (db:open-megatest-db mtdbfname))
+ ;; the reference db for syncing
+ (refdbfname (conc dbpath "/"dbname"_ref"))
+ (refndb (db:open-megatest-db refdbfname))
+ ;; (mtdbpath (dbr:dbdat-dbfile mtdb))
+ ;; the tmpdb
+ (tmpdbfname (conc dbpath"/"dbname)) ;; /tmp//.db/[main|1,2...].db
+ (tmpdb (db:open-megatest-db tmpdbfname)) ;; lock-create-open dbpath db:initialize-main-db))
(dbfexists (common:file-exists? tmpdbfname)) ;; (conc dbpath "/megatest.db")))
- (mtdbexists (common:file-exists? (conc *toppath* "/megatest.db")))
-
- (mtdbmodtime (if mtdbexists (common:lazy-sqlite-db-modification-time (conc *toppath* "/megatest.db")) #f))
- (tmpdbmodtime (if dbfexists (common:lazy-sqlite-db-modification-time tmpdbfname) #f))
- (mtdb (db:open-megatest-db))
- (mtdbpath (db:dbdat-get-path mtdb))
- (tmpdb (db:open-megatest-db path: dbpath)) ;; lock-create-open dbpath db:initialize-main-db))
- (refndb (db:open-megatest-db path: dbpath name: "megatest_ref.db"))
- (write-access (file-write-access? mtdbpath))
- ;(mtdbmodtime (if mtdbexists (common:lazy-sqlite-db-modification-time mtdbpath) #f)) ; moving this before db:open-megatest-db is called. if wal mode is on -WAL and -shm file get created with causing the tmpdbmodtime timestamp always greater than mtdbmodtime
- ;(tmpdbmodtime (if dbfexists (common:lazy-sqlite-db-modification-time tmpdbfname) #f))
- ;if wal mode is on -WAL and -shm file get created when db:open-megatest-db is called. modtimedelta will always be < 10 so db in tmp not get synced
- ;(tmpdbmodtime (if dbfexists (db:get-last-update-time (car tmpdb)) #f))
- ;(fmt (file-modification-time tmpdbfname))
+ (tmpdbmodtime (if dbfexists (common:lazy-sqlite-db-modification-time tmpdbfname) #f))
+
+ (write-access (file-write-access? mtdbfname))
+
+ ;; (mtdbmodtime (if mtdbexists
+ ;; (common:lazy-sqlite-db-modification-time mtdbpath)
+ ;; #f)) ; moving this before db:open-megatest-db is
+ ;; called. if wal mode is on -WAL and -shm file get
+ ;; created with causing the tmpdbmodtime timestamp
+ ;; always greater than mtdbmodtime (tmpdbmodtime (if
+ ;; dbfexists (common:lazy-sqlite-db-modification-time
+ ;; tmpdbfname) #f)) if wal mode is on -WAL and -shm
+ ;; file get created when db:open-megatest-db is
+ ;; called. modtimedelta will always be < 10 so db in
+ ;; tmp not get synced (tmpdbmodtime (if dbfexists
+ ;; (db:get-last-update-time (car tmpdb)) #f)) (fmt
+ ;; (file-modification-time tmpdbfname))
+
(modtimedelta (and mtdbmodtime tmpdbmodtime (- mtdbmodtime tmpdbmodtime))))
(when write-access
- (sqlite3:execute (car mtdb) "drop trigger if exists update_tests_trigger")
- (sqlite3:execute (car mtdb) "drop trigger if exists update_runs_trigger"))
+ (sqlite3:execute (dbr:dbdat-dbh mtdb) "drop trigger if exists update_tests_trigger")
+ (sqlite3:execute (dbr:dbdat-dbh mtdb) "drop trigger if exists update_runs_trigger"))
- ;(print "mtdbmodtime " mtdbmodtime " tmpdbmodtime " tmpdbmodtime " mtdbpath " mtdbpath " " (conc *toppath* "/megatest.db"))
- ;;(debug:print-info 13 *default-log-port* "db:open-db>> mtdbpath="mtdbpath" mtdbexists="mtdbexists" and write-access="write-access)
+ ;; (print "mtdbmodtime " mtdbmodtime " tmpdbmodtime " tmpdbmodtime " mtdbpath " mtdbpath " " (conc *toppath* "/megatest.db"))
+ ;; (debug:print-info 13 *default-log-port* "db:open-db>> mtdbpath="mtdbpath" mtdbexists="mtdbexists" and write-access="write-access)
(if (and dbexists (not write-access))
(begin
(set! *db-write-access* #f)
- (dbr:dbstruct-read-only-set! dbstruct #t)))
- (dbr:dbstruct-mtdb-set! dbstruct mtdb)
- (dbr:dbstruct-tmpdb-set! dbstruct tmpdb)
- (dbr:dbstruct-dbstack-set! dbstruct (make-stack)) ;; BB: why a stack? Why would the number of db's be indeterminate? Is this a legacy of 1.db 2.db .. ?
- (stack-push! (dbr:dbstruct-dbstack dbstruct) tmpdb) ;; olddb is already a (cons db path)
- (dbr:dbstruct-refndb-set! dbstruct refndb)
+ (dbr:subdb-read-only-set! subdb #t)))
+ (dbr:subdb-mtdb-set! subdb mtdb)
+ (dbr:subdb-tmpdb-set! subdb tmpdb)
+ (dbr:subdb-dbstack-set! subdb (make-stack)) ;; BB: why a stack? Why would the number of db's be indeterminate? Is this a legacy of 1.db 2.db .. ?
+ (stack-push! (dbr:subdb-dbstack subdb) tmpdb) ;; olddb is already a (cons db path)
+ (dbr:subdb-refndb-set! subdb refndb)
(if (and (or (not dbfexists)
(and modtimedelta
(> modtimedelta max-stale-tmp))) ;; if db in tmp is over ten seconds older than the file in MTRA then do a sync back
do-sync)
(begin
- (debug:print 1 *default-log-port* "filling db " (db:dbdat-get-path tmpdb) " with data \n from " (db:dbdat-get-path mtdb) " mod time delta: " modtimedelta)
- (db:sync-tables (db:sync-all-tables-list dbstruct) #f mtdb refndb tmpdb)
- ;touch tmp db to avoid wal mode wierdness
- (set! (file-modification-time tmpdbfname) (current-seconds))
+ (debug:print 1 *default-log-port* "filling db " (dbr:dbdat-dbfile tmpdb) " with data \n from " (dbr:dbdat-dbfile mtdb) " mod time delta: " modtimedelta)
+ (db:sync-tables (db:sync-all-tables-list subdb) #f mtdb refndb tmpdb)
+ ;; touch tmp db to avoid wal mode wierdness
+ (set! (file-modification-time tmpdbfname) (current-seconds))
(debug:print-info 13 *default-log-port* "db:sync-all-tables-list done.")
)
- (debug:print 4 *default-log-port* " db, " (db:dbdat-get-path tmpdb) " already exists or fresh enough, not propogating data from\n " (db:dbdat-get-path mtdb) " mod time delta: " modtimedelta) )
- ;; (db:multi-db-sync dbstruct 'old2new)) ;; migrate data from megatest.db automatically
+ (debug:print 4 *default-log-port* " db, " (dbr:dbdat-dbfile tmpdb) " already exists or fresh enough, not propogating data from\n " (dbr:dbdat-dbfile mtdb) " mod time delta: " modtimedelta) )
+ ;; (db:multi-db-sync subdb 'old2new)) ;; migrate data from megatest.db automatically
tmpdb))))
(define (db:get-last-update-time db)
-; (db:with-db
-; dbstruct #f #f
-; (lambda (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))
-;))
-
-;; Make the dbstruct, setup up auxillary db's and call for main db at least once
-;;
-;; called in http-transport and replicated in rmt.scm for *local* access.
-;;
-(define (db:setup do-sync #!key (areapath #f))
- ;;
- (cond
- (*dbstruct-db* *dbstruct-db*);; TODO: when multiple areas are supported, this optimization will be a hazard
- (else ;;(common:on-homehost?)
- (debug:print-info 13 *default-log-port* "db:setup entered (first time, not cached.)")
- (let* ((dbstruct (make-dbr:dbstruct)))
- (when (not *toppath*)
- (debug:print-info 13 *default-log-port* "in db:setup, *toppath* not set; calling launch:setup")
- (launch:setup areapath: areapath))
- (debug:print-info 13 *default-log-port* "Begin db:open-db")
- (db:open-db dbstruct areapath: areapath do-sync: do-sync)
- (debug:print-info 13 *default-log-port* "Done db:open-db")
- (set! *dbstruct-db* dbstruct)
- ;;(debug:print-info 13 *default-log-port* "new dbstruct = "(dbr:dbstruct->alist dbstruct))
- dbstruct))))
- ;; (else
- ;; (debug:print 0 *default-log-port* "ERROR: attempt to open database when not on homehost. Exiting. Homehost: " (common:get-homehost))
- ;; (exit 1))))
+ (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:reopen-megatest-db
-
-(define (db:open-megatest-db #!key (path #f)(name #f))
- (let* ((dbdir (or path *toppath*))
- (dbpath (conc dbdir "/" (or name "megatest.db")))
- (dbexists (common:file-exists? dbpath))
+(define (db:open-megatest-db dbpath)
+ (let* ((dbexists (file-exists? dbpath))
(db (db:lock-create-open dbpath
(lambda (db)
- (db:initialize-main-db db)
- ;;(db:initialize-run-id-db 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)))
+ ;; (cons db dbpath)))
+ (make-dbr:dbdat dbfile: dbpath dbh: db read-only: (not write-access))))
;; sync run to disk if touched
;;
(define (db:sync-touched dbstruct run-id #!key (force-sync #f))
- (let ((tmpdb (db:get-db dbstruct))
- (mtdb (dbr:dbstruct-mtdb dbstruct))
- (refndb (dbr:dbstruct-refndb dbstruct))
- (start-t (current-seconds)))
+ (let* ((subdb (dbfile:get-subdb dbstruct run-id))
+ (tmpsubdb (dbfile:get-subdb dbstruct run-id))
+ (tmpdbfile (dbr:subdb-tmpdbfile tmpsubdb))
+ (mtdb (dbr:subdb-mtdbdat subdb))
+ (tmpdb (dbfile:open-sqlite3-db tmpdbfile #f))
+
+ ;; (refndb (dbr:subdb-refndb subdb))
+ (start-t (current-seconds)))
(debug:print-info 4 *default-log-port* "Syncing for run-id: " run-id)
(mutex-lock! *db-multi-sync-mutex*)
- (let ((update_info (cons (if force-sync 0 *db-last-sync*) "last_update")))
+ (let ((update_info (cons "last_update" (if force-sync 0 *db-last-sync*) )))
(mutex-unlock! *db-multi-sync-mutex*)
- (db:sync-tables (db:sync-all-tables-list dbstruct) update_info tmpdb refndb mtdb))
+ (db:sync-tables (db:sync-all-tables-list dbstruct) update_info tmpdb mtdb))
(mutex-lock! *db-multi-sync-mutex*)
(set! *db-last-sync* start-t)
(set! *db-last-access* start-t)
(mutex-unlock! *db-multi-sync-mutex*)
- (stack-push! (dbr:dbstruct-dbstack dbstruct) tmpdb)))
-
-(define (db:safely-close-sqlite3-db db stmt-cache #!key (try-num 3))
- (if (<= try-num 0)
- #f
- (handle-exceptions
- exn
- (begin
- (print "Attempt to safely close sqlite3 db failed. Trying again. exn=" exn)
- (thread-sleep! 3)
- (sqlite3:interrupt! db)
- (db:safely-close-sqlite3-db db stmt-cache try-num: (- try-num 1)))
- (if (sqlite3:database? db)
- (let* ((stmts (and stmt-cache (hash-table-ref/default stmt-cache db #f))))
- (if stmts (map sqlite3:finalize! (hash-table-values stmts)))
- (sqlite3:finalize! db)
- #t)
- #f))))
-
-;; close all opened run-id dbs
-(define (db:close-all dbstruct)
- (if (dbr:dbstruct? dbstruct)
- (handle-exceptions
- exn
- (begin
- (debug:print 0 *default-log-port* "WARNING: Finalizing failed, " ((condition-property-accessor 'exn 'message) exn) ", note - exn=" exn)
- (print-call-chain *default-log-port*))
- ;; (db:sync-touched dbstruct 0 force-sync: #t) ;; NO. Do not do this here. Instead we rely on a server to be started when there are writes, even if the server itself is not going to be used as a server.
- (let ((tdbs (map db:dbdat-get-db
- (stack->list (dbr:dbstruct-dbstack dbstruct))))
- (mdb (db:dbdat-get-db (dbr:dbstruct-mtdb dbstruct)))
- (rdb (db:dbdat-get-db (dbr:dbstruct-refndb dbstruct)))
- (stmt-cache (dbr:dbstruct-stmt-cache dbstruct)))
- (map (lambda (db)
- (db:safely-close-sqlite3-db db stmt-cache))
- tdbs)
- (db:safely-close-sqlite3-db mdb stmt-cache) ;; (if (sqlite3:database? mdb) (sqlite3:finalize! mdb))
- (db:safely-close-sqlite3-db rdb stmt-cache))))) ;; (if (sqlite3:database? rdb) (sqlite3:finalize! rdb))))))
+ (stack-push! (dbr:subdb-dbstack subdb) tmpdb))
+ #t
+)
+
+
+;; db:safely-close-sqlite3-db and db:close-all were here, moved to dbfile
;; (let ((locdbs (dbr:dbstruct-locdbs dbstruct)))
;; (if (hash-table? locdbs)
;; (for-each (lambda (run-id)
;; (db:close-run-db dbstruct run-id))
@@ -601,11 +572,11 @@
db:sync-tests-only))
;; use bunch of Unix commands to try to break the lock and recreate the db
;;
(define (db:move-and-recreate-db dbdat)
- (let* ((dbpath (db:dbdat-get-path dbdat))
+ (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))))
@@ -622,11 +593,11 @@
;; return #f to indicate the dbdat should be closed/reopened
;; else return dbdat
;;
(define (db:repair-db dbdat #!key (numtries 1))
- (let* ((dbpath (db:dbdat-get-path dbdat))
+ (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))
@@ -691,49 +662,52 @@
(debug:print 0 *default-log-port* "EXCEPTION: database probably overloaded or unreadable in db:sync-tables.")
(print-call-chain (current-error-port))
(debug:print 0 *default-log-port* " message: " ((condition-property-accessor 'exn 'message) exn))
(debug:print 5 *default-log-port* "exn=" (condition->list exn))
(debug:print 0 *default-log-port* " status: " ((condition-property-accessor 'sqlite3 'status) exn))
- (debug:print 0 *default-log-port* " src db: " (db:dbdat-get-path fromdb))
+ (debug:print 0 *default-log-port* " src db: " (dbr:dbdat-dbfile fromdb))
(for-each (lambda (dbdat)
- (let ((dbpath (db:dbdat-get-path dbdat)))
+ (let ((dbpath (dbr:dbdat-dbfile dbdat)))
(debug:print 0 *default-log-port* " dbpath: " dbpath)
(if (not (db:repair-db dbdat))
(begin
(debug:print-error 0 *default-log-port* "Failed to rebuild " dbpath ", exiting now.")
(exit)))))
(cons todb slave-dbs))
0)
- ;; this is the work to be done
+
+ ;; this is the work to be done")
(cond
((not fromdb) (debug:print 3 *default-log-port* "WARNING: db:sync-tables called with fromdb missing")
-1)
((not todb) (debug:print 3 *default-log-port* "WARNING: db:sync-tables called with todb missing")
-2)
- ((not (sqlite3:database? (db:dbdat-get-db fromdb)))
+ ((not (sqlite3:database? (dbr:dbdat-dbh fromdb)))
(debug:print-error 0 *default-log-port* "db:sync-tables called with fromdb not a database " fromdb)
- -3)
- ((not (sqlite3:database? (db:dbdat-get-db todb)))
+ -3)
+ ((not (sqlite3:database? (dbr:dbdat-dbh todb)))
(debug:print-error 0 *default-log-port* "db:sync-tables called with todb not a database " todb)
- -4)
+ -4)
- ((not (file-write-access? (db:dbdat-get-path todb)))
+ ((not (file-write-access? (dbr:dbdat-dbfile todb)))
(debug:print-error 0 *default-log-port* "db:sync-tables called with todb not a read-only database " todb)
-5)
((not (null? (let ((readonly-slave-dbs
(filter
(lambda (dbdat)
- (not (file-write-access? (db:dbdat-get-path todb))))
+ (not (file-write-access? (dbr:dbdat-dbfile todb))))
slave-dbs)))
(for-each
(lambda (bad-dbdat)
(debug:print-error
0 *default-log-port* "db:sync-tables called with todb not a read-only database " bad-dbdat))
readonly-slave-dbs)
readonly-slave-dbs))) -6)
(else
+ (debug:print 3 *default-log-port* "db:sync-tables: args are good")
+
(let ((stmts (make-hash-table)) ;; table-field => stmt
(all-stmts '()) ;; ( ( stmt1 value1 ) ( stml2 value2 ))
(numrecs (make-hash-table))
(start-time (current-milliseconds))
(tot-count 0))
@@ -749,11 +723,11 @@
((number? last-update) #f) ;; if not matched first entry then ignore last-update for this table
((and (pair? last-update)
(member (car last-update) ;; last-update field name
(map car fields)))
#t)
- (last-update
+ ((and last-update (not (pair? last-update)) (not (number? last-update)))
(debug:print 0 *default-log-port* "ERROR: parameter last-update for db:sync-tables must be a pair or a number, received: " last-update);; found in fields
#f)
(else
#f)))
(last-update-value (if use-last-update ;; no need to check for has-last-update - it is already accounted for
@@ -791,56 +765,68 @@
(lambda (field)
(hash-table-set! field->num field count)
(set! count (+ count 1)))
fields)
+ (debug:print 3 *default-log-port* "fromdat: " fromdat)
+
;; read the source table
+ ;; store a list of all rows in the table in fromdat, up to batch-len.
+ ;; Then add fromdat to the fromdats list, clear fromdat and repeat.
(sqlite3:for-each-row
(lambda (a . b)
(set! fromdat (cons (apply vector a b) fromdat))
(if (> (length fromdat) batch-len)
(begin
(set! fromdats (cons fromdat fromdats))
(set! fromdat '())
- (set! totrecords (+ totrecords 1)))))
- (db:dbdat-get-db fromdb)
+ (set! totrecords (+ totrecords 1)))
+ )
+ )
+ (dbr:dbdat-dbh fromdb)
full-sel)
-
+
+ ;; Count less than batch-len as a record
+ (if (> (length fromdat) 0)
+ (set! totrecords (+ totrecords 1)))
+
;; tack on remaining records in fromdat
(if (not (null? fromdat))
(set! fromdats (cons fromdat fromdats)))
(if (common:low-noise-print 120 "sync-records")
- (debug:print-info 4 *default-log-port* "found " totrecords " records to sync"))
+ (debug:print 4 *default-log-port* "found " totrecords " records to sync"))
- ;; read the target table; BBHERE
(sqlite3:for-each-row
(lambda (a . b)
(hash-table-set! todat a (apply vector a b)))
- (db:dbdat-get-db todb)
+ (dbr:dbdat-dbh todb)
full-sel)
(when (and delay-handicap (> delay-handicap 0))
(debug:print-info 0 *default-log-port* "imposing synthetic sync delay of "delay-handicap" seconds since sync/delay-handicap is configured")
(thread-sleep! delay-handicap)
(debug:print-info 0 *default-log-port* "synthetic sync delay of "delay-handicap" seconds completed")
)
;; first pass implementation, just insert all changed rows
+
(for-each
(lambda (targdb)
- (let* ((db (db:dbdat-get-db targdb))
+ (let* ((db (dbr:dbdat-dbh targdb))
(drp-trigger (if (member "last_update" field-names)
(db:drop-trigger db tablename)
#f))
(is-trigger-dropped (if (member "last_update" field-names)
(db:is-trigger-dropped db tablename)
#f))
- (stmth (sqlite3:prepare db full-ins)))
+ (stmth (sqlite3:prepare db full-ins))
+ (changed-rows 0))
;; (db:delay-if-busy targdb) ;; NO WAITING
(if (member "last_update" field-names)
(debug:print-info 3 *default-log-port* "is-trigger-dropped: " is-trigger-dropped))
+
(for-each
(lambda (fromdat-lst)
(sqlite3:with-transaction
db
(lambda ()
@@ -857,17 +843,29 @@
(< i (- num-fields 1)))
(loop (+ i 1))))
(if (not same)
(begin
(apply sqlite3:execute stmth (vector->list fromrow))
- (hash-table-set! numrecs tablename (+ 1 (hash-table-ref/default numrecs tablename 0)))))))
+ (hash-table-set! numrecs tablename (+ 1 (hash-table-ref/default numrecs tablename 0)))
+ (set! changed-rows (+ changed-rows 1))
+ )
+ )
+ ))
fromdat-lst))))
fromdats)
+
+
+ (debug:print 3 *default-log-port* "changed rows: " changed-rows)
+
+
(sqlite3:finalize! stmth)
(if (member "last_update" field-names)
(db:create-trigger db tablename))))
- (append (list todb) slave-dbs))))
+ (append (list todb) slave-dbs)
+ )
+ )
+ )
tbls)
(let* ((runtime (- (current-milliseconds) start-time))
(should-print (or (debug:debug-mode 12)
(common:low-noise-print 120 "db sync" (> runtime 500))))) ;; low and high sync times treated as separate.
(if should-print (debug:print 3 *default-log-port* "INFO: db sync, total run time " runtime " ms"))
@@ -1051,10 +1049,35 @@
;; (conc cache-dir "/" fname)
;; use-last-update: #t)))
;; (thread-start! th1)
;; (apply proc cache-db params)
;; ))))
+
+
+
+
+;; Get a lock from the no-sync-db for the from-db, then delta sync the from-db to the to-db, otherwise return #f
+
+(define (db:lock-and-delta-sync no-sync-db from-db-file to-db-file)
+ (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
+ (debug:print 0 *default-log-port* "db:lock-and-sync copying db")
+ ;; (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
+ ))))
+
+
+
+
;; options:
;;
;; 'killservers - kills all servers
;; 'dejunk - removes junk records
@@ -1064,87 +1087,147 @@
;; 'closeall - close all opened dbs
;; 'schema - attempt to apply schema changes
;; run-ids: '(1 2 3 ...) or #f (for all)
;;
(define (db:multi-db-sync dbstruct . options)
- ;; (if (not (launch:setup))
- ;; (debug:print 0 *default-log-port* "ERROR: not able to setup up for megatest.")
- (let* ((mtdb (dbr:dbstruct-mtdb dbstruct))
- (tmpdb (db:get-db dbstruct))
- (refndb (dbr:dbstruct-refndb dbstruct))
- (allow-cleanup #t) ;; (if run-ids #f #t))
- (servers (server:get-list *toppath*)) ;; (tasks:get-all-servers (db:delay-if-busy tdbdat)))
- (data-synced 0)) ;; count of changed records (I hope)
-
- (for-each
- (lambda (option)
-
- (case option
- ;; kill servers
- ((killservers)
- (for-each
- (lambda (server)
- (handle-exceptions
- exn
- (begin
- (debug:print-info 0 *default-log-port* "Unable to get host and/or port from " server ", exn=" exn)
- #f)
- (match-let (((mod-time host port start-time server-id pid) server))
- (if (and host pid)
- (tasks:kill-server host pid)))))
- servers)
-
- ;; /tmp/bjbarcla/megatest_localdb/fullrun/.nfs.pdx.disks.icf_env_disk001.bjbarcla.gwa.issues.mtdev.matt-bisect.megatest.ext-tests.runs.all.v1.65.1.6524.dev.bb-24-justrollup-f8.rollup.fullrun/megatest.db.lock
- (delete-file* (common:get-sync-lock-filepath))
- )
-
- ;; clear out junk records
- ;;
- ((dejunk)
- ;; (db:delay-if-busy mtdb) ;; ok to delay on mtdb
- (when (file-write-access? (db:dbdat-get-path mtdb)) (db:clean-up mtdb))
- (db:clean-up tmpdb)
- (db:clean-up refndb))
-
- ;; sync runs, test_meta etc.
- ;;
- ((old2new)
- (set! data-synced
- (+ (db:sync-tables (db:sync-all-tables-list dbstruct) #f mtdb tmpdb refndb)
- data-synced)))
-
- ;; now ensure all newdb data are synced to megatest.db
- ;; do not use the run-ids list passed in to the function
- ;;
- ((new2old)
- (set! data-synced
- (+ (db:sync-tables (db:sync-all-tables-list dbstruct) #f tmpdb refndb mtdb)
- data-synced)))
-
- ((adj-target)
- (db:adj-target (db:dbdat-get-db mtdb))
- (db:adj-target (db:dbdat-get-db tmpdb))
- (db:adj-target (db:dbdat-get-db refndb)))
-
- ((schema)
- (db:patch-schema-maindb (db:dbdat-get-db mtdb))
- (db:patch-schema-maindb (db:dbdat-get-db tmpdb))
- (db:patch-schema-maindb (db:dbdat-get-db refndb))
- (db:patch-schema-rundb (db:dbdat-get-db mtdb))
- (db:patch-schema-rundb (db:dbdat-get-db tmpdb))
- (db:patch-schema-rundb (db:dbdat-get-db refndb))))
-
- (stack-push! (dbr:dbstruct-dbstack dbstruct) tmpdb))
- options)
- data-synced))
-
-(define (db:tmp->megatest.db-sync dbstruct last-update)
- (let* ((mtdb (dbr:dbstruct-mtdb dbstruct))
- (tmpdb (db:get-db dbstruct))
- (refndb (dbr:dbstruct-refndb dbstruct))
- (res (db:sync-tables (db:sync-all-tables-list dbstruct) last-update tmpdb refndb mtdb)))
- (stack-push! (dbr:dbstruct-dbstack dbstruct) tmpdb)
+ (db:open-db dbstruct #f)
+
+ (let* ((data-synced 0) ;; count of changed records
+ (tmp-area (common:get-db-tmp-area))
+ (dbfiles (glob (conc tmp-area"/.db/*.db")))
+ (sync-durations (make-hash-table))
+ )
+
+ (for-each
+ (lambda (file)
+ (debug:print-info 0 *default-log-port* "file: " file)
+ (let* ((fname (conc (pathname-file file) ".db"))
+ (fulln (conc *toppath*"/.db/"fname))
+ (time1 (if (file-exists? file)
+ (file-modification-time file)
+ (begin
+ (debug:print-info 0 *default-log-port* "Sync - I do not see file "file)
+ 1)))
+ (time2 (if (file-exists? fulln)
+ (file-modification-time fulln)
+ (begin
+ (debug:print-info 0 *default-log-port* "Sync - I do not see file "fulln)
+ 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 sync
+ #t)
+ (else
+ #f))))
+ (if do-cp
+ (let* ((start-time (current-milliseconds)))
+ (debug:print-info 0 *default-log-port* "delta sync delta file: " fname", delta: " (- time1 time2) " seconds")
+ (db:lock-and-delta-sync *no-sync-db* file fulln)
+ (hash-table-set! sync-durations (conc fname".db") (- (current-milliseconds) start-time)))
+ (debug:print-info 0 *default-log-port* "skipping delta sync. " file " is up to date")
+ )
+ )
+ )
+ dbfiles
+ )
+
+
+ (hash-table->alist sync-durations)
+
+
+
+ (debug:print 0 *default-log-port* "db:multi-db-sync subdbs: " (hash-table-values (dbr:dbstruct-subdbs dbstruct)))
+ (for-each
+ (lambda (subdb)
+ (let* ((mtdb (dbr:subdb-mtdbdat subdb))
+ (tmpdbfile (dbr:subdb-tmpdbfile subdb))
+ (main-tmpdb (dbfile:open-db dbstruct #f db:initialize-main-db))
+ (allow-cleanup #t) ;; (if run-ids #f #t))
+ (servers (server:get-list *toppath*)) ;; (tasks:get-all-servers (db:delay-if-busy tdbdat)))
+ )
+ (debug:print 0 *default-log-port* "db:multi-db-sync mtdb: " mtdb " tmpdbfile:" tmpdbfile )
+ (for-each
+ (lambda (option)
+
+ (case option
+ ;; kill servers
+ ((killservers)
+ (for-each
+ (lambda (server)
+ (handle-exceptions
+ exn
+ (begin
+ (debug:print-info 0 *default-log-port* "Unable to get host and/or port from " server ", exn=" exn)
+ #f)
+ (match-let (((mod-time host port start-time server-id pid) server))
+ (if (and host pid)
+ (tasks:kill-server host pid)))))
+ servers)
+
+ ;; /tmp/bjbarcla/megatest_localdb/fullrun/.nfs.pdx.disks.icf_env_disk001.bjbarcla.gwa.issues.mtdev.matt-bisect.megatest.ext-tests.runs.all.v1.65.1.6524.dev.bb-24-justrollup-f8.rollup.fullrun/megatest.db.lock
+ (delete-file* (common:get-sync-lock-filepath)))
+
+ ;; clear out junk records
+ ;;
+ ((dejunk)
+ ;; (db:delay-if-busy mtdb) ;; ok to delay on mtdb
+ (when (file-write-access? (dbr:dbdat-dbfile mtdb)) (db:clean-up mtdb))
+ (db:clean-up main-tmpdb)
+ )
+ ;; sync from main dbs to /tmp ones.
+ ;;
+ ((old2new)
+ (set! data-synced
+ (+ (db:sync-tables (db:sync-all-tables-list dbstruct) #f mtdb main-tmpdb)
+ data-synced)))
+
+ ;; sync from /tmp dbs to main ones.
+ ;;
+ ((new2old)
+ (set! data-synced
+ (+ (db:sync-tables (db:sync-all-tables-list dbstruct) #f main-tmpdb mtdb)
+ data-synced)))
+
+ ((adj-target)
+ (db:adj-target (dbr:dbdat-dbh mtdb))
+ (db:adj-target (dbr:dbdat-dbh main-tmpdb))
+ )
+
+ ((schema)
+ (db:patch-schema-maindb (dbr:dbdat-dbh mtdb))
+ (db:patch-schema-maindb (dbr:dbdat-dbh main-tmpdb))
+ (db:patch-schema-rundb (dbr:dbdat-dbh mtdb))
+ (db:patch-schema-rundb (dbr:dbdat-dbh main-tmpdb))
+ )
+ )
+ (stack-push! (dbr:subdb-dbstack subdb) main-tmpdb))
+ options)))
+ (hash-table-values (dbr:dbstruct-subdbs dbstruct)))
+ 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* ((dbname (db:run-id->dbname run-id))
+ (mtdb (dbr:subdb-mtdb subdb))
+ (tmpdb (db:get-subdb dbstruct run-id))
+ (refndb (dbr:subdb-refndb subdb))
+ (newres (db:sync-tables (db:sync-all-tables-list dbstruct) last-update tmpdb refndb mtdb)))
+ (stack-push! (dbr:subdb-dbstack subdb) 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
@@ -1186,11 +1269,11 @@
(print "I don't work anymore. open-run-close-no-exception-handling needs fixing or removing...")
(exit)
(if (or *db-write-access*
(not #t)) ;; was: (member proc * db:all-write-procs *)))
(let* ((db (cond
- ((pair? idb) (db:dbdat-get-db idb))
+ ((pair? idb) (dbr:dbdat-dbh idb))
((sqlite3:database? idb) idb)
((not idb) (debug:print-error 0 *default-log-port* "cannot open-run-close with #f anymore"))
((procedure? idb) (idb))
(else (debug:print-error 0 *default-log-port* "cannot open-run-close with #f anymore"))))
(res #f))
@@ -1254,15 +1337,17 @@
FOR EACH ROW
BEGIN
UPDATE test_data SET last_update=(strftime('%s','now'))
WHERE id=old.id;
END;" )))
-
+;;
+;; ADD run-id SUPPORT
+;;
(define (db:create-all-triggers dbstruct)
(db:with-db
dbstruct #f #f
- (lambda (db)
+ (lambda (dbdat db)
(db:create-triggers db))))
(define (db:create-triggers db)
(for-each (lambda (key)
(sqlite3:execute db (cadr key)))
@@ -1269,11 +1354,11 @@
db:trigger-list))
(define (db:drop-all-triggers dbstruct)
(db:with-db
dbstruct #f #f
- (lambda (db)
+ (lambda (dbdat db)
(db:drop-triggers db))))
(define (db:is-trigger-dropped db tbl-name)
(let* ((trigger-name (if (equal? tbl-name "test_steps")
"update_teststeps_trigger"
@@ -1311,19 +1396,19 @@
(if (equal? (car key) trigger-name)
(sqlite3:execute db (cadr key))))
db:trigger-list)))
-(define (db:initialize-main-db dbdat)
+(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 (db:dbdat-get-db dbdat)))
+ #;(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"))
@@ -1539,11 +1624,10 @@
state TEXT DEFAULT 'new',
status TEXT DEFAULT 'n/a',
archive_type TEXT DEFAULT 'bup',
du INTEGER,
archive_path TEXT);")))
- (print "creating triggers from init")
(db:create-triggers db)
db)) ;; )
;;======================================================================
;; A R C H I V E S
@@ -1552,12 +1636,12 @@
;; dneeded is minimum space needed, scan for existing archives that
;; are on disks with adequate space and already have this test/itempath
;; archived
;;
(define (db:archive-get-allocations dbstruct testname itempath dneeded)
- (let* ((dbdat (db:get-db dbstruct)) ;; archive tables are in main.db
- (db (db:dbdat-get-db dbdat))
+ (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)))
@@ -1584,12 +1668,12 @@
;; returns id of the record, register a disk allocated to archiving and record it's last known
;; available space
;;
(define (db:archive-register-disk dbstruct bdisk-name bdisk-path df)
- (let* ((dbdat (db:get-db dbstruct)) ;; archive tables are in main.db
- (db (db:dbdat-get-db dbdat))
+ (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
@@ -1614,12 +1698,12 @@
;; record an archive path created on a given archive disk (identified by it's bdisk-id)
;; if path starts with / then it is full, otherwise it is relative to the archive disk
;; preference is to store the relative path.
;;
(define (db:archive-register-block-name dbstruct bdisk-id archive-path #!key (du #f))
- (let* ((dbdat (db:get-db dbstruct)) ;; archive tables are in main.db
- (db (db:dbdat-get-db dbdat))
+ (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))
@@ -1644,11 +1728,11 @@
(define (db:test-set-archive-block-id dbstruct run-id test-id archive-block-id)
(db:with-db
dbstruct
run-id
#f
- (lambda (db)
+ (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
;;
@@ -1655,11 +1739,11 @@
(define (db:test-get-archive-block-info dbstruct archive-block-id)
(db:with-db
dbstruct
#f
#f
- (lambda (db)
+ (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)))
@@ -1667,12 +1751,12 @@
"SELECT id,archive_disk_id,disk_path,last_du,last_du_time,creation_time FROM archive_blocks WHERE id=?;"
archive-block-id)
res))))
;; (define (db:archive-allocate-testsuite/area-to-block block-id testsuite-name areakey)
-;; (let* ((dbdat (db:get-db dbstruct #f)) ;; archive tables are in main.db
-;; (db (db:dbdat-get-db dbdat))
+;; (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)
;;======================================================================
@@ -1724,12 +1808,12 @@
(deadtime (if (and deadtime-str
(string->number deadtime-str))
(string->number deadtime-str)
72000))) ;; twenty hours
(db:with-db
- dbstruct #f #f
- (lambda (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
@@ -1807,24 +1891,24 @@
)
(debug:print-info 4 *default-log-port* "running-deadtime = " running-deadtime)
(debug:print-info 4 *default-log-port* "deadtime-trim = " deadtime-trim)
(db:with-db
- dbstruct #f #f
- (lambda (db)
+ dbstruct run-id #f
+ (lambda (dbdat db)
(let* ((stmth1 (db:get-cache-stmth
- dbstruct db
+ dbdat run-id db
"SELECT id,rundir,uname,testname,item_path,event_time,run_duration FROM tests
WHERE run_id=? AND (strftime('%s','now') - event_time) > (run_duration + ?)
AND state IN ('RUNNING');"))
(stmth2 (db:get-cache-stmth
- dbstruct db
+ dbdat run-id db
"SELECT id,rundir,uname,testname,item_path,event_time,run_duration FROM tests
WHERE run_id=? AND (strftime('%s','now') - event_time) > (run_duration + ?)
AND state IN ('REMOTEHOSTSTART');"))
(stmth3 (db:get-cache-stmth
- dbstruct db
+ dbdat run-id db
"SELECT id,rundir,uname,testname,item_path FROM tests
WHERE run_id=? AND (strftime('%s','now') - event_time) > 86400
AND state IN ('LAUNCHED');")))
;; in RUNNING or REMOTEHOSTSTART for more than 10 minutes
;;
@@ -1928,11 +2012,11 @@
)))))))
;; BUG: Probably broken - does not explicitly use run-id in the query
;;
(define (db:top-test-set-per-pf-counts dbstruct run-id test-name)
- (db:general-call dbstruct 'top-test-set-per-pf-counts (list test-name test-name test-name test-name test-name test-name test-name test-name test-name test-name test-name test-name test-name test-name test-name test-name test-name)))
+ (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:
;;
@@ -1944,11 +2028,11 @@
;; b. ....
;;
(define (db:clean-up dbdat)
;; (debug:print 0 *default-log-port* "WARNING: db clean up not fully ported to v1.60, cleanup action will be on megatest.db")
(let* ((keep-record-age ( - (current-seconds) (common:hms-string->seconds (or (configf:lookup *configdat* "setup" "delete-record-age") "30d"))))
- (db (db:dbdat-get-db dbdat))
+ (db (dbr:dbdat-dbh dbdat))
(count-stmt (sqlite3:prepare db "SELECT (SELECT count(id) FROM tests)+(SELECT count(id) FROM runs);"))
(statements
(map (lambda (stmt)
(sqlite3:prepare db stmt))
(list
@@ -1999,11 +2083,11 @@
;; a. If have tests that are not deleted, set state='unknown'
;; b. ....
;;
(define (db:clean-up-rundb dbdat)
;; (debug:print 0 *default-log-port* "WARNING: db clean up not fully ported to v1.60, cleanup action will be on megatest.db")
- (let* ((db (db:dbdat-get-db dbdat))
+ (let* ((db (dbr:dbdat-dbh dbdat))
(count-stmt (sqlite3:prepare db "SELECT (SELECT count(id) FROM tests);"))
(statements
(map (lambda (stmt)
(sqlite3:prepare db stmt))
(list
@@ -2040,11 +2124,11 @@
;; a. If have tests that are not deleted, set state='unknown'
;; b. ....
;;
(define (db:clean-up-maindb dbdat)
;; (debug:print 0 *default-log-port* "WARNING: db clean up not fully ported to v1.60, cleanup action will be on megatest.db")
- (let* ((db (db:dbdat-get-db dbdat))
+ (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
@@ -2085,12 +2169,12 @@
;; also updates *global-delta*
;;
(define (db:get-var dbstruct var)
(let* ((res #f))
(db:with-db
- dbstruct #f #f
- (lambda (db)
+ dbstruct #f #f ;; for the moment vars are only stored in main.db
+ (lambda (dbdat db)
(sqlite3:for-each-row
(lambda (val)
(set! res val))
db
"SELECT val FROM metadat WHERE var=?;" var)
@@ -2100,16 +2184,16 @@
(if valnum (set! res valnum))))
res))))
(define (db:inc-var dbstruct var)
(db:with-db dbstruct #f #t
- (lambda (db)
+ (lambda (dbdat db)
(sqlite3:execute db "UPDATE metadat SET val=val+1 WHERE var=?;" var))))
(define (db:dec-var dbstruct var)
(db:with-db dbstruct #f #t
- (lambda (db)
+ (lambda (dbdat db)
(sqlite3:execute db "UPDATE metadat SET val=val-1 WHERE var=?;" var))))
;; This was part of db:get-var. It was used to estimate the load on
;; the database files.
;;
@@ -2122,99 +2206,49 @@
;; (debug:print-info 4 *default-log-port* "launch throttle factor=" *global-delta*)
;; (set! *last-global-delta-printed* *global-delta*)))
(define (db:set-var dbstruct var val)
(db:with-db dbstruct #f #t
- (lambda (db)
+ (lambda (dbdat db)
(sqlite3:execute db "INSERT OR REPLACE INTO metadat (var,val) VALUES (?,?);" var val))))
(define (db:add-var dbstruct var val)
(db:with-db dbstruct #f #t
- (lambda (db)
+ (lambda (dbdat db)
(sqlite3:execute db "UPDATE metadat SET val=val+? WHERE var=?;" val var))))
(define (db:del-var dbstruct var)
(db:with-db dbstruct #f #t
- (lambda (db)
+ (lambda (dbdat db)
(sqlite3:execute db "DELETE FROM metadat WHERE var=?;" var))))
;;======================================================================
;; no-sync.db - small bits of data to be shared between servers
;;======================================================================
-(define (db:open-no-sync-db)
- (let* ((dbpath (db:dbfile-path))
- (dbname (conc dbpath "/no-sync.db"))
- (db-exists (common:file-exists? dbname))
- (db (sqlite3:open-database dbname)))
- (sqlite3:set-busy-handler! db (sqlite3:make-busy-timeout 136000))
- (if (not db-exists)
- (begin
- (sqlite3:execute db "PRAGMA synchronous = 0;")
- (sqlite3:execute db "CREATE TABLE IF NOT EXISTS no_sync_metadat (var TEXT,val TEXT, CONSTRAINT no_sync_metadat_constraint UNIQUE (var));")
- (sqlite3:execute db "PRAGMA journal_mode=WAL;")))
- db))
-
-;; if we are not a server create a db handle. this is not finalized
-;; so watch for problems. I'm still not clear if it is needed to manually
-;; finalize sqlite3 dbs with the sqlite3 egg.
-;;
(define (db:no-sync-db db-in)
- (mutex-lock! *db-access-mutex*)
- (let ((res (if db-in
- db-in
- (let ((db (db:open-no-sync-db)))
- (set! *no-sync-db* db)
- db))))
- (mutex-unlock! *db-access-mutex*)
- res))
-
-(define (db:no-sync-set db var val)
- (sqlite3:execute (db:no-sync-db db) "INSERT OR REPLACE INTO no_sync_metadat (var,val) VALUES (?,?);" var val))
-
-(define (db:no-sync-del! db var)
- (sqlite3:execute (db:no-sync-db db) "DELETE FROM no_sync_metadat WHERE var=?;" var))
-
-(define (db:no-sync-get/default db var default)
- (let ((res default))
- (sqlite3:for-each-row
- (lambda (val)
- (set! res val))
- (db:no-sync-db db)
- "SELECT val FROM no_sync_metadat WHERE var=?;"
- var)
- (if res
- (let ((newres (if (string? res)
- (string->number res)
- #f)))
- (if newres
- newres
- res))
- res)))
+ (if db-in
+ db-in
+ (if *no-sync-db*
+ *no-sync-db*
+ (begin
+ (mutex-lock! *db-access-mutex*)
+ (let ((dbpath (common:get-db-tmp-area))
+ (db (dbfile:open-no-sync-db dbpath)))
+ (set! *no-sync-db* db)
+ (mutex-unlock! *db-access-mutex*)
+ db)))))
+
+(define (with-no-sync-db proc)
+ (let* ((db (db:no-sync-db *no-sync-db*)))
+ (proc db)))
+
+(define (db:open-no-sync-db)
+ (dbfile:open-no-sync-db (db:dbfile-path)))
(define (db:no-sync-close-db db stmt-cache)
(db:safely-close-sqlite3-db db stmt-cache))
-
-;; transaction protected lock aquisition
-;; either:
-;; fails returns (#f . lock-creation-time)
-;; succeeds (returns (#t . lock-creation-time)
-;; use (db:no-sync-del! db keyname) to release the lock
-;;
-(define (db:no-sync-get-lock db-in keyname)
- (let ((db (db:no-sync-db db-in)))
- (sqlite3:with-transaction
- db
- (lambda ()
- (handle-exceptions
- exn
- (let ((lock-time (current-seconds)))
- (debug:print-info 2 *default-log-port* "db:no-sync-get-lock keyname=" keyname ", lock-time=" lock-time ", exn=" exn)
- (sqlite3:execute db "INSERT INTO no_sync_metadat (var,val) VALUES(?,?);" keyname lock-time)
- `(#t . ,lock-time))
- `(#f . ,(sqlite3:first-result db "SELECT val FROM no_sync_metadat WHERE var=?;" keyname)))))))
-
;; use a global for some primitive caching, it is just silly to
;; re-read the db over and over again for the keys since they never
;; change
@@ -2221,21 +2255,23 @@
;; why get the keys from the db? why not get from the *configdat*
;; using keys:config-get-fields?
(define (db:get-keys dbstruct)
- (if *db-keys* *db-keys*
- (let ((res '()))
- (db:with-db dbstruct #f #f
- (lambda (db)
- (sqlite3:for-each-row
- (lambda (key)
- (set! res (cons key res)))
- db
- "SELECT fieldname FROM keys ORDER BY id DESC;")))
- (set! *db-keys* res)
- res)))
+ (keys:config-get-fields *configdat*)
+)
+;; (if *db-keys* *db-keys*
+;; (let ((res '()))
+;; (db:with-db dbstruct #f #f
+;; (lambda (dbdat db)
+;; (sqlite3:for-each-row
+;; (lambda (key)
+;; (set! res (cons key res)))
+;; db
+;; "SELECT fieldname FROM keys ORDER BY id DESC;")))
+;; (set! *db-keys* res)
+;; res)))
;; extract index number given a header/data structure
(define (db:get-index-by-header header field)
(list-index (lambda (x)(equal? x field)) header))
@@ -2275,11 +2311,11 @@
;(print qry)
(db:with-db
dbstruct
#f ;; this is for the main runs db
#f ;; does not modify db
- (lambda (db)
+ (lambda (dbdat db)
(sqlite3:for-each-row
(lambda (runname runtime target )
(set! res (cons (vector runname runtime target) res)))
db
qry
@@ -2292,11 +2328,11 @@
(define (db:get-run-name-from-id dbstruct run-id)
(db:with-db
dbstruct
#f ;; this is for the main runs db
#f ;; does not modify db
- (lambda (db)
+ (lambda (dbdat db)
(let ((res #f))
(sqlite3:for-each-row
(lambda (runname)
(set! res runname))
db
@@ -2307,11 +2343,11 @@
(define (db:get-run-key-val dbstruct run-id key)
(db:with-db
dbstruct
#f
#f
- (lambda (db)
+ (lambda (dbdat db)
(let ((res #f))
(sqlite3:for-each-row
(lambda (val)
(set! res val))
db
@@ -2356,11 +2392,11 @@
(debug:print 3 *default-log-port* "keys: " keys " allvals: " allvals " keyvals: " keyvals " key=?str is " key=?str)
(debug:print 2 *default-log-port* "NOTE: using target " (string-intersperse (map cadr keyvals) "/") " for this run")
(if (and runname (null? (filter (lambda (x)(not x)) keyvals))) ;; there must be a better way to "apply and"
(db:with-db
dbstruct #f #f
- (lambda (db)
+ (lambda (dbdat db)
(let ((res #f))
(apply sqlite3:execute db (conc "INSERT OR IGNORE INTO runs (runname,state,status,owner,event_time,contour" comma keystr ") VALUES (?,?,?,?,strftime('%s','now'),?" comma valslots ");")
allvals)
(apply sqlite3:for-each-row
(lambda (id)
@@ -2406,11 +2442,11 @@
(if (number? offset)
(conc " OFFSET " offset)
""))))
(debug:print-info 11 *default-log-port* "db:get-runs START qrystr: " qrystr " keypatts: " keypatts " offset: " offset " limit: " count)
(db:with-db dbstruct #f #f
- (lambda (db)
+ (lambda (dbdat db)
(sqlite3:for-each-row
(lambda (a . x)
(set! res (cons (apply vector a x) res)))
db
qrystr
@@ -2449,11 +2485,11 @@
(conc " OFFSET " offset)
"")))
)
(debug:print-info 11 *default-log-port* "db:get-runs START qrystr: " qrystr " target: " target " offset: " offset " limit: " count)
(db:with-db dbstruct #f #f
- (lambda (db)
+ (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
@@ -2490,11 +2526,11 @@
(seen (make-hash-table)))
(db:with-db
dbstruct
#f
#f
- (lambda (db)
+ (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
@@ -2509,11 +2545,11 @@
(define (db:get-num-runs dbstruct runpatt)
(db:with-db
dbstruct
#f
#f
- (lambda (db)
+ (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))
@@ -2526,11 +2562,11 @@
(define (db:get-runs-cnt-by-patt dbstruct runpatt targetpatt keys)
(db:with-db
dbstruct
#f
#f
- (lambda (db)
+ (lambda (dbdat db)
(let ((numruns 0)
(qry-str #f)
(key-patt "")
(keyvals (if targetpatt (keys:target->keyval keys targetpatt) '())))
@@ -2564,11 +2600,11 @@
(define (db:get-raw-run-stats dbstruct run-id)
(db:with-db
dbstruct
run-id
#f
- (lambda (db)
+ (lambda (dbdat db)
(sqlite3:fold-row
(lambda (res state status count)
(cons (list state status count) res))
'()
db
@@ -2583,11 +2619,11 @@
(db:with-db
dbstruct
#f
#f
- (lambda (db)
+ (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
@@ -2607,11 +2643,11 @@
(define (db:get-main-run-stats dbstruct run-id)
(db:with-db
dbstruct
#f ;; this data comes from main
#f
- (lambda (db)
+ (lambda (dbdat db)
(sqlite3:fold-row
(lambda (res state status count)
(cons (list state status count) res))
'()
db
@@ -2640,11 +2676,11 @@
(define (db:get-all-run-ids dbstruct)
(db:with-db
dbstruct
#f
#f
- (lambda (db)
+ (lambda (dbdat db)
(let ((run-ids '()))
(sqlite3:for-each-row
(lambda (run-id)
(set! run-ids (cons run-id run-ids)))
db
@@ -2664,11 +2700,11 @@
(res '())
(runs-info '()))
;; First get all the runname/run-ids
(db:with-db
dbstruct #f #f
- (lambda (db)
+ (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
@@ -2680,11 +2716,11 @@
(run-name (cadr run-info)))
(db:with-db
dbstruct
run-id
#f
- (lambda (db)
+ (lambda (dbdat db)
(sqlite3:for-each-row
(lambda (state status count)
(let ((netstate (if (equal? state "COMPLETED") status state)))
(if (string? netstate)
(begin
@@ -2742,11 +2778,11 @@
;(print "runs:get-runs-by-patt qry=" qry-str " " runnamepatt)
(vector header
(reverse
(db:with-db dbstruct #f #f ;; reads db, does not write to it.
- (lambda (db)
+ (lambda (dbdat db)
(sqlite3:fold-row
(lambda (res . r)
(cons (list->vector r) res))
'()
db
@@ -2768,11 +2804,11 @@
(string-intersperse remfields ","))))
(debug:print-info 11 *default-log-port* "db:get-run-info run-id: " run-id " header: " header " keystr: " keystr)
(db:with-db
dbstruct #f #f
- (lambda (db)
+ (lambda (dbdat db)
(sqlite3:for-each-row
(lambda (a . x)
(set! res (apply vector a x)))
db
(conc "SELECT " keystr " FROM runs WHERE id=?;")
@@ -2783,19 +2819,19 @@
finalres)))
(define (db:set-comment-for-run dbstruct run-id comment)
(db:with-db
dbstruct #f #f
- (lambda (db)
+ (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 #f
- (lambda (db)
+ (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)
@@ -2804,17 +2840,17 @@
(sqlite3:execute db "UPDATE runs SET state='deleted',comment='' WHERE id=?;" run-id))))))
(define (db:update-run-event_time dbstruct run-id)
(db:with-db
dbstruct #f #t
- (lambda (db)
+ (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 (db)
+ (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)
@@ -2823,28 +2859,28 @@
(debug:print-info 1 *default-log-port* "" newlockval " run number " run-id)))))
(define (db:set-run-status dbstruct run-id status msg)
(db:with-db
dbstruct #f #f
- (lambda (db)
+ (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 dbstruct run-id state status )
(db:with-db
dbstruct #f #f
- (lambda (db)
+ (lambda (dbdat db)
(sqlite3:execute db "UPDATE runs SET status=?,state=? WHERE id=?;" status state run-id))))
(define (db:get-run-status dbstruct run-id)
(let ((res "n/a"))
(db:with-db
dbstruct #f #f
- (lambda (db)
+ (lambda (dbdat db)
(sqlite3:for-each-row
(lambda (status)
(set! res status))
db
"SELECT status FROM runs WHERE id=?;"
@@ -2853,11 +2889,11 @@
(define (db:get-run-state dbstruct run-id)
(let ((res "n/a"))
(db:with-db
dbstruct #f #f
- (lambda (db)
+ (lambda (dbdat db)
(sqlite3:for-each-row
(lambda (status)
(set! res status))
db
"SELECT state FROM runs WHERE id=?;"
@@ -2874,11 +2910,11 @@
(define (db:get-key-val-pairs dbstruct run-id)
(let* ((keys (db:get-keys dbstruct))
(res '()))
(db:with-db
dbstruct #f #f
- (lambda (db)
+ (lambda (dbdat db)
(for-each
(lambda (key)
(let ((qry (conc "SELECT " key " FROM runs WHERE id=?;")))
(sqlite3:for-each-row
(lambda (key-val)
@@ -2891,11 +2927,11 @@
(define (db:get-key-vals dbstruct run-id)
(let* ((keys (db:get-keys dbstruct))
(res '()))
(db:with-db
dbstruct #f #f
- (lambda (db)
+ (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
@@ -2923,11 +2959,11 @@
(let ((prev-run-ids '()))
(if (null? keyvals)
'()
(begin
(db:with-db dbstruct #f #f ;; #f means work with the zeroth db - i.e. the runs db
- (lambda (db)
+ (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 != ?;")
@@ -3018,11 +3054,11 @@
(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 (db)
+ (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
@@ -3055,11 +3091,11 @@
;; 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 (db)
+;; (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))
@@ -3085,11 +3121,11 @@
" 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 (db)
+ (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))
'()
@@ -3099,11 +3135,11 @@
(or last-update 0))))))
(define (db:get-testinfo-state-status dbstruct run-id test-id)
(let ((res #f))
(db:with-db dbstruct run-id #f
- (lambda (db)
+ (lambda (dbdat db)
(sqlite3:for-each-row
(lambda (run-id testname item-path state status)
;; id,run_id,testname,state,status,event_time,host,cpuload,diskfree,uname,rundir,item_path,run_duration,final_logf,comment
(set! res (vector test-id run-id testname state status -1 "" -1 -1 "" "-" item-path -1 "-" "-")))
db
@@ -3134,15 +3170,15 @@
;; Convert calling routines to get list of run-ids and loop, do not use the get-tests-for-runs
;;
(define (db:delete-test-records dbstruct run-id test-id)
- (db:general-call dbstruct 'delete-test-step-records (list test-id))
- (db:general-call dbstruct 'delete-test-data-records (list test-id))
+ (db: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 #f #f
- (lambda (db)
+ dbstruct run-id #f
+ (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)
(let ((targtime (- (current-seconds)
@@ -3150,11 +3186,11 @@
(* 30 24 60 60))))) ;; one month in the past
(db:with-db
dbstruct
0
#t
- (lambda (db)
+ (lambda (dbdat db)
(sqlite3:with-transaction
db
(lambda ()
(sqlite3:execute db "DELETE FROM test_steps WHERE test_id IN (SELECT id FROM tests WHERE state='DELETED' AND event_timenumber "id" db:test-record-fields))))
- (db:adj-test-id (db:dbdat-get-db mtdb) min-test-id test-id)))
+ (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
;;
@@ -3469,21 +3504,21 @@
(define (db:prep-megatest.db-for-migration mtdb)
(let* ((run-ids (db:get-all-run-ids mtdb)))
(for-each
(lambda (run-id)
(let ((testrecs (db:get-all-tests-info-by-run-id mtdb run-id)))
- (db:prep-megatest.db-adj-test-ids (db:dbdat-get-db mtdb) run-id testrecs)))
+ (db:prep-megatest.db-adj-test-ids (dbr:dbdat-dbh mtdb) run-id testrecs)))
run-ids)))
;; Get test data using test_id, run-id is not used
;;
(define (db:get-test-info-by-id dbstruct run-id test-id)
(db:with-db
dbstruct
- #f ;; run-id
+ run-id
#f
- (lambda (db)
+ (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)))
@@ -3498,11 +3533,11 @@
(define (db:get-test-info-by-ids dbstruct run-id test-ids)
(db:with-db
dbstruct
run-id
#f
- (lambda (db)
+ (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)))
@@ -3514,11 +3549,11 @@
(define (db:get-test-info dbstruct run-id test-name item-path)
(db:with-db
dbstruct
run-id
#f
- (lambda (db)
+ (lambda (dbdat db)
(let ((res #f))
(sqlite3:for-each-row
(lambda (a . b)
(set! res (apply vector a b)))
db
@@ -3529,11 +3564,11 @@
(define (db:test-get-rundir-from-test-id dbstruct run-id test-id)
(db:with-db
dbstruct
run-id
#f
- (lambda (db)
+ (lambda (dbdat db)
(db:first-result-default
db
"SELECT rundir FROM tests WHERE id=?;"
#f ;; default result
test-id))))
@@ -3545,11 +3580,11 @@
" as target from tests inner join runs on tests.run_id = runs.id where runs.runname = ? and target = ? ;")))
(db:with-db
dbstruct
#f ;; this is for the main runs db
#f ;; does not modify db
- (lambda (db)
+ (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
@@ -3563,11 +3598,11 @@
(define (db:teststep-set-status! dbstruct run-id test-id teststep-name state-in status-in comment logfile)
(db:with-db
dbstruct
run-id
#t
- (lambda (db)
+ (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 "")
@@ -3579,11 +3614,11 @@
;; TODO: figure out why status is the key field rather than state (note: CONSTRAINT test_steps_constraint UNIQUE (test_id,stepname,state) )
(db:with-db
dbstruct
run-id
#t
- (lambda (db)
+ (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))))
@@ -3592,11 +3627,11 @@
(define (db:get-steps-for-test dbstruct run-id test-id)
(db:with-db
dbstruct
run-id
#f
- (lambda (db)
+ (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
@@ -3607,11 +3642,11 @@
(define (db:get-steps-info-by-id dbstruct test-step-id)
(db:with-db
dbstruct
#f
#f
- (lambda (db)
+ (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
@@ -3622,11 +3657,11 @@
(define (db:get-steps-data dbstruct run-id test-id)
(db:with-db
dbstruct
run-id
#f
- (lambda (db)
+ (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
@@ -3642,12 +3677,12 @@
(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
#f
#f
- (lambda (db)
- (let* ((stmth (db:get-cache-stmth dbstruct db stmt))
+ (lambda (dbdat db)
+ (let* ((stmth (db:get-cache-stmth dbdat #f 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
@@ -3661,24 +3696,24 @@
;; if one or more are fail (any case) then set test status to PASS, non "pass" or "fail" are ignored
(define (db:test-data-rollup dbstruct run-id test-id status)
(let* ((fail-count 0)
(pass-count 0))
(db:with-db
- dbstruct #f #f
- (lambda (db)
+ dbstruct run-id #f
+ (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 'pass-fail-counts (list pass-count fail-count test-id))
+ (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 'test_data-pf-rollup (list test-id test-id test-id test-id))))))
+ (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
@@ -3761,11 +3796,11 @@
(define (db:csv->test-data dbstruct run-id test-id csvdata)
(debug:print 4 *default-log-port* "test-id " test-id ", csvdata: " csvdata)
(db:with-db
dbstruct #f #f
- (lambda (db)
+ (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
@@ -3824,11 +3859,11 @@
;;
(define (db:read-test-data dbstruct run-id test-id categorypatt)
(let* ((res '()))
(db:with-db
dbstruct #f #f
- (lambda (db)
+ (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)
@@ -3838,11 +3873,11 @@
;;
(define (db:read-test-data-varpatt dbstruct run-id test-id categorypatt varpatt)
(let* ((res '()))
(db:with-db
dbstruct #f #f
- (lambda (db)
+ (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)
@@ -3854,11 +3889,11 @@
;;======================================================================
(define (db:get-run-ids-matching-target dbstruct keynames target res runname testpatt statepatt statuspatt)
(db:with-db
dbstruct #f #f
- (lambda (db)
+ (lambda (dbdat db)
(let* ((row-ids '())
(keystr (string-intersperse
(map (lambda (key val)
(conc key " like '" val "'"))
keynames
@@ -3881,11 +3916,11 @@
(tstsqry (conc "SELECT rundir FROM tests WHERE run_id=? AND " testqry " AND state LIKE '" statepatt "' AND status LIKE '" statuspatt "' ORDER BY event_time ASC;")))
(db:with-db
dbstruct
run-id
#f
- (lambda (db)
+ (lambda (dbdat db)
(sqlite3:for-each-row
(lambda (p)
(set! res (cons p res)))
db
tstsqry
@@ -3895,11 +3930,11 @@
(define (db:test-toplevel-num-items dbstruct run-id testname)
(db:with-db
dbstruct
run-id
#f
- (lambda (db)
+ (lambda (dbdat db)
(let ((res 0))
(sqlite3:for-each-row
(lambda (num-items)
(set! res num-items))
db
@@ -3946,11 +3981,11 @@
(else msg))) ;; rpc
;; ; This is to be the big daddy call NOPE: Replaced by db:set-state-status-and-roll-up-items
;; ;
;; define (db:test-set-state-status dbstruct run-id test-id state status msg)
-;; (let ((dbdat (db:get-db dbstruct run-id)))
+;; (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)))
@@ -3961,11 +3996,11 @@
;; (mt:process-triggers dbstruct run-id test-id state status)))
;; state is the priority rollup of all states
;; status is the priority rollup of all completed statesfu
;;
-;; if test-name is an integer work off that instead of test-name test-path
+;; 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)
@@ -3979,26 +4014,26 @@
(tl-testdat (db:get-test-info dbstruct run-id test-name ""))
(tl-test-id (if tl-testdat
(db:test-get-id tl-testdat)
#f)))
(if (member state '("LAUNCHED" "REMOTEHOSTSTART"))
- (db:general-call dbstruct 'set-test-start-time (list test-id)))
+ (db:general-call dbstruct run-id 'set-test-start-time (list test-id)))
(mutex-lock! *db-transaction-mutex*)
(db:with-db
- dbstruct #f #f
- (lambda (db)
+ dbstruct run-id #f
+ (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 run-id test-id state status comment) ;; this call sets the item state/status
(if (not (equal? item-path "")) ;; only roll up IF incoming test is an item
- (let* ((state-status-counts (db:get-all-state-status-counts-for-test dbstruct run-id test-name item-path state status)) ;; item-path is used to exclude current state/status of THIS test
- (state-stauses (db:roll-up-rules state-status-counts state status))
- (newstate (car state-stauses))
- (newstatus (cadr state-stauses)))
+ (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)))
(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)))) " | "))
@@ -4011,88 +4046,87 @@
(if (and test-id state status (equal? status "AUTO"))
(db:test-data-rollup dbstruct run-id test-id status))
tr-res)))))
(define (db:roll-up-rules state-status-counts state status)
- (let* ((running (length (filter (lambda (x)
- (member (dbr:counts-state x) *common:running-states*))
- state-status-counts)))
- (bad-not-started (length (filter (lambda (x)
- (and (equal? (dbr:counts-state x) "NOT_STARTED")
- (not (member (dbr:counts-status x) *common:not-started-ok-statuses*))))
- state-status-counts)))
- (all-curr-states (common:special-sort ;; worst -> best (sort of)
- (delete-duplicates
- (if (and state (not (member state *common:dont-roll-up-states*)))
- (cons state (map dbr:counts-state state-status-counts))
- (map dbr:counts-state state-status-counts)))
- *common:std-states* >))
- (all-curr-statuses (common:special-sort ;; worst -> best
- (delete-duplicates
- (if (and state status (not (member state *common:dont-roll-up-states*)))
- (cons status (map dbr:counts-status state-status-counts))
- (map dbr:counts-status state-status-counts)))
- *common:std-statuses* >))
- (non-completes (filter (lambda (x)
- (not (member x (cons "COMPLETED" *common:dont-roll-up-states*))))
- all-curr-states))
- (preq-fails (filter (lambda (x)
- (equal? x "PREQ_FAIL"))
- all-curr-statuses))
- (num-non-completes (length non-completes))
- (newstate (cond
- ((> running 0) "RUNNING") ;; anything running, call the situation running
- ((> (length preq-fails) 0) "NOT_STARTED")
- ((> bad-not-started 0) "COMPLETED") ;; we have an ugly situation, it is completed in the sense we cannot do more.
- ((> num-non-completes 0) (car non-completes)) ;; (remove (lambda (x)(equal? "COMPLETED" x)) all-curr-states))) ;; only rollup DELETED if all DELETED
- (else (car all-curr-states))))
- (newstatus (cond
- ((> (length preq-fails) 0) "PREQ_FAIL")
- ((or (> bad-not-started 0)
- (and (equal? newstate "NOT_STARTED")
- (> num-non-completes 0)))
- "STARTED")
- (else (car all-curr-statuses)))))
- (debug:print-info 2 *default-log-port*
- "\n--> probe db:set-state-status-and-roll-up-items: "
- "\n--> state-status-counts: "(map dbr:counts->alist state-status-counts)
- "\n--> running: "running
- "\n--> bad-not-started: "bad-not-started
- "\n--> non-non-completes: "num-non-completes
- "\n--> non-completes: "non-completes
- "\n--> all-curr-states: "all-curr-states
- "\n--> all-curr-statuses: "all-curr-statuses
- "\n--> newstate "newstate
- "\n--> newstatus "newstatus
- "\n\n")
-
- ;; NB// Pass the db so it is part of the transaction
- (list newstate newstatus)))
+ (let* ((running (length (filter (lambda (x)
+ (member (dbr:counts-state x) *common:running-states*))
+ state-status-counts)))
+ (bad-not-started (length (filter (lambda (x)
+ (and (equal? (dbr:counts-state x) "NOT_STARTED")
+ (not (member (dbr:counts-status x) *common:not-started-ok-statuses*))))
+ state-status-counts)))
+ (all-curr-states (common:special-sort ;; worst -> best (sort of)
+ (delete-duplicates
+ (if (and state (not (member state *common:dont-roll-up-states*)))
+ (cons state (map dbr:counts-state state-status-counts))
+ (map dbr:counts-state state-status-counts)))
+ *common:std-states* >))
+ (all-curr-statuses (common:special-sort ;; worst -> best
+ (delete-duplicates
+ (if (and state status (not (member state *common:dont-roll-up-states*)))
+ (cons status (map dbr:counts-status state-status-counts))
+ (map dbr:counts-status state-status-counts)))
+ *common:std-statuses* >))
+ (non-completes (filter (lambda (x)
+ (not (member x (cons "COMPLETED" *common:dont-roll-up-states*))))
+ all-curr-states))
+ (preq-fails (filter (lambda (x)
+ (equal? x "PREQ_FAIL"))
+ all-curr-statuses))
+ (num-non-completes (length non-completes))
+ (newstate (cond
+ ((> running 0) "RUNNING") ;; anything running, call the situation running
+ ((> (length preq-fails) 0) "NOT_STARTED")
+ ((> bad-not-started 0) "COMPLETED") ;; we have an ugly situation, it is completed in the sense we cannot do more.
+ ((> num-non-completes 0) (car non-completes)) ;; (remove (lambda (x)(equal? "COMPLETED" x)) all-curr-states))) ;; only rollup DELETED if all DELETED
+ (else (car all-curr-states))))
+ (newstatus (cond
+ ((> (length preq-fails) 0) "PREQ_FAIL")
+ ((or (> bad-not-started 0)
+ (and (equal? newstate "NOT_STARTED")
+ (> num-non-completes 0)))
+ "STARTED")
+ (else (car all-curr-statuses)))))
+ (debug:print-info 2 *default-log-port*
+ "\n--> probe db:set-state-status-and-roll-up-items: "
+ "\n--> state-status-counts: "(map dbr:counts->alist state-status-counts)
+ "\n--> running: "running
+ "\n--> bad-not-started: "bad-not-started
+ "\n--> non-non-completes: "num-non-completes
+ "\n--> non-completes: "non-completes
+ "\n--> all-curr-states: "all-curr-states
+ "\n--> all-curr-statuses: "all-curr-statuses
+ "\n--> newstate "newstate
+ "\n--> newstatus "newstatus
+ "\n\n")
+
+ ;; NB// Pass the db so it is part of the transaction
+ (list newstate newstatus)))
(define (db:set-state-status-and-roll-up-run dbstruct run-id curr-state curr-status)
(mutex-lock! *db-transaction-mutex*)
(db:with-db
- dbstruct #f #f
- (lambda (db)
+ dbstruct run-id #f
+ (lambda (dbdat db)
(let ((tr-res
(sqlite3:with-transaction
db
(lambda ()
- (let* ((state-status-counts (db:get-all-state-status-counts-for-run dbstruct run-id))
- (state-stauses (db:roll-up-rules state-status-counts #f #f ))
- (newstate (car state-stauses))
- (newstatus (cadr state-stauses)))
- (if (or (not (eq? newstate curr-state)) (not (eq? newstatus curr-status)))
- (db:set-run-state-status dbstruct run-id newstate newstatus )))))))
+ (let* ((state-status-counts (db:get-all-state-status-counts-for-run 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 run-id newstate newstatus )))))))
(mutex-unlock! *db-transaction-mutex*)
tr-res))))
-
(define (db:get-all-state-status-counts-for-run dbstruct run-id)
(let* ((test-count-recs (db:with-db
dbstruct #f #f
- (lambda (db)
+ (lambda (dbdat db)
(sqlite3:map-row
(lambda (state status count)
(make-dbr:counts state: state status: status count: count))
db
"SELECT state,status,count(id) FROM tests WHERE run_id=? GROUP BY state,status;"
@@ -4107,12 +4141,12 @@
(define (db:get-all-state-status-counts-for-test dbstruct run-id test-name item-path item-state-in item-status-in)
(let* ((test-info (db:get-test-info dbstruct run-id test-name item-path))
(item-state (or item-state-in (db:test-get-state test-info)))
(item-status (or item-status-in (db:test-get-status test-info)))
(other-items-count-recs (db:with-db
- dbstruct #f #f
- (lambda (db)
+ dbstruct run-id #f
+ (lambda (dbdat db)
(sqlite3:map-row
(lambda (state status count)
(make-dbr:counts state: state status: status count: count))
db
;; ignore current item because we have changed its value in the current transation so this select will see the old value.
@@ -4157,11 +4191,11 @@
(define (db:test-get-logfile-info dbstruct run-id test-name)
(db:with-db
dbstruct
run-id
#f
- (lambda (db)
+ (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)))
@@ -4343,29 +4377,30 @@
(else
(hash-table-set! *logged-in-clients* client-signature (current-seconds))
'(#t "successful login"))))
-(define (db:general-call dbstruct stmtname params)
+(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 #f #f
- (lambda (db)
+ dbstruct run-id #f
+ (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 #f #f
- (lambda (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;"
@@ -4375,11 +4410,11 @@
(define (db:get-latest-host-load dbstruct raw-hostname)
(let* ((hostname (string-substitute "\\..*$" "" raw-hostname))
(res (cons -1 0)))
(db:with-db
dbstruct #f #f
- (lambda (db)
+ (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 ))
@@ -4420,11 +4455,11 @@
(keyvals #f)
(tests-hash (make-hash-table)))
;; first look up the key values from the run selected by run-id
(db:with-db
dbstruct #f #f
- (lambda (db)
+ (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)))
@@ -4431,11 +4466,11 @@
(if (not keyvals)
'()
(let ((prev-run-ids '()))
(db:with-db
dbstruct #f #f
- (lambda (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 id != ?;") (append keyvals (list run-id)))))
@@ -4467,14 +4502,14 @@
;; 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 (db:dbdat-get-db dbdat))
+ (and dbdat (dbr:dbdat-dbh dbdat))
(if dbdat
- (let* ((dbpath (db:dbdat-get-path dbdat))
- (db (db:dbdat-get-db dbdat)) ;; we'll return this so (db:delay--if-busy can be called inline
+ (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)
@@ -4510,11 +4545,11 @@
(let ((res '()))
(db:with-db
dbstruct
run-id
#f
- (lambda (db)
+ (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?
@@ -4529,11 +4564,11 @@
;; returns a hash table of tags to tests
;;
(define (db:get-tests-tags dbstruct)
(db:with-db
dbstruct #f #f
- (lambda (db)
+ (lambda (dbdat db)
(let* ((res (make-hash-table)))
(sqlite3:for-each-row
(lambda (testname tags-in)
(let ((tags (string-split tags-in ",")))
(for-each
@@ -4551,11 +4586,11 @@
(let ((res #f))
(db:with-db
dbstruct
#f
#f
- (lambda (db)
+ (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=?;"
@@ -4563,26 +4598,26 @@
res))))
;; create a new record for a given testname
(define (db:testmeta-add-record dbstruct testname)
(db:with-db dbstruct #f #f
- (lambda (db)
+ (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 #f
- (lambda (db)
+ (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 (db)
+ (lambda (dbdat db)
(let ((res '()))
(sqlite3:for-each-row
(lambda (a . b)
(set! res (cons (apply vector a b) res)))
db
@@ -4833,11 +4868,11 @@
;;======================================================================
(define (db:get-run-record-ids dbstruct target run keynames test-patt)
(let ((backcons (lambda (lst item)(cons item lst))))
(db:with-db
dbstruct #f #f
- (lambda (db)
+ (lambda (dbdat db)
(let* ((keystr (string-intersperse
(map (lambda (key val)
(conc key " like '" val "'"))
keynames
(string-split target "/"))
@@ -4862,11 +4897,11 @@
(define (db:get-changed-record-ids dbstruct since-time)
;; no transaction, allow the db to be accessed between the big queries
(let ((backcons (lambda (lst item)(cons item lst))))
(db:with-db
dbstruct #f #f
- (lambda (db)
+ (lambda (dbdat db)
`((runs . ,(sqlite3:fold-row backcons '() db "SELECT id FROM runs WHERE last_update>=?" since-time))
(tests . ,(sqlite3:fold-row backcons '() db "SELECT id FROM tests WHERE last_update>=?" since-time))
(test_steps . ,(sqlite3:fold-row backcons '() db "SELECT id FROM test_steps WHERE last_update>=?" since-time))
(test_data . ,(sqlite3:fold-row backcons '() db "SELECT id FROM test_data WHERE last_update>=?" since-time))
;; (test_meta . ,(fold-row backcons '() db "SELECT id FROM test_meta WHERE last_update>?" since-time))
@@ -4880,16 +4915,17 @@
;; 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-db dbstruct))
- (db (db:dbdat-get-db dbdat))
+ (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
@@ -5001,6 +5037,416 @@
(stack-push! (dbr:dbstruct-dbstack dbstruct) 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)))
+
+;;======================================================================
+;; TODO: for multiple areas, we will have multiple watchdogs; and multiple threads to manage
+(define (common:watchdog)
+ (debug:print-info 13 *default-log-port* "common:watchdog entered.")
+ (if (launch:setup)
+ (if (common:on-homehost?)
+ (let ((dbstruct (db:setup #t))) ;; (db:setup-db *dbstruct-dbs* *toppath* #f))) ;; #t)))
+ (debug:print-info 13 *default-log-port* "after db:setup with dbstruct=" dbstruct)
+ (cond
+ ((dbr:dbstruct-read-only dbstruct)
+ (debug:print-info 13 *default-log-port* "loading read-only watchdog")
+ (common:readonly-watchdog dbstruct))
+ (else
+ (debug:print-info 13 *default-log-port* "loading writable-watchdog.")
+ (let* ((syncer (or (configf:lookup *configdat* "server" "sync-method") "delta-sync"))) ;; "delta-sync"))) ;; "brute-force-sync")))
+ (cond
+ ((equal? syncer "brute-force-sync")
+ (server:writable-watchdog-bruteforce dbstruct))
+ ((equal? syncer "delta-sync")
+ (server:writable-watchdog-deltasync dbstruct))
+ ((equal? syncer "copy-sync")
+ (server:writable-watchdog-copysync dbstruct))
+ (else
+ (debug:print-error 0 *default-log-port* "Unknown server/sync-method specified ("syncer") - valid values are copy-sync, brute-force-sync and delta-sync.")
+ (exit 1)))
+ ;;(debug:print 1 *default-log-port* "INFO: ["(common:human-time)"] Syncer started (method="syncer")")
+ )))
+ (debug:print-info 13 *default-log-port* "watchdog done."))
+ (debug:print-info 13 *default-log-port* "no need for watchdog on non-homehost"))))
+
+
+(define (db:do-sync)
+ (let* ((syncer (or (configf:lookup *configdat* "server" "sync-method") "delta-sync"))
+ (dbstruct (db:setup #t)))
+
+ (debug:print 0 *default-log-port* "db:do-sync: sync-method: " syncer)
+ (cond
+ ((equal? syncer "brute-force-sync")
+ (db:run-lock-and-sync *no-sync-db*))
+ ((equal? syncer "delta-sync")
+ (debug:print 0 *default-log-port* "db:do-sync: db:multi-db-sync" )
+ (let* (
+ (tmpdbpth (dbr:dbstruct-tmppath dbstruct))
+ (lockfile (conc tmpdbpth ".lock"))
+ (locked (common:simple-file-lock lockfile))
+ (res (if locked
+ (db:multi-db-sync
+ dbstruct
+ 'new2old)
+ #f)))
+ (if res
+ (begin
+ (common:simple-file-release-lock lockfile)
+ (print "db:do-sync: Synced " res " records to megatest.db")
+ )
+ (print "db:do-sync: Skipping sync, there is a sync in progress.")
+ )
+ )
+ )
+ ((equal? syncer "copy-sync")
+ (db:run-lock-and-sync *no-sync-db*))
+ (else
+ (debug:print-error 0 *default-log-port* "Unknown server/sync-method specified ("syncer") - valid values are copy-sync, brute-force-sync and delta-sync.")
+ (exit 1)
+ )
+ )
+ )
+)
+
+
+
+
+(define (server:writable-watchdog-bruteforce dbstruct)
+ (thread-sleep! 1) ;; delay for startup
+ #;(let* ((do-a-sync (server:get-bruteforce-syncer dbstruct))
+ (final-sync (server:get-bruteforce-syncer dbstruct fork-to-background: #t persist-until-sync: #t)))
+ (when (and (not (args:get-arg "-sync-to-megatest.db")) ;; conditions under which we do not run the sync
+ (args:get-arg "-server"))
+
+ (let loop ()
+ (do-a-sync)
+ (if (not *time-to-exit*) (loop))) ;; keep going unless time to exit
+
+ ;; time to exit, close the no-sync db here
+ (final-sync)
+
+ (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)
+ ))))
+ )
+
+
+;; 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:get-db-tmp-area))
+ (dbfiles (glob (conc tmp-area"/.db/*.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*"/.db/"fname))
+ (time1 (if (file-exists? file)
+ (file-modification-time file)
+ (begin
+ (debug:print-info 0 *default-log-port* "Sync - I do not see file "file)
+ 1)))
+ (time2 (if (file-exists? fulln)
+ (file-modification-time fulln)
+ (begin
+ (debug:print-info 0 *default-log-port* "Sync - I do not see file "fulln)
+ 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:get-db-tmp-area)))
+ ;; Sync moved to http-transport keep-running loop
+ (set! *no-sync-db* no-sync-db) ;; make the no sync db available to api calls
+ (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))))
+ (set! *no-sync-db* no-sync-db) ;; make the no sync db available to api calls
+ (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:get-db-tmp-area))
+ (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))
+ ;;(debug:print-info 13 *default-log-port* "std-exit-procedure called; *time-to-exit*="*time-to-exit*)
+ (let ((no-hurry (if *time-to-exit* ;; hurry up
+ #f
+ (begin
+ (set! *time-to-exit* #t)
+ #t))))
+ (debug:print-info 4 *default-log-port* "starting exit process, finalizing databases.")
+ (if (and no-hurry (debug:debug-mode 18))
+ (rmt:print-db-stats))
+ (let ((th1 (make-thread (lambda () ;; thread for cleaning up, give it five seconds
+ (if *dbstruct-dbs* (db:close-all *dbstruct-dbs*)) ;; one second allocated
+ (if *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)))))
+ (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 dbfile.scm
Index: dbfile.scm
==================================================================
--- /dev/null
+++ dbfile.scm
@@ -0,0 +1,637 @@
+;;======================================================================
+;; 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 .
+
+;;======================================================================
+
+(declare (unit dbfile))
+;; (declare (uses debugprint))
+;; (declare (uses commonmod))
+
+(module dbfile
+ *
+
+(import scheme chicken data-structures extras)
+(import (prefix sqlite3 sqlite3:)
+ posix typed-records srfi-18
+ srfi-69
+ stack
+ files
+ ports
+
+ ;; commonmod
+ )
+
+;; (import debugprint)
+
+;;======================================================================
+;; R E C O R D S
+;;======================================================================
+
+;; a single Megatest area with it's multiple dbs is
+;; managed in a dbstruct
+;;
+(defstruct dbr:dbstruct
+ (areapath #f)
+ (homehost #f)
+ (tmppath #f)
+ (read-only #f)
+ (subdbs (make-hash-table))
+ )
+
+;; NOTE: Need one dbr:subdb per main.db, 1.db ...
+;;
+(defstruct dbr:subdb
+ (dbname #f) ;; .db/1.db
+ (mtdbfile #f) ;; mtrah/.db/1.db
+ (mtdbdat #f) ;; only need one of these for syncing
+ ;; (dbdats (make-hash-table)) ;; id => dbdat
+ (tmpdbfile #f) ;; /tmp/.../.db/1.db
+ ;; (refndbfile #f) ;; /tmp/.../.db/1.db_ref
+ (dbstack (make-stack)) ;; stack for tmp dbr:dbdat,
+ (homehost #f) ;; not used yet
+ (on-homehost #f) ;; not used yet
+ (read-only #f)
+ (last-sync 0)
+ (last-write (current-seconds))
+ ) ;; goal is to converge on one struct for an area but for now it is too confusing
+
+;; need to keep dbhandles and cached statements together
+(defstruct dbr:dbdat
+ (dbfile #f)
+ (dbh #f)
+ (stmt-cache (make-hash-table))
+ (read-only #f))
+
+(define *dbstruct-dbs* #f)
+(define *db-access-mutex* (make-mutex))
+(define *no-sync-db* #f)
+
+(define (dbfile:run-id->key run-id)
+ (or run-id 'main))
+
+(define (db:safely-close-sqlite3-db db stmt-cache #!key (try-num 3))
+ (if (<= try-num 0)
+ #f
+ (handle-exceptions
+ exn
+ (begin
+ (print "Attempt to safely close sqlite3 db failed. Trying again. exn=" exn)
+ (thread-sleep! 3)
+ (sqlite3:interrupt! db)
+ (db:safely-close-sqlite3-db db stmt-cache try-num: (- try-num 1)))
+ (if (sqlite3:database? db)
+ (let* ((stmts (and stmt-cache (hash-table-ref/default stmt-cache db #f))))
+ (if stmts (map sqlite3:finalize! (hash-table-values stmts)))
+ (sqlite3:finalize! db)
+ #t)
+ (begin
+ (dbfile:print-err "db:safely-close-sqlite3-db: " db " is not an sqlite3 db")
+ #f
+ )
+ ))))
+
+;; close all opened run-id dbs
+(define (db:close-all dbstruct)
+ (if (dbr:dbstruct? dbstruct)
+;; (handle-exceptions
+;; exn
+;; (begin
+;; (debug:print 0 *default-log-port* "WARNING: Finalizing failed, " ((condition-property-accessor 'exn 'message) exn) ", note - exn=" exn)
+;; (print-call-chain *default-log-port*))
+ ;; (db:sync-touched dbstruct 0 force-sync: #t) ;; NO. Do not do this here. Instead we rely on a server to be started when there are writes, even if the server itself is not going to be used as a server.
+ (let* ((subdbs (hash-table-values (dbr:dbstruct-subdbs dbstruct))))
+ (for-each
+ (lambda (subdb)
+ (let* ((tdbs (stack->list (dbr:subdb-dbstack subdb)))
+ (mtdbdat (dbr:dbdat-dbh (dbr:subdb-mtdbdat subdb)))
+ #;(rdb (dbr:dbdat-dbh (dbr:subdb-refndb subdb))))
+
+ (map (lambda (dbdat)
+ (let* ((stmt-cache (dbr:dbdat-stmt-cache dbdat))
+ (dbh (dbr:dbdat-dbh dbdat)))
+ (db:safely-close-sqlite3-db dbh stmt-cache)))
+ tdbs)
+ (db:safely-close-sqlite3-db mtdbdat (dbr:dbdat-stmt-cache (dbr:subdb-mtdbdat subdb)))
+ ;; (if (sqlite3:database? mdb) (sqlite3:finalize! mdb))
+ #;(db:safely-close-sqlite3-db rdb #f))) ;; stmt-cache))))) ;; (if (sqlite3:database? rdb) (sqlite3:finalize! rdb))))))
+ subdbs)
+ #t
+ )
+ #f
+ )
+)
+
+;; ;; set up a single db (e.g. main.db, 1.db ... etc.)
+;; ;;
+;; (define (db:setup-db dbstruct areapath run-id)
+;; (let* ((dbname (db:run-id->dbname run-id))
+;; (dbstruct (hash-table-ref/default dbstructs dbname #f)))
+;; (if dbstruct
+;; dbstruct
+;; (let* ((dbstruct-new (make-dbr:dbstruct)))
+;; (db:open-db dbstruct-new run-id areapath: areapath do-sync: #t)
+;; (hash-table-set! dbstructs dbname dbstruct-new)
+;; dbstruct-new))))
+
+;; ; Returns the dbdat for a particular dbfile inside the area
+;; ;;
+;; (define (dbr:dbstruct-get-dbdat dbstruct dbfile)
+;; (hash-table-ref/default (dbr:dbstruct-dbdats dbstruct) dbfile #f))
+;;
+;; (define (dbr:dbstruct-dbdat-put! dbstruct dbfile db)
+;; (hash-table-set! (dbr:dbstruct-dbdats dbstruct) dbfile db))
+;;
+;; (define (db:run-id->first-num run-id)
+;; (let* ((s (number->string run-id))
+;; (l (string-length s)))
+;; (substring s (- l 1) l)))
+
+;; 1234 => 4/1234.db
+;; #f => 0/main.db
+;; (abandoned the idea of num/db)
+;;
+(define (dbfile:run-id->path apath run-id)
+ (conc apath"/"(dbfile:run-id->dbname run-id)))
+
+(define (db:dbname->path apath dbname)
+ (conc apath"/"dbname))
+
+(define (dbfile:run-id->dbname run-id)
+ (cond
+ ((number? run-id) (conc ".db/" (modulo run-id 100) ".db"))
+ ((not run-id) (conc ".db/main.db"))
+ (else run-id)))
+
+;; Make the dbstruct, setup up auxillary db's and call for main db at least once
+;;
+;; called in http-transport and replicated in rmt.scm for *local* access.
+;;
+(define (dbfile:setup do-sync areapath tmppath)
+ (cond
+ (*dbstruct-dbs* *dbstruct-dbs*);; TODO: when multiple areas are supported, this optimization will be a hazard
+ (else ;;(common:on-homehost?)
+ (let* ((dbstruct (make-dbr:dbstruct)))
+ #;(when (not *toppath*)
+ (debug:print-info 0 *default-log-port* "in db:setup, *toppath* not set; calling launch:setup")
+ (launch:setup areapath: areapath))
+ (set! *dbstruct-dbs* dbstruct)
+ (dbr:dbstruct-areapath-set! dbstruct areapath)
+ (dbr:dbstruct-tmppath-set! dbstruct tmppath)
+ dbstruct))))
+
+#;(define (dbfile:get-subdb dbstruct run-id)
+ (let* ((res (hash-table-ref/default (dbr:dbstruct-subdbs dbstruct) (dbfile:run-id->key run-id) #f)))
+ (if res
+ res
+ (let* ((newsubdb (make-dbr:subdb)))
+ (db:open-db newsubdb run-id areapath: (dbr:dbstruct-areapath dbstruct) do-sync: #t)
+ (hash-table-set! (dbr:dbstruct-subdbs dbstruct) (dbfile:run-id->key run-id) newsubdb)
+ newsubdb))))
+
+(define (dbfile:get-subdb dbstruct run-id)
+ (let* ((dbfname (dbfile:run-id->dbname run-id)))
+ (hash-table-ref/default (dbr:dbstruct-subdbs dbstruct) dbfname #f)))
+
+(define (dbfile:set-subdb dbstruct run-id subdb)
+ (hash-table-set! (dbr:dbstruct-subdbs dbstruct) (dbfile:run-id->dbname run-id) subdb))
+
+;; 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 inmem
+;; if db not open, open inmem, rundb and sync then return inmem
+;; inuse gets set automatically for rundb's
+;;
+(define (dbfile:get-dbdat dbstruct run-id)
+ (let* ((subdb (dbfile:get-subdb dbstruct run-id)))
+ (if (stack-empty? (dbr:subdb-dbstack subdb))
+ #f
+ (stack-pop! (dbr:subdb-dbstack subdb)))))
+
+;; return a previously opened db handle to the stack of available handles
+(define (dbfile:add-dbdat dbstruct run-id dbdat)
+ (let* ((subdb (dbfile:get-subdb dbstruct run-id)))
+ (stack-push! (dbr:subdb-dbstack subdb) dbdat)))
+
+;; set up a subdb
+;;
+(define (dbfile:init-subdb dbstruct run-id init-proc)
+ (let* ((dbname (dbfile:run-id->dbname run-id))
+ (areapath (dbr:dbstruct-areapath dbstruct))
+ (tmppath (dbr:dbstruct-tmppath dbstruct))
+ (mtdbpath (dbfile:run-id->path areapath run-id))
+ (tmpdbpath (dbfile:run-id->path tmppath run-id))
+ (mtdbdat (dbfile:open-sqlite3-db mtdbpath init-proc))
+ (newsubdb (make-dbr:subdb dbname: dbname
+ mtdbfile: mtdbpath
+ tmpdbfile: tmpdbpath
+ mtdbdat: mtdbdat)))
+ (dbfile:set-subdb dbstruct run-id newsubdb)
+ newsubdb)) ;; return the new subdb - but shouldn't really use it
+
+;; returns dbdat with dbh and dbfilepath
+;; 1. if needed setup the subdb for the given run-id
+;; 2. if there is no existing db handle in the stack
+;; create a new handle and return it (do NOT add
+;; it to the stack).
+;;
+(define (dbfile:open-db dbstruct run-id init-proc)
+ (let* ((subdb (dbfile:get-subdb dbstruct run-id)))
+ (if (not subdb) ;; not yet defined
+ (begin
+ (dbfile:init-subdb dbstruct run-id init-proc)
+ (dbfile:open-db dbstruct run-id init-proc))
+ (let* ((dbdat (dbfile:get-dbdat dbstruct run-id)))
+ (if dbdat
+ dbdat
+ (let* ((tmppath (dbr:dbstruct-tmppath dbstruct))
+ (tmpdbpath (dbfile:run-id->path tmppath run-id)))
+ (dbfile:open-sqlite3-db tmpdbpath init-proc)))))))
+
+;; COMBINE dbfile:open-sqlite-db and dbfile:lock-create-open
+;;
+
+;; Open the classic megatest.db file (defaults to open in toppath)
+;;
+;; NOTE: returns a dbdat not a dbstruct!
+;;
+(define (dbfile:open-sqlite3-db dbpath init-proc)
+ (let* ((dbexists (file-exists? dbpath))
+ (write-access (file-write-access? dbpath))
+ (db (dbfile:cautious-open-database dbpath init-proc))) #;(sqlite3:open-database dbpath)
+ (sqlite3:set-busy-handler! db (sqlite3:make-busy-timeout 10000))
+ ;; (init-proc db)
+ (make-dbr:dbdat dbfile: dbpath dbh: db read-only: (not write-access))))
+
+(define (dbfile:print-and-exit . params)
+ (with-output-to-port
+ (current-error-port)
+ (lambda ()
+ (apply print params)))
+ (exit 1))
+
+(define (dbfile:print-err . params)
+ (with-output-to-port
+ (current-error-port)
+ (lambda ()
+ (apply print params))))
+
+;; open an sql database inside a file lock
+;; returns: db existed-prior-to-opening
+;; RA => Returns a db handler; sets the lock if opened in writable mode
+;;
+;; (define *db-open-mutex* (make-mutex))
+;;
+#;(define (dbfile:lock-create-open fname initproc)
+ (let* ((parent-dir (or (pathname-directory fname)(current-directory))) ;; no parent? go local
+ (raw-fname (pathname-file fname))
+ (dir-writable (file-write-access? parent-dir))
+ (file-exists (file-exists? fname))
+ (file-write (if file-exists
+ (file-write-access? fname)
+ dir-writable )))
+ ;; (mutex-lock! *db-open-mutex*) ;; tried this mutex, not clear it helped.
+ (if file-write ;; dir-writable
+ (condition-case
+ (let* ((lockfname (conc fname ".lock"))
+ (readyfname (conc parent-dir "/.ready-" raw-fname))
+ (readyexists (common:file-exists? readyfname)))
+ (if (not readyexists)
+ (common:simple-file-lock-and-wait lockfname))
+ (let ((db (sqlite3:open-database fname)))
+ (sqlite3:set-busy-handler! db (sqlite3:make-busy-timeout 136000))
+ (sqlite3:execute db "PRAGMA synchronous = 0;")
+ (if (not file-exists)
+ (initproc db))
+ (if (not readyexists)
+ (begin
+ (common:simple-file-release-lock lockfname)
+ (with-output-to-file
+ readyfname
+ (lambda ()
+ (print "Ready at "
+ (seconds->year-work-week/day-time
+ (current-seconds)))))))
+ db))
+ (exn (io-error) (dbfile:print-and-exit "ERROR: i/o error with " fname ". Check permissions, disk space etc. and try again."))
+ (exn (corrupt) (dbfile:print-and-exit "ERROR: database " fname " is corrupt. Repair it to proceed."))
+ (exn (busy) (dbfile:print-and-exit "ERROR: database " fname " is locked. Try copying to another location, remove original and copy back."))
+ (exn (permission)(dbfile:print-and-exit "ERROR: database " fname " has some permissions problem."))
+ (exn () (dbfile:print-and-exit "ERROR: Unknown error with database " fname " message: " ((condition-property-accessor 'exn 'message) exn))))
+
+ (condition-case
+ (begin
+ (dbfile:print-err "WARNING: opening db in non-writable dir " fname)
+ (let ((db (sqlite3:open-database fname)))
+ (sqlite3:set-busy-handler! db (sqlite3:make-busy-timeout 136000))
+ (sqlite3:execute db "PRAGMA synchronous = 0;")
+ ;; (mutex-unlock! *db-open-mutex*)
+ db))
+ (exn (io-error)
+ (dbfile:print-and-exit
+ "ERROR: i/o error with " fname ". Check permissions, disk space etc. and try again."))
+ (exn (corrupt)
+ (dbfile:print-and-exit
+ "ERROR: database " fname " is corrupt. Repair it to proceed."))
+ (exn (busy)
+ (dbfile:print-and-exit
+ "ERROR: database " fname " is locked. Try copying to another location, remove original and copy back."))
+ (exn (permission)
+ (dbfile:print-and-exit
+ "ERROR: database " fname " has some permissions problem."))
+ (exn ()
+ (dbfile:print-and-exit
+ "ERROR: Unknown error with database " fname " message: " ((condition-property-accessor 'exn 'message) exn))))
+ )))
+
+
+;; This routine creates the db if not already present. It is only called if the db is not already opened
+;;
+#;(define (db:init-dbstruct dbstruct run-id init-proc #!key (do-sync #t))
+ (let* ((subdb (dbfile:get-subdb dbstruct run-id))
+ (tmpdb-stack (dbr:subdb-dbstack subdb))
+ (max-stale-tmp (dbr:dbstruct-max-stale-secs dbstruct));; (configf:lookup-number *configdat* "server" "filling-db-max-stale-seconds" default: 10))
+ (dbpath (dbr:dbstruct-tmppath dbstruct)) ;; (db:dbfile-path)) ;; path to tmp db area
+ (dbname (dbfile:run-id->dbname run-id))
+ (dbexists (file-exists? dbpath))
+ (areapath (dbr:dbstruct-areapath dbstruct))
+ (mtdbfname (conc areapath "/"dbname))
+ (mtdbexists (file-exists? mtdbfname))
+ (mtdbmodtime (if mtdbexists (dbfile:lazy-sqlite-db-modification-time mtdbfname) #f))
+ (mtdb (db:open-sqlite-db mtdbfname init-proc))
+ ;; the reference db for syncing
+ (refdbfname (conc dbpath "/"dbname"_ref"))
+ (refndb (db:open-megatest-db refdbfname))
+ ;; (mtdbpath (dbr:dbdat-dbfile mtdb))
+ ;; the tmpdb
+ (tmpdbfname (conc dbpath"/"dbname)) ;; /tmp//.db/[main|1,2...].db
+ (tmpdb (db:open-megatest-db tmpdbfname)) ;; lock-create-open dbpath db:initialize-main-db))
+ (dbfexists (common:file-exists? tmpdbfname)) ;; (conc dbpath "/megatest.db")))
+ (tmpdbmodtime (if dbfexists (common:lazy-sqlite-db-modification-time tmpdbfname) #f))
+
+ (write-access (file-write-access? mtdbfname))
+
+ ;; (mtdbmodtime (if mtdbexists
+ ;; (common:lazy-sqlite-db-modification-time mtdbpath)
+ ;; #f)) ; moving this before db:open-megatest-db is
+ ;; called. if wal mode is on -WAL and -shm file get
+ ;; created with causing the tmpdbmodtime timestamp
+ ;; always greater than mtdbmodtime (tmpdbmodtime (if
+ ;; dbfexists (common:lazy-sqlite-db-modification-time
+ ;; tmpdbfname) #f)) if wal mode is on -WAL and -shm
+ ;; file get created when db:open-megatest-db is
+ ;; called. modtimedelta will always be < 10 so db in
+ ;; tmp not get synced (tmpdbmodtime (if dbfexists
+ ;; (db:get-last-update-time (car tmpdb)) #f)) (fmt
+ ;; (file-modification-time tmpdbfname))
+
+ (modtimedelta (and mtdbmodtime tmpdbmodtime (- mtdbmodtime tmpdbmodtime))))
+
+ (when write-access
+ (sqlite3:execute (dbr:dbdat-dbh mtdb) "drop trigger if exists update_tests_trigger")
+ (sqlite3:execute (dbr:dbdat-dbh mtdb) "drop trigger if exists update_runs_trigger"))
+
+ ;; (print "mtdbmodtime " mtdbmodtime " tmpdbmodtime " tmpdbmodtime " mtdbpath " mtdbpath " " (conc *toppath* "/megatest.db"))
+ ;; (debug:print-info 13 *default-log-port* "db:open-db>> mtdbpath="mtdbpath" mtdbexists="mtdbexists" and write-access="write-access)
+ (if (and dbexists (not write-access))
+ (begin
+ (set! *db-write-access* #f)
+ (dbr:subdb-read-only-set! subdb #t)))
+ (dbr:subdb-mtdb-set! subdb mtdb)
+ (dbr:subdb-tmpdb-set! subdb tmpdb)
+ (dbr:subdb-dbstack-set! subdb (make-stack)) ;; BB: why a stack? Why would the number of db's be indeterminate? Is this a legacy of 1.db 2.db .. ?
+ (stack-push! (dbr:subdb-dbstack subdb) tmpdb) ;; olddb is already a (cons db path)
+ (dbr:subdb-refndb-set! subdb refndb)
+ (if (and (or (not dbfexists)
+ (and modtimedelta
+ (> modtimedelta max-stale-tmp))) ;; if db in tmp is over ten seconds older than the file in MTRA then do a sync back
+ do-sync)
+ (begin
+ (dbfile:print-err "filling db " (dbr:dbdat-dbfile tmpdb) " with data \n from " (dbr:dbdat-dbfile mtdb) " mod time delta: " modtimedelta)
+ (db:sync-tables (db:sync-all-tables-list subdb) #f mtdb refndb tmpdb)
+ ;; touch tmp db to avoid wal mode wierdness
+ (set! (file-modification-time tmpdbfname) (current-seconds))
+ (dbfile:print-err "INFO: db:sync-all-tables-list done.")
+ )
+ (dbfile:print-err " db, " (dbr:dbdat-dbfile tmpdb) " already exists or fresh enough, not propogating data from\n " (dbr:dbdat-dbfile mtdb) " mod time delta: " modtimedelta) )
+ ;; (db:multi-db-sync subdb 'old2new)) ;; migrate data from megatest.db automatically
+ tmpdb))
+
+;;======================================================================
+;; no-sync.db - small bits of data to be shared between servers
+;;======================================================================
+
+;; if we are not a server create a db handle. this is not finalized
+;; so watch for problems. I'm still not clear if it is needed to manually
+;; finalize sqlite3 dbs with the sqlite3 egg.
+;;
+
+(define (dbfile:cautious-open-database fname init-proc #!optional (tries-left 10))
+ (let* ((lock-file (conc fname".lock"))
+ (retry (lambda ()
+ (thread-sleep! 1.1)
+ (if (> tries-left 0)
+ (dbfile:cautious-open-database fname init-proc (- tries-left 1))))))
+ (assert (>= tries-left 0) (conc "FATAL: Five attempts in dbfile:cautious-open-database of "fname", giving up."))
+ (if (and (file-write-access? fname) (not (dbfile:simple-file-lock lock-file)))
+ (begin
+ (dbfile:print-err "INFO: lock file "lock-file" exists, trying again in 1 second.")
+ (thread-sleep! 1)
+ (dbfile:cautious-open-database fname init-proc (- tries-left 1)))
+ (let* ((db-exists (file-exists? fname))
+ (result (condition-case
+ (let* ((db (sqlite3:open-database fname)))
+ (if (and init-proc (not db-exists))
+ (init-proc db))
+ db)
+ (exn (io-error)
+ (dbfile:print-err exn "ERROR: i/o error with " fname ". Check permissions, disk space etc. and try again.")
+ (retry))
+ (exn (corrupt)
+ (dbfile:print-err exn "ERROR: database " fname " is corrupt. Repair it to proceed.")
+ (retry))
+ (exn (busy)
+ (dbfile:print-err exn "ERROR: database " fname
+ " is locked. Try copying to another location, remove original and copy back.")
+ (retry))
+ (exn (permission)(dbfile:print-err exn "ERROR: database " fname " has some permissions problem.")
+ (retry))
+ (exn ()
+ (dbfile:print-err exn "ERROR: Unknown error with database " fname " message: "
+ ((condition-property-accessor 'exn 'message) exn))
+ (retry)))))
+ (if (file-write-access? fname)
+ (dbfile:simple-file-release-lock lock-file)
+ )
+ result))))
+
+
+(define (dbfile:open-no-sync-db dbpath)
+ (if *no-sync-db*
+ *no-sync-db*
+ (begin
+ (if (not (file-exists? dbpath))
+ (create-directory dbpath #t))
+ (let* ((dbname (conc dbpath "/no-sync.db"))
+ (db-exists (file-exists? dbname))
+ (init-proc (lambda (db)
+ (if (not db-exists)
+ (begin
+ (sqlite3:execute db "PRAGMA synchronous = 0;")
+ (sqlite3:execute db "CREATE TABLE IF NOT EXISTS no_sync_metadat (var TEXT,val TEXT, CONSTRAINT no_sync_metadat_constraint UNIQUE (var));"))
+ )))
+ (db (dbfile:cautious-open-database dbname init-proc))) ;; (sqlite3:open-database dbname)))
+ (sqlite3:set-busy-handler! db (sqlite3:make-busy-timeout 136000))
+ ;;(sqlite3:execute db "PRAGMA journal_mode=WAL;")
+ (set! *no-sync-db* db)
+ db))))
+
+(define (db:no-sync-set db var val)
+ (sqlite3:execute db "INSERT OR REPLACE INTO no_sync_metadat (var,val) VALUES (?,?);" var val))
+
+(define (db:no-sync-del! db var)
+ (sqlite3:execute db "DELETE FROM no_sync_metadat WHERE var=?;" var))
+
+(define (db:no-sync-get/default db var default)
+ (let ((res default))
+ (sqlite3:for-each-row
+ (lambda (val)
+ (set! res val))
+ db
+ "SELECT val FROM no_sync_metadat WHERE var=?;"
+ var)
+ (if res
+ (let ((newres (if (string? res)
+ (string->number res)
+ #f)))
+ (if newres
+ newres
+ res))
+ res)))
+
+;; transaction protected lock aquisition
+;; either:
+;; fails returns (#f . lock-creation-time)
+;; succeeds (returns (#t . lock-creation-time)
+;; use (db:no-sync-del! db keyname) to release the lock
+;;
+(define (db:no-sync-get-lock db keyname)
+ (sqlite3:with-transaction
+ db
+ (lambda ()
+ (handle-exceptions
+ exn
+ (let ((lock-time (current-seconds)))
+ ;; (debug:print-info 2 *default-log-port* "db:no-sync-get-lock keyname=" keyname ", lock-time=" lock-time ", exn=" exn)
+ (sqlite3:execute db "INSERT INTO no_sync_metadat (var,val) VALUES(?,?);" keyname lock-time)
+ `(#t . ,lock-time))
+ `(#f . ,(sqlite3:first-result db "SELECT val FROM no_sync_metadat WHERE var=?;" keyname))))))
+
+
+;;======================================================================
+;; file utils
+;;======================================================================
+
+;;======================================================================
+;; lazy-safe get file mod time. on any error (file not existing etc.) return 0
+;;
+(define (dbfile:lazy-modification-time fpath)
+ (handle-exceptions
+ exn
+ (begin
+ (dbfile:print-err "Failed to get modification time for " fpath ", treating it as zero. exn=" exn)
+ 0)
+ (if (file-exists? fpath)
+ (file-modification-time fpath)
+ 0)))
+
+;;======================================================================
+;; find timestamp of newest file associated with a sqlite db file
+(define (dbfile:lazy-sqlite-db-modification-time fpath)
+ (let* ((glob-list (handle-exceptions
+ exn
+ (begin
+ (dbfile:print-err "Failed to glob " fpath "*, exn=" exn)
+ `(,(conc "/no/such/file, message: " ((condition-property-accessor 'exn 'message) exn))))
+ (glob (conc fpath "*"))))
+ (file-list (if (eq? 0 (length glob-list))
+ '("/no/such/file")
+ glob-list)))
+ (apply max
+ (map
+ dbfile:lazy-modification-time
+ file-list))))
+
+;; dot-locking egg seems not to work, using this for now
+;; if lock is older than expire-time then remove it and try again
+;; to get the lock
+;;
+(define (dbfile:simple-file-lock fname #!key (expire-time 300))
+ (let ((fmod-time (handle-exceptions
+ ext
+ (current-seconds)
+ (file-modification-time fname))))
+ (if (file-exists? fname)
+ (if (> (- (current-seconds) fmod-time) expire-time)
+ (begin
+ (handle-exceptions exn #f (delete-file* fname))
+ (dbfile:simple-file-lock fname expire-time: expire-time))
+ #f)
+ (let ((key-string (conc (get-host-name) "-" (current-process-id)))
+ (oup (open-output-file fname)))
+ (with-output-to-port
+ oup
+ (lambda ()
+ (print key-string)))
+ (close-output-port oup)
+ #;(with-output-to-file fname ;; bizarre. with-output-to-file does not seem to be cleaning up after itself.
+ (lambda ()
+ (print key-string)))
+ (thread-sleep! 0.25)
+ (if (file-exists? fname)
+ (handle-exceptions exn
+ #f
+ (with-input-from-file fname
+ (lambda ()
+ (equal? key-string (read-line)))))
+ #f)
+ )
+ )
+ )
+)
+
+(define (dbfile:simple-file-lock-and-wait fname #!key (expire-time 300))
+ (let ((end-time (+ expire-time (current-seconds))))
+ (let loop ((got-lock (dbfile:simple-file-lock fname expire-time: expire-time)))
+ (if got-lock
+ #t
+ (if (> end-time (current-seconds))
+ (begin
+ (thread-sleep! 3)
+ (loop (dbfile:simple-file-lock fname expire-time: expire-time)))
+ #f)))))
+
+(define (dbfile:simple-file-release-lock fname)
+ (handle-exceptions
+ exn
+ #f ;; I don't really care why this failed (at least for now)
+ (delete-file* fname)))
+
+
+)
ADDED debugprint.scm
Index: debugprint.scm
==================================================================
--- /dev/null
+++ debugprint.scm
@@ -0,0 +1,175 @@
+
+(declare (unit debugprint))
+(declare (uses mtargs))
+
+(module debugprint
+ *
+
+;;(import scheme chicken data-structures extras files ports)
+ (import
+ scheme
+ chicken
+ data-structures
+ posix
+ ports
+ extras
+
+ ;; scheme
+ ;; chicken.base
+ ;; chicken.string
+ ;; chicken.time
+ ;; chicken.time.posix
+ ;; chicken.port
+ ;; chicken.process-context
+ ;; chicken.process-context.posix
+
+ (prefix mtargs args:)
+ srfi-1
+ ;; system-information
+ )
+
+;;======================================================================
+;; debug stuff
+;;======================================================================
+
+(define verbosity (make-parameter '()))
+(define *default-log-port* (current-error-port))
+(define debug:print-logger (make-parameter #f)) ;; set to a proc to call on every logging print
+
+(define (debug:setup)
+ (let ((debugstr (or (args:get-arg "-debug")
+ (args:get-arg "-debug-noprop")
+ (get-environment-variable "MT_DEBUG_MODE"))))
+ (verbosity (debug:calc-verbosity debugstr 'q))
+ (debug:check-verbosity (verbosity) debugstr)
+ ;; if we were handed a bad verbosity rule then we will override it with 1 and continue
+ (if (not (verbosity))(verbosity 1))
+ (if (and (not (args:get-arg "-debug-noprop"))
+ (or (args:get-arg "-debug")
+ (not (get-environment-variable "MT_DEBUG_MODE"))))
+ (setenv #;set-environment-variable! "MT_DEBUG_MODE" (if (list? (verbosity))
+ (string-intersperse (map conc (verbosity)) ",")
+ (conc (verbosity)))))))
+
+;; check verbosity, #t is ok
+(define (debug:check-verbosity verbosity vstr)
+ (if (not (or (number? verbosity)
+ (list? verbosity)))
+ (begin
+ (print "ERROR: Invalid debug value \"" vstr "\"")
+ #f)
+ #t))
+
+;;======================================================================
+;; (define (debug:print . params) #f)
+;; (define (debug:print-info . params) #f)
+;;
+;; (define (set-functions dbgp dbgpinfo)
+;; (set! debug:print dbgp)
+;; (set! debug:print-info dbgpinfo))
+
+;;======================================================================
+;; this was cached based on results from profiling but it turned out the profiling
+;; somehow went wrong - perhaps too many processes writing to it. Leaving the caching
+;; in for now but can probably take it out later.
+;;
+(define (debug:calc-verbosity vstr arg) ;; arg is 'v (verbose) or 'q (quiet)
+ (let* ((res (cond
+ ((number? vstr) vstr)
+ ((not (string? vstr)) 1)
+ ;; ((string-match "^\\s*$" vstr) 1)
+ (vstr (let ((debugvals (filter number? (map string->number (string-split vstr ",")))))
+ (cond
+ ((> (length debugvals) 1) debugvals)
+ ((> (length debugvals) 0)(car debugvals))
+ (else 1))))
+ ((eq? arg 'v) 2) ;; verbose
+ ((eq? arg 'q) 0) ;; quiet
+ (else 1))))
+ (verbosity res)
+ res))
+
+;;======================================================================
+;; check verbosity, #t is ok
+#;(define (debug-check-verbosity verbosity vstr)
+ (if (not (or (number? verbosity)
+ (list? verbosity)))
+ (begin
+ (print "ERROR: Invalid debug value \"" vstr "\"")
+ #f)
+ #t))
+
+(define (debug:debug-mode n)
+ (let* ((vb (verbosity)))
+ (cond
+ ((and (number? vb) ;; number number
+ (number? n))
+ (<= n vb))
+ ((and (list? vb) ;; list number
+ (number? n))
+ (member n vb))
+ ((and (list? vb) ;; list list
+ (list? n))
+ (not (null? (lset-intersection! eq? vb n))))
+ ((and (number? vb)
+ (list? n))
+ (member vb n))
+ (else #f))))
+
+(define (debug:handle-remote-logging params)
+ (if (debug:print-logger) ;; NOTE: turn params into string to keep things simple for now
+ ((debug:print-logger)(conc "REMOTE ("(get-host-name)", pid="(current-process-id)") "
+ (string-intersperse (map conc params) " ") "; "
+ (string-intersperse (command-line-arguments) " ")))))
+
+(define debug:enable-timestamp (make-parameter #t))
+
+(define (debug:timestamp)
+ (if (debug:enable-timestamp)
+ (conc (time->string
+ (seconds->local-time (current-seconds)) "%H:%M:%S") " ")
+ ""))
+
+ (define (debug:print n e . params)
+ (if (debug:debug-mode n)
+ (with-output-to-port (or e (current-error-port))
+ (lambda ()
+ ;; (if *logging*
+ ;; (db:log-event (apply conc params))
+ (apply print (debug:timestamp) params)
+ ;; (debug:handle-remote-logging params)
+ )))
+ #t ;; only here to make remote stuff happy. It'd be nice to fix that ...
+ )
+
+(define (debug:print-error n e . params)
+ ;; normal print
+ (if (debug:debug-mode n)
+ (with-output-to-port (if (port? e) e (current-error-port))
+ (lambda ()
+ (apply print "ERROR: " (debug:timestamp) params)
+ ;; (debug:handle-remote-logging (cons "ERROR: " params))
+ )))
+ ;; pass important messages to stderr
+ (if (and (eq? n 0)(not (eq? e (current-error-port))))
+ (with-output-to-port (current-error-port)
+ (lambda ()
+ (apply print "ERROR: " (debug:timestamp) params)
+ ))))
+
+(define (debug:print-info n e . params)
+ (if (debug:debug-mode n)
+ (with-output-to-port (if (port? e) e (current-error-port))
+ (lambda ()
+ (apply print "INFO: (" n ") "(debug:timestamp) params) ;; res)
+ ;; (debug:handle-remote-logging (cons "INFO: " params))
+ ))))
+
+(define (debug:print-warn n e . params)
+ (if (debug:debug-mode n)
+ (with-output-to-port (if (port? e) e (current-error-port))
+ (lambda ()
+ (apply print "WARN: (" n ") " (debug:timestamp) params) ;; res)
+ ;; (debug:handle-remote-logging (cons "WARN: " params))
+ ))))
+)
DELETED filedb.scm
Index: filedb.scm
==================================================================
--- filedb.scm
+++ /dev/null
@@ -1,255 +0,0 @@
-;; Copyright 2006-2011, 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 .
-;;
-
-;; (require-extension synch sqlite3 posix srfi-13 srfi-1 utils regex)
-(use sqlite3 srfi-1 posix regex srfi-69 srfi-13 posix-extras)
-(import (prefix sqlite3 sqlite3:))
-
-(declare (unit filedb))
-
-(include "fdb_records.scm")
-;; (include "settings.scm")
-
-(define (filedb:open-db dbpath)
- (let* ((fdb (make-filedb:fdb))
- (dbexists (common:file-exists? dbpath))
- (db (sqlite3:open-database dbpath)))
- (filedb:fdb-set-db! fdb db)
- (filedb:fdb-set-dbpath! fdb dbpath)
- (filedb:fdb-set-pathcache! fdb (make-hash-table))
- (filedb:fdb-set-idcache! fdb (make-hash-table))
- (filedb:fdb-set-partcache! fdb (make-hash-table))
- (sqlite3:set-busy-handler! db (make-busy-timeout 136000))
- (if (not dbexists)
- (begin
- (sqlite3:execute db "PRAGMA synchronous = OFF;")
- (sqlite3:execute db "CREATE TABLE names (id INTEGER PRIMARY KEY,name TEST);") ;; for future use - change path in paths table to path_id
- (sqlite3:execute db "CREATE INDEX name_index ON names (name);")
- ;; NB// We store a useful subset of file attributes but do not attempt to store all
- (sqlite3:execute db "CREATE TABLE paths (id INTEGER PRIMARY KEY,
- path TEXT,
- parent_id INTEGER,
- mode INTEGER DEFAULT -1,
- uid INTEGER DEFAULT -1,
- gid INTEGER DEFAULT -1,
- size INTEGER DEFAULT -1,
- mtime INTEGER DEFAULT -1);")
- (sqlite3:execute db "CREATE INDEX path_index ON paths (path,parent_id);")
- (sqlite3:execute db "CREATE TABLE bases (id INTEGER PRIMARY KEY,base TEXT, updated TIMESTAMP);")))
- ;; close the sqlite3 db and open it as needed
- (filedb:finalize-db! fdb)
- (filedb:fdb-set-db! fdb #f)
- fdb))
-
-(define (filedb:reopen-db fdb)
- (let ((db (sqlite3:open-database (filedb:fdb-get-dbpath fdb))))
- (filedb:fdb-set-db! fdb db)
- (sqlite3:set-busy-handler! db (make-busy-timeout 136000))))
-
-(define (filedb:finalize-db! fdb)
- (sqlite3:finalize! (filedb:fdb-get-db fdb)))
-
-(define (filedb:get-current-time-string)
- (string-chomp (time->string (seconds->local-time (current-seconds)))))
-
-(define (filedb:get-base-id db path)
- (let ((stmt (sqlite3:prepare db "SELECT id FROM bases WHERE base=?;"))
- (id-num #f))
- (sqlite3:for-each-row
- (lambda (num) (set! id-num num)) stmt path)
- (sqlite3:finalize! stmt)
- id-num))
-
-(define (filedb:get-path-id db path parent)
- (let ((stmt (sqlite3:prepare db "SELECT id FROM paths WHERE path=? AND parent_id=?;"))
- (id-num #f))
- (sqlite3:for-each-row
- (lambda (num) (set! id-num num)) stmt path parent)
- (sqlite3:finalize! stmt)
- id-num))
-
-(define (filedb:add-base db path)
- (let ((existing (filedb:get-base-id db path)))
- (if existing #f
- (begin
- (sqlite3:execute db "INSERT INTO bases (base,updated) VALUES (?,?);" path (filedb:get-current-time-string))))))
-
-;; index value field notes
-;; 0 inode number st_ino
-;; 1 mode st_mode bitfield combining file permissions and file type
-;; 2 number of hard links st_nlink
-;; 3 UID of owner st_uid as with file-owner
-;; 4 GID of owner st_gid
-;; 5 size st_size as with file-size
-;; 6 access time st_atime as with file-access-time
-;; 7 change time st_ctime as with file-change-time
-;; 8 modification time st_mtime as with file-modification-time
-;; 9 parent device ID st_dev ID of device on which this file resides
-;; 10 device ID st_rdev device ID for special files (i.e. the raw major/minor number)
-;; 11 block size st_blksize
-;; 12 number of blocks allocated st_blocks
-
-(define (filedb:add-path-stat db path parent statinfo)
- (let ((stmt (sqlite3:prepare db "INSERT INTO paths (path,parent_id,mode,uid,gid,size,mtime) VALUES (?,?,?,?,?,?,?);")))
- (sqlite3:execute stmt
- path
- parent
- (vector-ref statinfo 1) ;; mode
- (vector-ref statinfo 3) ;; uid
- (vector-ref statinfo 4) ;; gid
- (vector-ref statinfo 5) ;; size
- (vector-ref statinfo 8) ;; mtime
- )
- (sqlite3:finalize! stmt))) ;; (filedb:get-current-time-string))))
-
-(define (filedb:add-path db path parent)
- (let ((stmt (sqlite3:prepare db "INSERT INTO paths (path,parent_id) VALUES (?,?);")))
- (sqlite3:execute stmt path parent)
- (sqlite3:finalize! stmt)))
-
-(define (filedb:register-path fdb path #!key (save-stat #f))
- (let* ((db (filedb:fdb-get-db fdb))
- (pathcache (filedb:fdb-get-pathcache fdb))
- (stat (if save-stat (file-stat path #t)))
- (id (hash-table-ref/default pathcache path #f)))
- (if (not db)(filedb:reopen-db fdb))
- (if id id
- (let ((plist (string-split path "/")))
- (let loop ((head (car plist))
- (tail (cdr plist))
- (parent 0))
- (let ((id (filedb:get-path-id db head parent))
- (done (null? tail)))
- (if id ;; we'll have a id if the path is already registered
- (if done
- (begin
- (hash-table-set! pathcache path id)
- id) ;; return the last path id for a result
- (loop (car tail)(cdr tail) id))
- (begin ;; add the path and then repeat the loop with the same data
- (if save-stat
- (filedb:add-path-stat db head parent stat)
- (filedb:add-path db head parent))
- (loop head tail parent)))))))))
-
-(define (filedb:update-recursively fdb path #!key (save-stat #f))
- (let ((p (open-input-pipe (string-append "find -L " path)))) ;; (resolve-pathname path)))) ;; (string-append "find " path))))
- (print "processed 0 files...")
- (let loop ((l (read-line p))
- (lc 0)) ;; line count
- (if (eof-object? l)
- (begin
- (print " " lc " files")
- (close-input-port p))
- (begin
- (filedb:register-path fdb l save-stat: save-stat) ;; (get-real-path l)) ;; don't like losing the original path info
- (if (= (modulo lc 100) 0)
- (print " " lc " files"))
- (loop (read-line p)(+ lc 1)))))))
-
-(define (filedb:update fdb path #!key (save-stat #f))
- ;; first get the realpath and add it to the bases table
- (let ((real-path path) ;; (filedb:get-real-path path))
- (db (filedb:fdb-get-db fdb)))
- (filedb:add-base db real-path)
- (filedb:update-recursively fdb path save-stat: save-stat)))
-
-;; not used and broken
-;;
-(define (filedb:get-real-path path)
- (let* ((p (open-input-pipe (string-append real-path " " (regexp-escape path))))
- (pth (read-line p)))
- (if (eof-object? pth) path
- (begin
- (close-input-port p)
- pth))))
-
-(define (filedb:drop-base fdb path)
- (print "Sorry, I don't do anything yet"))
-
-(define (filedb:find-all fdb pattern action)
- (let* ((db (filedb:fdb-get-db fdb))
- (stmt (sqlite3:prepare db "SELECT id FROM paths WHERE path like ?;"))
- (result '()))
- (sqlite3:for-each-row
- (lambda (num)
- (action num)
- (set! result (cons num result))) stmt pattern)
- (sqlite3:finalize! stmt)
- result))
-
-(define (filedb:get-path-record fdb id)
- (let* ((db (filedb:fdb-get-db fdb))
- (partcache (filedb:fdb-get-partcache fdb))
- (dat (hash-table-ref/default partcache id #f)))
- (if dat dat
- (let ((stmt (sqlite3:prepare db "SELECT path,parent_id FROM paths WHERE id=?;"))
- (result #f))
- (sqlite3:for-each-row
- (lambda (path parent_id)(set! result (list path parent_id))) stmt id)
- (hash-table-set! partcache id result)
- (sqlite3:finalize! stmt)
- result))))
-
-(define (filedb:get-children fdb parent-id)
- (let* ((db (filedb:fdb-get-db fdb))
- (res '()))
- (sqlite3:for-each-row
- (lambda (id path parent-id)
- (set! res (cons (vector id path parent-id) res)))
- db "SELECT id,path,parent_id FROM paths WHERE parent_id=?;"
- parent-id)
- res))
-
-;; retrieve all that have children and those without
-;; children that match patt
-(define (filedb:get-children-patt fdb parent-id search-patt)
- (let* ((db (filedb:fdb-get-db fdb))
- (res '()))
- ;; first get the children that have no children
- (sqlite3:for-each-row
- (lambda (id path parent-id)
- (set! res (cons (vector id path parent-id) res)))
- db "SELECT id,path,parent_id FROM paths WHERE parent_id=? AND
- (id IN (SELECT parent_id FROM paths) OR path LIKE ?);"
- parent-id search-patt)
- res))
-
-(define (filedb:get-path fdb id)
- (let* ((db (filedb:fdb-get-db fdb))
- (idcache (filedb:fdb-get-idcache fdb))
- (path (hash-table-ref/default idcache id #f)))
- (if (not db)(filedb:reopen-db fdb))
- (if path path
- (let loop ((curr-id id)
- (path ""))
- (let ((path-record (filedb:get-path-record fdb curr-id)))
- (if (not path-record) #f ;; this id has no path
- (let* ((parent-id (list-ref path-record 1))
- (pname (list-ref path-record 0))
- (newpath (string-append "/" pname path)))
- (if (= parent-id 0) ;; fields 0=path, 1=parent. root parent=0
- (begin
- (hash-table-set! idcache id newpath)
- newpath)
- (loop parent-id newpath)))))))))
-
-(define (filedb:search db pattern)
- (let ((action (lambda (id)(print (filedb:get-path db id)))))
- (filedb:find-all db pattern action)))
-
DELETED fs-transport.scm
Index: fs-transport.scm
==================================================================
--- fs-transport.scm
+++ /dev/null
@@ -1,52 +0,0 @@
-
-;; Copyright 2006-2012, 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 .
-
-(require-extension (srfi 18) extras tcp s11n)
-
-(use sqlite3 srfi-1 posix regex regex-case srfi-69 hostinfo md5 message-digest)
-(import (prefix sqlite3 sqlite3:))
-
-(use spiffy uri-common intarweb http-client spiffy-request-vars)
-
-(tcp-buffer-size 2048)
-
-(declare (unit fs-transport))
-
-(declare (uses common))
-(declare (uses db))
-(declare (uses tests))
-(declare (uses tasks)) ;; tasks are where stuff is maintained about what is running.
-
-(include "common_records.scm")
-(include "db_records.scm")
-
-
-;;======================================================================
-;; F S T R A N S P O R T S E R V E R
-;;======================================================================
-
-;; There is no "server" per se but a convience routine to make it non
-;; necessary to be reopening the db over and over again.
-;;
-
-(define (fs:process-queue-item packet)
- (if (not *dbstruct-db*) ;; we will require that (setup-for-run) has already been called
- (set! *dbstruct-db* (db:setup-db)))
- (debug:print-info 11 *default-log-port* "fs:process-queue-item called with packet=" packet)
- (db:process-queue-item *dbstruct-db* packet))
-
DELETED ftail.scm
Index: ftail.scm
==================================================================
--- ftail.scm
+++ /dev/null
@@ -1,108 +0,0 @@
-;;======================================================================
-;; 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 .
-
-;;======================================================================
-
-(declare (unit ftail))
-
-(module ftail
- (
- open-tail-db
- tail-write
- tail-get-fid
- file-tail
- )
-
-(import scheme chicken data-structures extras)
-(use (prefix sqlite3 sqlite3:) posix typed-records)
-
-(define (open-tail-db )
- (let* ((basedir (create-directory (conc "/tmp/" (current-user-name))))
- (dbpath (conc basedir "/megatest_logs.db"))
- (dbexists (file-exists? dbpath))
- (db (sqlite3:open-database dbpath))
- (handler (sqlite3:make-busy-timeout 136000)))
- (sqlite3:set-busy-handler! db handler)
- (sqlite3:execute db "PRAGMA synchronous = 0;")
- (if (not dbexists)
- (begin
- (sqlite3:execute db "CREATE TABLE IF NOT EXISTS log_files (id INTEGER PRIMARY KEY,filename TEXT,event_time TIMESTAMP DEFAULT (strftime('%s','now')));")
- (sqlite3:execute db "CREATE TABLE IF NOT EXISTS log_data (id INTEGER PRIMARY KEY,fid INTEGER,line TEXT,event_time TIMESTAMP DEFAULT (strftime('%s','now')));")
- ))
- db))
-
-(define (tail-write db fid lines)
- (sqlite3:with-transaction
- db
- (lambda ()
- (for-each
- (lambda (line)
- (sqlite3:execute db "INSERT INTO log_data (fid,line) VALUES (?,?);" fid line))
- lines))))
-
-(define (tail-get-fid db fname)
- (let ((fid (handle-exceptions
- exn
- #f
- (sqlite3:first-result db "SELECT id FROM log_files WHERE filename=?;" fname))))
- (if fid
- fid
- (begin
- (sqlite3:execute db "INSERT INTO log_files (filename) VALUES (?);" fname)
- (tail-get-fid db fname)))))
-
-(define (file-tail fname #!key (db-in #f))
- (let* ((inp (open-input-file fname))
- (db (or db-in (open-tail-db)))
- (fid (tail-get-fid db fname)))
- (let loop ((inl (read-line inp))
- (lines '())
- (lastwr (current-seconds)))
- (if (eof-object? inl)
- (let ((timed-out (> (- (current-seconds) lastwr) 60)))
- (if timed-out (tail-write db fid (reverse lines)))
- (sleep 1)
- (if timed-out
- (loop (read-line inp) '() (current-seconds))
- (loop (read-line inp) lines lastwr)))
- (let* ((savelines (> (length lines) 19)))
- ;; (print inl)
- (if savelines (tail-write db fid (reverse lines)))
- (loop (read-line inp)
- (if savelines
- '()
- (cons inl lines))
- (if savelines
- (current-seconds)
- lastwr)))))))
-
-;; offset -20 means get last 20 lines
-;;
-(define (tail-get-lines db fid offset count)
- (if (> offset 0)
- (sqlite3:map-row (lambda (id line)
- (vector id line))
- db
- "SELECT id,line FROM log_data WHERE fid=? OFFSET ? LIMIT ?;" fid offset count)
- (reverse ;; get N from the end
- (sqlite3:map-row (lambda (id line)
- (vector id line))
- db
- "SELECT id,line FROM log_data WHERE fid=? ORDER BY id DESC LIMIT ?;" fid (abs offset)))))
-
-)
Index: http-transport.scm
==================================================================
--- http-transport.scm
+++ http-transport.scm
@@ -35,14 +35,17 @@
(declare (uses tasks)) ;; tasks are where stuff is maintained about what is running.
(declare (uses server))
;; (declare (uses daemon))
(declare (uses portlogger))
(declare (uses rmt))
+(declare (uses dbfile))
(include "common_records.scm")
(include "db_records.scm")
(include "js-path.scm")
+
+(import dbfile)
(require-library stml)
(define (http-transport:make-server-url hostport)
(if (not hostport)
#f
@@ -97,11 +100,11 @@
(dat ($ 'dat))
(res #f))
(cond
((equal? (uri-path (request-uri (current-request)))
'(/ "api"))
- (send-response body: (api:process-request *dbstruct-db* $) ;; the $ is the request vars proc
+ (send-response body: (api:process-request *dbstruct-dbs* $) ;; the $ is the request vars proc
headers: '((content-type text/plain)))
(mutex-lock! *heartbeat-mutex*)
(set! *db-last-access* (current-seconds))
(mutex-unlock! *heartbeat-mutex*))
((equal? (uri-path (request-uri (current-request)))
@@ -171,13 +174,13 @@
(debug:print 0 *default-log-port* "INFO: Trying to start server on " ipaddrstr ":" portnum)
;; This starts the spiffy server
;; NEED WAY TO SET IP TO #f TO BIND ALL
;; (start-server bind-address: ipaddrstr port: portnum)
(if config-hostname ;; this is a hint to bind directly
- (start-server port: portnum bind-address: (if (equal? config-hostname "-")
- ipaddrstr
- config-hostname))
+ (start-server port: portnum) ;; bind-address: (if (equal? config-hostname "-")
+ ;; ipaddrstr
+ ;; config-hostname))
(start-server port: portnum))
(portlogger:open-run-close portlogger:set-port portnum "released")
(debug:print 1 *default-log-port* "INFO: server has been stopped"))))
;;======================================================================
@@ -400,10 +403,11 @@
;; if none running or if > 20 seconds since
;; server last used then start shutdown
;; This thread waits for the server to come alive
(debug:print-info 0 *default-log-port* "Starting the sync-back, keep alive thread in server")
(let* ((sdat #f)
+ (no-sync-db (db:open-no-sync-db))
(tmp-area (common:get-db-tmp-area))
(started-file (conc tmp-area "/.server-started"))
(server-start-time (current-seconds))
(server-info (let loop ((start-time (current-seconds))
(changed #t)
@@ -457,18 +461,29 @@
(let loop ((count 0)
(server-state 'available)
(bad-sync-count 0)
(start-time (current-milliseconds)))
+
;; Use this opportunity to sync the tmp db to megatest.db
- (if (not server-going) ;; *dbstruct-db*
+ (if (not server-going) ;; *dbstruct-dbs*
(begin
(debug:print 0 *default-log-port* "SERVER: dbprep")
- (set! *dbstruct-db* (db:setup #t)) ;; run-id))
+ (set! *dbstruct-dbs* (db:setup #t)) ;; run-id)) FIXME!!!
(set! server-going #t)
(debug:print 0 *default-log-port* "SERVER: running, megatest version: " (common:get-full-version)) ;; NOTE: the server is NOT yet marked as running in the log. We do that in the keep-running routine.
- (thread-start! *watchdog*)))
+
+ ;; (thread-start! *watchdog*)
+ )
+ (if *no-sync-db*
+ (begin
+ (debug:print 0 *default-log-port* "keep-running calling db:do-sync at " (time->string (seconds->local-time) "%H:%M:%S"))
+ (db:do-sync)
+ ;; (db:run-lock-and-sync *no-sync-db*)
+ )
+ )
+ )
;; when things go wrong we don't want to be doing the various queries too often
;; so we strive to run this stuff only every four seconds or so.
(let* ((sync-time (- (current-milliseconds) start-time))
(rem-time (quotient (- 4000 sync-time) 1000)))
@@ -490,11 +505,10 @@
(debug:print-info 0 *default-log-port* "WARNING: interface changed, refreshing iface and port info")
(set! iface new-iface)
(set! port new-port)
(if (not *server-id*)
(set! *server-id* (server:mk-signature)))
- (debug:print 0 *default-log-port* (current-seconds) (current-directory) (current-process-id) (argv))
(debug:print 0 *default-log-port* "SERVER STARTED: " iface ":" port " AT " (current-seconds) " server-id: " *server-id*)
(flush-output *default-log-port*)))
;; Transfer *db-last-access* to last-access to use in checking that we are still alive
(mutex-lock! *heartbeat-mutex*)
@@ -502,14 +516,14 @@
(mutex-unlock! *heartbeat-mutex*)
(if (common:low-noise-print 120 (conc "server running on " iface ":" port))
(begin
(if (not *server-id*)
- (set! *server-id* (server:mk-signature)))
- (debug:print 0 *default-log-port* (current-seconds) (current-directory) (current-process-id) (argv))
- (debug:print 0 *default-log-port* "SERVER STARTED: " iface ":" port " AT " (current-seconds) " server-id: " *server-id*)
- (flush-output *default-log-port*)))
+ (set! *server-id* (server:mk-signature)))
+ (debug:print 0 *default-log-port* (current-seconds) (current-directory) (current-process-id) (argv))
+ (debug:print 0 *default-log-port* "SERVER STARTED: " iface ":" port " AT " (current-seconds) " server-id: " *server-id*)
+ (flush-output *default-log-port*)))
(if (common:low-noise-print 60 "dbstats")
(begin
(debug:print 0 *default-log-port* "Server stats:")
(db:print-current-query-stats)))
(let* ((hrs-since-start (/ (- (current-seconds) server-start-time) 3600)))
Index: launch.scm
==================================================================
--- launch.scm
+++ launch.scm
@@ -481,11 +481,11 @@
;; -mrw- I'm removing KILLREQ from this list so that a test in KILLREQ state is treated as a "do not run" flag.
((member (db:test-get-state test-info) '("INCOMPLETE" "KILLED" "UNKNOWN" "STUCK")) ;; prior run of this test didn't complete, go ahead and try to rerun
(debug:print 0 *default-log-port* "INFO: test is INCOMPLETE or KILLED, treat this execute call as a rerun request")
;; (tests:test-force-state-status! run-id test-id "REMOTEHOSTSTART" "n/a")
- (rmt:general-call 'set-test-start-time #f test-id)
+ (rmt:general-call 'set-test-start-time run-id test-id)
(rmt:test-set-state-status run-id test-id "REMOTEHOSTSTART" "n/a" #f)
) ;; prime it for running
((member (db:test-get-state test-info) '("RUNNING" "REMOTEHOSTSTART"))
(if (process:alive-on-host? test-host test-pid)
(debug:print-error 0 *default-log-port* "test state is " (db:test-get-state test-info) " and process " test-pid " is still running on host " test-host ", cannot proceed")
@@ -494,11 +494,11 @@
(debug:print 0 *default-log-port* "test state is " (db:test-get-state test-info) ", cannot proceed")
(debug:print 0 *default-log-port* "exiting with status 1")
(exit 1))
((not (member (db:test-get-state test-info) '("REMOVING" "REMOTEHOSTSTART" "RUNNING" "KILLREQ")))
;; (tests:test-force-state-status! run-id test-id "REMOTEHOSTSTART" "n/a")
- (rmt:general-call 'set-test-start-time #f test-id)
+ (rmt:general-call 'set-test-start-time run-id test-id)
(rmt:test-set-state-status run-id test-id "REMOTEHOSTSTART" "n/a" #f))
(else ;; (member (db:test-get-state test-info) '("REMOVING" "REMOTEHOSTSTART" "RUNNING" "KILLREQ"))
(debug:print 0 *default-log-port* "test state is " (db:test-get-state test-info) ", cannot proceed")
(debug:print 0 *default-log-port* "exiting with status 1")
(exit 1))))
Index: megatest-version.scm
==================================================================
--- megatest-version.scm
+++ megatest-version.scm
@@ -18,6 +18,6 @@
;; Always use two or four digit decimal
;; 1.01, 1.02...1.10,1.11,1.1101 ... 1.99,2.00..
;; (declare (unit megatest-version))
-(define megatest-version 1.6592)
+(define megatest-version 1.7001)
Index: megatest.scm
==================================================================
--- megatest.scm
+++ megatest.scm
@@ -30,21 +30,34 @@
(declare (uses server))
(declare (uses client))
(declare (uses tests))
(declare (uses genexample))
;; (declare (uses daemon))
+
(declare (uses db))
;; (declare (uses dcommon))
(declare (uses tdb))
(declare (uses mt))
(declare (uses api))
(declare (uses tasks)) ;; only used for debugging.
(declare (uses env))
(declare (uses diff-report))
+(declare (uses dbmod))
+(declare (uses dbmod.import))
+(declare (uses dbfile))
+(declare (uses dbfile.import))
+;; (declare (uses debugprint))
+;; (declare (uses debugprint.import))
+;; (declare (uses mtargs))
+;; (declare (uses mtargs.import))
+
;; (declare (uses ftail))
;; (import ftail)
+
+(import dbmod
+ dbfile)
(define *db* #f) ;; this is only for the repl, do not use in general!!!!
(include "common_records.scm")
(include "key_records.scm")
@@ -494,19 +507,19 @@
;; The watchdog is to keep an eye on things like db sync etc.
;;
;; TODO: for multiple areas, we will have multiple watchdogs; and multiple threads to manage
-(define *watchdog* (make-thread
- (lambda ()
- (handle-exceptions
- exn
- (begin
- (print-call-chain)
- (print " message: " ((condition-property-accessor 'exn 'message) exn) ", exn=" exn))
- (common:watchdog)))
- "Watchdog thread"))
+;;(define *watchdog* (make-thread
+;; (lambda ()
+;; (handle-exceptions
+;; exn
+;; (begin
+;; (print-call-chain)
+;; (print " message: " ((condition-property-accessor 'exn 'message) exn) ", exn=" exn))
+;; (common:watchdog)))
+;; "Watchdog thread"))
;;(if (not (args:get-arg "-server"))
;; (thread-start! *watchdog*)) ;; if starting a server; wait till we get to running state before kicking off watchdog
(let* ((no-watchdog-args
'("-list-runs"
@@ -534,12 +547,14 @@
(loop (car tail) (cdr tail))))))
(no-watchdog-args-vals (filter (lambda (x) x)
(map args:get-arg no-watchdog-args)))
(start-watchdog (and (null? no-watchdog-args-vals) start-watchdog-specail-arg-val)))
;(print "no-watchdog-args="no-watchdog-args "no-watchdog-args-vals="no-watchdog-args-vals " start-watchdog-specail-arg-val:" start-watchdog-specail-arg-val " start-watchdog:" start-watchdog)
- (if start-watchdog
- (thread-start! *watchdog*)))
+;; (if start-watchdog
+;; (thread-start! *watchdog*))
+ #t
+)
;; bracket open-output-file with code to make leading directory if it does not exist and handle exceptions
(define (open-logfile logpath-in)
(condition-case
@@ -931,13 +946,13 @@
(if (or (args:get-arg "-list-servers")
(args:get-arg "-kill-servers"))
(let ((tl (launch:setup)))
(if tl ;; all roads from here exit
(let* ((servers (server:get-list *toppath*))
- (fmtstr "~8a~22a~20a~20a~8a\n"))
- (format #t fmtstr "pid" "Interface:port" "age (hms)" "Last mod" "State")
- (format #t fmtstr "===" "==============" "=========" "========" "=====")
+ (fmtstr "~33a~22a~20a~20a~8a\n"))
+ (format #t fmtstr "ID" "host:port" "age (hms)" "Last mod" "State")
+ (format #t fmtstr "==" "=========" "=========" "========" "=====")
(for-each ;; ( mod-time host port start-time pid )
(lambda (server)
(let* ((mtm (any->number (car server)))
(mod (if mtm (- (current-seconds) mtm) "unk"))
(age (- (current-seconds)(or (any->number (list-ref server 3)) (current-seconds))))
@@ -2290,22 +2305,22 @@
(begin
(debug:print 0 *default-log-port* "Failed to setup, exiting")
(exit 1)))
;; keep this one local
;; (open-run-close patch-db #f)
- (let ((dbstruct (db:setup #f areapath: *toppath*)))
- (common:cleanup-db dbstruct full: #t))
+ (let ((dbstructs (db:setup #f)))
+ (common:cleanup-db dbstructs full: #t))
(set! *didsomething* #t)))
(if (args:get-arg "-cleanup-db")
(begin
(if (not (launch:setup))
(begin
(debug:print 0 *default-log-port* "Failed to setup, exiting")
(exit 1)))
- (let ((dbstruct (db:setup #f areapath: *toppath*)))
- (common:cleanup-db dbstruct))
+ (let ((dbstructs (db:setup #f)))
+ (common:cleanup-db dbstructs))
(set! *didsomething* #t)))
(if (args:get-arg "-mark-incompletes")
(begin
(if (not (launch:setup))
@@ -2357,14 +2372,14 @@
(if (or (getenv "MT_RUNSCRIPT")
(args:get-arg "-repl")
(args:get-arg "-load"))
(let* ((toppath (launch:setup))
- (dbstruct (if (and toppath
- (common:on-homehost?))
- (db:setup #t)
- #f))) ;; make-dbr:dbstruct path: toppath local: (args:get-arg "-local")) #f)))
+ (dbstructs (if (and toppath
+ (common:on-homehost?))
+ (db:setup #t)
+ #f))) ;; make-dbr:dbstruct path: toppath local: (args:get-arg "-local")) #f)))
(if *toppath*
(cond
((getenv "MT_RUNSCRIPT")
;; How to run megatest scripts
;;
@@ -2377,15 +2392,16 @@
;; EOF
(repl))
(else
(begin
- (set! *db* dbstruct)
+ (set! *db* dbstructs)
(import extras) ;; might not be needed
;; (import csi)
(import readline)
(import apropos)
+ (import dbfile)
;; (import (prefix sqlite3 sqlite3:)) ;; doesn't work ...
(if *use-new-readline*
(begin
(install-history-file (get-environment-variable "HOME") ".megatest_history") ;; [homedir] [filename] [nlines])
@@ -2447,10 +2463,11 @@
;; ;; ;; redo me (list "uname" "rundir" "final_logf" "comment"))
;; ;; ;; redo me (set! *didsomething* #t)))
(if (args:get-arg "-import-megatest.db")
(begin
+ (launch:setup)
(db:multi-db-sync
(db:setup #f)
'killservers
'dejunk
'adj-testids
@@ -2458,16 +2475,18 @@
;; 'new2old
)
(set! *didsomething* #t)))
(when (args:get-arg "-sync-brute-force")
+ (launch:setup)
((server:get-bruteforce-syncer (db:setup #t) persist-until-sync: #t))
(set! *didsomething* #t))
(if (args:get-arg "-sync-to-megatest.db")
- (let* ((dbstruct (db:setup #f))
- (tmpdbpth (cdr (dbr:dbstruct-tmpdb dbstruct)))
+ (let* ((duh (launch:setup))
+ (dbstruct (db:setup #t))
+ (tmpdbpth (dbr:dbstruct-tmppath dbstruct))
(lockfile (conc tmpdbpth ".lock"))
(locked (common:simple-file-lock lockfile))
(res (if locked
(db:multi-db-sync
dbstruct
@@ -2533,14 +2552,14 @@
;;(debug:print-info 13 *default-log-port* "thread-join! watchdog")
;; join the watchdog thread if it has been thread-start!ed (it may not have been started in the case of a server that never enters running state)
;; (symbols returned by thread-state: created ready running blocked suspended sleeping terminated dead)
;; TODO: for multiple areas, we will have multiple watchdogs; and multiple threads to manage
-(if (thread? *watchdog*)
- (case (thread-state *watchdog*)
- ((ready running blocked sleeping terminated dead)
- (thread-join! *watchdog*))))
+;;(if (thread? *watchdog*)
+;; (case (thread-state *watchdog*)
+;; ((ready running blocked sleeping terminated dead)
+;; (thread-join! *watchdog*))))
(set! *time-to-exit* #t)
(if (not (eq? *globalexitstatus* 0))
(if (or (args:get-arg "-run")(args:get-arg "-runtests")(args:get-arg "-runall"))
Index: mtargs/mtargs.scm
==================================================================
--- mtargs/mtargs.scm
+++ mtargs/mtargs.scm
@@ -56,10 +56,20 @@
(if (string? help)
(print help)
(print "Usage: " (car (argv)) " ... "))
(exit 0))
+ ;; one-of args defined
+(define (args:any-defined? . param)
+ (let ((res #f))
+ (for-each
+ (lambda (arg)
+ (if (get-arg arg)(set! res #t)))
+ param)
+ res))
+
+;; args:
(define (get-args args params switches arg-hash num-needed)
(let* ((numtargs (length args))
(adj-num-needed (if num-needed (+ num-needed 2) #f)))
(if (< numtargs (if adj-num-needed adj-num-needed 2))
(if (>= num-needed 1)
Index: rmt.scm
==================================================================
--- rmt.scm
+++ rmt.scm
@@ -368,28 +368,28 @@
(loop (car tal)(cdr tal) newmax-cmd currmax)))))))
(mutex-unlock! *db-stats-mutex*)
res))
(define (rmt:open-qry-close-locally cmd run-id params #!key (remretries 5))
- (let* ((qry-is-write (not (member cmd api:read-only-queries)))
- (db-file-path (db:dbfile-path)) ;; 0))
- (dbstruct-local (db:setup #t)) ;; make-dbr:dbstruct path: dbdir local: #t)))
- (read-only (not (file-write-access? db-file-path)))
- (start (current-milliseconds))
- (resdat (if (not (and read-only qry-is-write))
- (let ((v (api:execute-requests dbstruct-local (vector (symbol->string cmd) params))))
- (handle-exceptions ;; there has been a long history of receiving strange errors from values returned by the client when things go wrong..
- exn ;; This is an attempt to detect that situation and recover gracefully
- (begin
- (debug:print 0 *default-log-port* "ERROR: bad data from server " v " message: " ((condition-property-accessor 'exn 'message) exn) ", exn=" exn)
- (vector #t '())) ;; should always get a vector but if something goes wrong return a dummy
- (if (and (vector? v)
- (> (vector-length v) 1))
- (let ((newvec (vector (vector-ref v 0)(vector-ref v 1))))
- newvec) ;; by copying the vector while inside the error handler we should force the detection of a corrupted record
- (vector #t '())))) ;; we could also check that the returned types are valid
- (vector #t '())))
+ (let* ((qry-is-write (not (member cmd api:read-only-queries)))
+ (db-file-path (db:dbfile-path)) ;; 0))
+ (dbstructs-local (db:setup #t)) ;; make-dbr:dbstruct path: dbdir local: #t)))
+ (read-only (not (file-write-access? db-file-path)))
+ (start (current-milliseconds))
+ (resdat (if (not (and read-only qry-is-write))
+ (let ((v (api:execute-requests dbstructs-local (vector (symbol->string cmd) params))))
+ (handle-exceptions ;; there has been a long history of receiving strange errors from values returned by the client when things go wrong..
+ exn ;; This is an attempt to detect that situation and recover gracefully
+ (begin
+ (debug:print 0 *default-log-port* "ERROR: bad data from server " v " message: " ((condition-property-accessor 'exn 'message) exn) ", exn=" exn)
+ (vector #t '())) ;; should always get a vector but if something goes wrong return a dummy
+ (if (and (vector? v)
+ (> (vector-length v) 1))
+ (let ((newvec (vector (vector-ref v 0)(vector-ref v 1))))
+ newvec) ;; by copying the vector while inside the error handler we should force the detection of a corrupted record
+ (vector #t '())))) ;; we could also check that the returned types are valid
+ (vector #t '())))
(success (vector-ref resdat 0))
(res (vector-ref resdat 1))
(duration (- (current-milliseconds) start)))
(if (and read-only qry-is-write)
(debug:print 0 *default-log-port* "ERROR: attempt to write to read-only database ignored. cmd=" cmd))
@@ -973,12 +973,12 @@
(define (rmtmod:calc-ro-mode runremote *toppath*)
(if (and runremote
(remote-ro-mode-checked runremote))
(remote-ro-mode runremote)
- (let* ((dbfile (conc *toppath* "/megatest.db"))
- (ro-mode (not (file-write-access? dbfile)))) ;; TODO: use dbstruct or runremote to figure this out in future
+ (let* ((mtcfgfile (conc *toppath* "/megatest.config"))
+ (ro-mode (not (file-write-access? mtcfgfile)))) ;; TODO: use dbstruct or runremote to figure this out in future
(if runremote
(begin
(remote-ro-mode-set! runremote ro-mode)
(remote-ro-mode-checked-set! runremote #t)
ro-mode)
Index: runs.scm
==================================================================
--- runs.scm
+++ runs.scm
@@ -508,12 +508,12 @@
(let* ((keys (keys:config-get-fields *configdat*))
(keyvals (keys:target->keyval keys target))
(run-id (rmt:register-run keyvals runname "new" "n/a" user (args:get-arg "-contour"))) ;; test-name)))
;; (deferred '()) ;; delay running these since they have a waiton clause
(runconfigf (conc *toppath* "/runconfigs.config"))
- (dbfile (conc *toppath* "/megatest.db"))
- (readonly-mode (not (file-write-access? dbfile)))
+ (mtconfig (conc *toppath* "/megatest.config"))
+ (readonly-mode (not (file-write-access? mtconfig)))
(test-records (make-hash-table))
;; need to process runconfigs before generating these lists
(all-tests-registry #f) ;; (tests:get-all)) ;; (tests:get-valid-tests (make-hash-table) test-search-path)) ;; all valid tests to check waiton names
(all-test-names #f) ;; (hash-table-keys all-tests-registry))
(test-names #f) ;; Generated by a call to (tests:filter-test-names all-test-names test-patts))
@@ -526,11 +526,11 @@
(allowed-tests #f)
(runconf #f))
;; check if readonly
(when readonly-mode
- (debug:print-error 0 *default-log-port* "megatest.db is readonly. Cannot proceed.")
+ (debug:print-error 0 *default-log-port* "Megatest database is readonly. Cannot proceed.")
(exit 1))
;; per user request. If less than 100Meg space on dbdir partition, bail out with error
;; this will reduce issues in database corruption
(common:check-db-dir-and-exit-if-insufficient)
@@ -2347,15 +2347,15 @@
(bup-mutex (make-mutex))
(keep-records (args:get-arg "-keep-records")) ;; used in conjunction with -remove-runs to keep the records, TODO: consolidate this with "mode".
(test-records '())) ;; for tasks that we wish to operate on all tests in one fell swoop
(let* ((write-access-actions '(remove-runs set-state-status archive run-wait kill-runs))
- (dbfile (conc *toppath* "/megatest.db"))
+ (dbfile (conc *toppath* "/.db/main.db"))
(readonly-mode (not (file-write-access? dbfile))))
(when (and readonly-mode
(member action write-access-actions))
- (debug:print-error 0 *default-log-port* "megatest.db is readonly. Cannot proceed with action ["action"] in which write-access isrequired .")
+ (debug:print-error 0 *default-log-port* dbfile " is readonly. Cannot proceed with action ["action"] in which write-access isrequired .")
(exit 1)))
(debug:print-info 4 *default-log-port* "runs:operate-on => Header: " header " action: " action " new-state-status: " new-state-status)
(if (> 2 (length state-status))
(begin
DELETED sdb.scm
Index: sdb.scm
==================================================================
--- sdb.scm
+++ /dev/null
@@ -1,116 +0,0 @@
-;;======================================================================
-;; Copyright 2006-2013, 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 .
-
-;;======================================================================
-
-;;======================================================================
-;; Simple persistant strings lookup table. Keep out of the main db
-;; so writes/reads don't slow down central access.
-;;======================================================================
-
-(require-extension (srfi 18) extras)
-(use sqlite3 srfi-1 posix regex regex-case srfi-69 csv-xml s11n md5 message-digest base64)
-(import (prefix sqlite3 sqlite3:))
-(import (prefix base64 base64:))
-
-(declare (unit sdb))
-
-;;
-(define (sdb:open fname)
- (let* ((dbpath (pathname-directory fname))
- (dbexists (let ((fe (common:file-exists? fname)))
- (if fe
- fe
- (begin
- (create-directory dbpath #t)
- #f))))
- (sdb (sqlite3:open-database fname))
- (handler (make-busy-timeout 136000)))
- (sqlite3:set-busy-handler! sdb handler)
- (if (not dbexists)
- (sdb:initialize sdb))
- (sqlite3:execute sdb "PRAGMA synchronous = 1;")
- sdb))
-
-(define (sdb:initialize sdb)
- (sqlite3:execute sdb "CREATE TABLE IF NOT EXISTS strs
- (id INTEGER PRIMARY KEY,
- str TEXT,
- CONSTRAINT str UNIQUE (str));")
- (sqlite3:execute sdb "CREATE INDEX IF NOT EXISTS strindx ON strs (str);"))
-
-;; (define sumup (let ((a 0))(lambda (x)(set! a (+ x a)) a)))
-
-(define (sdb:register-string sdb str)
- (sqlite3:execute sdb "INSERT OR IGNORE INTO strs (str) VALUES (?);" str))
-
-(define (sdb:string->id sdb str-cache str)
- (let ((id (hash-table-ref/default str-cache str #f)))
- (if (not id)
- (sqlite3:for-each-row
- (lambda (sid)
- (set! id sid)
- (hash-table-set! str-cache str id))
- sdb
- "SELECT id FROM strs WHERE str=?;" str))
- id))
-
-(define (sdb:id->string sdb id-cache id)
- (let ((str (hash-table-ref/default id-cache id #f)))
- (if (not str)
- (sqlite3:for-each-row
- (lambda (istr)
- (set! str istr)
- (hash-table-set! id-cache id str))
- sdb
- "SELECT str FROM strs WHERE id=?;" id))
- str))
-
-;; Numbers get passed though in both directions
-;;
-(define (make-sdb:qry fname)
- (let ((sdb #f)
- (scache (make-hash-table))
- (icache (make-hash-table)))
- (lambda (cmd var)
- (case cmd
- ((setup) (set! sdb (if (not sdb)
- (sdb:open (if var var fname)))))
- ((setdb) (set! sdb var))
- ((getdb) sdb)
- ((finalize) (if sdb
- (begin
- (sqlite3:finalize! sdb)
- (set! sdb #f))))
- ((getid) (let ((id (if (or (number? var)
- (string->number var))
- var
- (sdb:string->id sdb scache var))))
- (if id
- id
- (begin
- (sdb:register-string sdb var)
- (sdb:string->id sdb scache var)))))
- ((getstr) (if (or (number? var)
- (string->number var))
- (sdb:id->string sdb icache var)
- var))
- ((passid) var)
- ((passstr) var)
- (else #f)))))
-
Index: server.scm
==================================================================
--- server.scm
+++ server.scm
@@ -606,11 +606,14 @@
;; moving this here as it needs access to db and cannot be in common.
;;
(define (server:get-bruteforce-syncer dbstruct #!key (fork-to-background #f) (persist-until-sync #f))
- (let* ((sqlite-exe (or (get-environment-variable "MT_SQLITE3_EXE"))) ;; defined in cfg.sh
+ (debug:print "WARNING: bruteforce-syncer is called but has been disabled!")
+ (lambda ()
+ (debug:print "WARNING: bruteforce-syncer is called but has been disabled!"))
+ #;(let* ((sqlite-exe (or (get-environment-variable "MT_SQLITE3_EXE"))) ;; defined in cfg.sh
(sync-log (or (args:get-arg "-sync-log") (conc *toppath* "/logs/sync-" (current-process-id) "-" (get-host-name) ".log")))
(tmp-area (common:get-db-tmp-area))
(tmp-db (conc tmp-area "/megatest.db"))
(staging-file (conc *toppath* "/.megatest.db"))
(mtdbfile (conc *toppath* "/megatest.db"))
@@ -703,155 +706,5 @@
finalres)
) ;; end lambda
))
do-a-sync))
-(define (server:writable-watchdog-bruteforce dbstruct)
- (thread-sleep! 1) ;; delay for startup
- (let* ((do-a-sync (server:get-bruteforce-syncer dbstruct))
- (final-sync (server:get-bruteforce-syncer dbstruct fork-to-background: #t persist-until-sync: #t)))
- (when (and (not (args:get-arg "-sync-to-megatest.db")) ;; conditions under which we do not run the sync
- (args:get-arg "-server"))
-
- (let loop ()
- (do-a-sync)
- (if (not *time-to-exit*) (loop))) ;; keep going unless time to exit
-
- ;; time to exit, close the no-sync db here
- (final-sync)
-
- (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)
- (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 (dbr:dbstruct-stmt-cache dbstruct))
- (sync-duration 0) ;; run time of the sync in milliseconds
- )
- (set! *no-sync-db* no-sync-db) ;; make the no sync db available to api calls
- (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*))
- (let* (;;(dbstruct (db:setup))
- (mtdb (dbr:dbstruct-mtdb dbstruct))
- (mtpath (db:dbdat-get-path mtdb))
- (tmp-area (common:get-db-tmp-area))
- (start-file (conc tmp-area "/.start-sync"))
- (end-file (conc tmp-area "/.end-sync")))
- (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* ((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
- (let ((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")))))
-;; ;; TODO: factor this next routine out into a function
-;; (with-input-from-pipe ;; this should not block other threads but need to verify this
-;; (conc "megatest -sync-to-megatest.db -m testsuite:" (common:get-area-name) ":" *toppath*)
-;; (lambda ()
-;; (let loop ((inl (read-line))
-;; (res #f))
-;; (if (eof-object? inl)
-;; (begin
-;; (set! sync-duration (- (current-milliseconds) sync-start))
-;; (cond
-;; ((not res)
-;; (debug:print 0 *default-log-port* "ERROR: sync from /tmp db to megatest.db appears to have failed. Recommended that you stop your runs and run \"megatest -cleanup-db\""))
-;; ((> res 0)
-;; (mutex-lock! *heartbeat-mutex*)
-;; (set! *db-last-access* (current-seconds))
-;; (mutex-unlock! *heartbeat-mutex*))))
-;; (let ((num-synced (let ((matches (string-match "^Synced (\\d+).*$" inl)))
-;; (if matches
-;; (string->number (cadr matches))
-;; #f))))
-;; (loop (read-line)
-;; (or num-synced res))))))))))
- (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) ))))))) ;;" this-wd-num="this-wd-num)))))))
-
Index: spublish.scm
==================================================================
--- spublish.scm
+++ spublish.scm
@@ -396,19 +396,19 @@
(if (< (sauth-common:space-left-at-dest target-path) (sauth-common:src-size src-path))
(begin
(sauth:print-error "Destination does not have enough disk space.")
(exit 1)))
(if (is_directory src-path)
- (begin
- (let* ((parent-dir src-path)
- (start-dir target-path))
- (run (pipe
- (begin (system (conc "cd " parent-dir " ;tar chf - ." )))
- (begin (change-directory start-dir)
- ;(print "123")
- (run-cmd "tar" (list "xf" "-")))))
- (print "Copied data to " start-dir)))
+ (begin
+ (let* ((parent-dir src-path)
+ (start-dir target-path))
+ (run (pipe
+ (begin (system (conc "cd " parent-dir " ;tar chf - ." )))
+ (begin (change-directory start-dir)
+ ;(print "123")
+ (run-cmd "tar" (list "xf" "-")))))
+ (print "Copied data to " start-dir)))
(begin
(let*((parent-dir (pathname-directory src-path))
(start-dir target-path)
(filename (if (pathname-extension src-path)
(conc(pathname-file src-path) "." (pathname-extension src-path))
Index: tasks.scm
==================================================================
--- tasks.scm
+++ tasks.scm
@@ -327,11 +327,11 @@
;; register a task
(define (tasks:add dbstruct action owner target runname testpatt params)
(db:with-db
dbstruct #f #t
- (lambda (db)
+ (lambda (dbdat db)
(sqlite3:execute db "INSERT INTO tasks_queue (action,owner,state,target,name,testpatt,params,creation_time,execution_time)
VALUES (?,?,'new',?,?,?,?,strftime('%s','now'),0);"
action
owner
target
@@ -362,11 +362,11 @@
(define (tasks:snag-a-task dbstruct)
(let ((res #f)
(keytxt (conc (current-process-id) "-" (get-host-name) "-" (car (user-information (current-user-id))))))
(db:with-db
dbstruct #f #t
- (lambda (db)
+ (lambda (dat db)
;; first randomly set a new to pid-hostname-hostname
(sqlite3:execute
db
"UPDATE tasks_queue SET keylock=? WHERE id IN
(SELECT id FROM tasks_queue
@@ -389,11 +389,11 @@
(define (tasks:reset-stuck-tasks dbstruct)
(let ((res '()))
(db:with-db
dbstruct #f #t
- (lambda (db)
+ (lambda (dat db)
(sqlite3:for-each-row
(lambda (id delta)
(set! res (cons id res)))
db
"SELECT id,strftime('%s','now')-execution_time AS delta FROM tasks_queue WHERE state='inprogress' AND delta>700 ORDER BY delta DESC LIMIT 2;")
@@ -406,11 +406,11 @@
;;
(define (tasks:get-tasks dbstruct types states)
(let ((res '()))
(db:with-db
dbstruct #f #f
- (lambda (db)
+ (lambda (dbdat db)
(sqlite3:for-each-row
(lambda (id . rem)
(set! res (cons (apply vector id rem) res)))
db
(conc "SELECT id,action,owner,state,target,name,test,item,params,creation_time,execution_time
@@ -423,11 +423,11 @@
(define (tasks:get-last dbstruct target runname)
(let ((res #f))
(db:with-db
dbstruct #f #f
- (lambda (db)
+ (lambda (dbdat db)
(sqlite3:for-each-row
(lambda (id . rem)
(set! res (apply vector id rem)))
db
(conc "SELECT id,action,owner,state,target,name,testpatt,keylock,params,creation_time,execution_time
@@ -440,26 +440,26 @@
;; remove tasks given by a string of numbers comma separated
(define (tasks:remove-queue-entries dbstruct task-ids)
(db:with-db
dbstruct #f #t
- (lambda (db)
+ (lambda (dbdat db)
(sqlite3:execute db (conc "DELETE FROM tasks_queue WHERE id IN (" task-ids ");")))))
-#;(define (tasks:process-queue dbstruct)
- (let* ((task (tasks:snag-a-task dbstruct))
- (action (if task (tasks:task-get-action task) #f)))
- (if action (print "tasks:process-queue task: " task))
- (if action
- (case (string->symbol action)
- ((run) (tasks:start-run dbstruct task))
- ((remove) (tasks:remove-runs dbstruct task))
- ((lock) (tasks:lock-runs dbstruct task))
- ;; ((monitor) (tasks:start-monitor db task))
- #;((rollup) (tasks:rollup-runs dbstruct task))
- ((updatemeta)(tasks:update-meta dbstruct task))
- #;((kill) (tasks:kill-monitors dbstruct task))))))
+;; (define (tasks:process-queue dbstruct)
+;; (let* ((task (tasks:snag-a-task dbstruct))
+;; (action (if task (tasks:task-get-action task) #f)))
+;; (if action (print "tasks:process-queue task: " task))
+;; (if action
+;; (case (string->symbol action)
+;; ((run) (tasks:start-run dbstruct task))
+;; ((remove) (tasks:remove-runs dbstruct task))
+;; ((lock) (tasks:lock-runs dbstruct task))
+;; ;; ((monitor) (tasks:start-monitor db task))
+;; #;((rollup) (tasks:rollup-runs dbstruct task))
+;; ((updatemeta)(tasks:update-meta dbstruct task))
+;; #;((kill) (tasks:kill-monitors dbstruct task))))))
(define (tasks:tasks->text tasks)
(let ((fmtstr "~10a~10a~10a~12a~20a~12a~12a~10a"))
(conc (format #f fmtstr "id" "action" "owner" "state" "target" "runname" "testpatts" "params") "\n"
(string-intersperse
@@ -477,11 +477,11 @@
tasks) "\n"))))
(define (tasks:set-state dbstruct task-id state)
(db:with-db
dbstruct #f #t
- (lambda (db)
+ (lambda (dbdat db)
(sqlite3:execute db "UPDATE tasks_queue SET state=? WHERE id=?;"
state
task-id))))
;;======================================================================
@@ -489,49 +489,48 @@
;;======================================================================
(define (tasks:param-key->id dbstruct task-params)
(db:with-db
dbstruct #f #f
- (lambda (db)
+ (lambda (dbdat db)
(handle-exceptions
exn
#f
(sqlite3:first-result db "SELECT id FROM tasks_queue WHERE params LIKE ?;"
task-params)))))
(define (tasks:set-state-given-param-key dbstruct param-key new-state)
(db:with-db
dbstruct #f #t
- (lambda (db)
+ (lambda (dbdat db)
(sqlite3:execute db "UPDATE tasks_queue SET state=? WHERE params LIKE ?;" new-state param-key))))
(define (tasks:get-records-given-param-key dbstruct param-key state-patt action-patt test-patt)
(db:with-db
dbstruct #f #f
- (lambda (db)
+ (lambda (dbdat db)
(handle-exceptions
exn
'()
(sqlite3:first-row db "SELECT id,action,owner,state,target,name,testpatt,keylock,params WHERE
params LIKE ? AND state LIKE ? AND action LIKE ? AND testpatt LIKE ?;"
param-key state-patt action-patt test-patt)))))
(define (tasks:find-task-queue-records dbstruct target run-name test-patt state-patt action-patt)
- ;; (handle-exceptions
- ;; exn
- ;; '()
- ;; (sqlite3:first-row
- (let ((db (db:delay-if-busy (db:get-db dbstruct)))
- (res '()))
- (sqlite3:for-each-row
- (lambda (a . b)
- (set! res (cons (cons a b) res)))
- db "SELECT id,action,owner,state,target,name,testpatt,keylock,params FROM tasks_queue
+ (db:with-db
+ dbstruct
+ #f #f
+ (lambda (dbdat db)
+ (let ((res '()))
+ (sqlite3:for-each-row
+ (lambda (a . b)
+ (set! res (cons (cons a b) res)))
+ db "SELECT id,action,owner,state,target,name,testpatt,keylock,params FROM tasks_queue
WHERE
target = ? AND name = ? AND state LIKE ? AND action LIKE ? AND testpatt LIKE ?;"
- target run-name state-patt action-patt test-patt)
- res)) ;; )
+ target run-name state-patt action-patt test-patt)
+ res))))
;; kill any runner processes (i.e. processes handling -runtests) that match target/runname
;;
;; do a remote call to get the task queue info but do the killing as self here.
;;
ADDED tests/simplerun/Makefile
Index: tests/simplerun/Makefile
==================================================================
--- /dev/null
+++ tests/simplerun/Makefile
@@ -0,0 +1,5 @@
+
+cleanup :
+ killall mtest dboard -v -9 || true
+ rm -rf *.log *.bak NB* logs/* .meta .db /tmp/$(USER)/megatest_localdb/simplerun ../simpleruns/* lt
+
ADDED tests/simplerun/debug.scm
Index: tests/simplerun/debug.scm
==================================================================
--- /dev/null
+++ tests/simplerun/debug.scm
@@ -0,0 +1,61 @@
+
+(module junk
+ *
+
+(import big-chicken
+ rmtmod
+ apimod
+ dbmod
+ srfi-18
+ trace)
+
+(trace-call-sites #t)
+(trace
+ ;; db:get-tests-for-run
+ ;; rmt:general-open-connection
+ ;; rmt:open-main-connection
+ ;; rmt:drop-conn
+ ;; rmt:send-receive
+ ;; rmt:log-to-main
+ )
+
+(define (make-run-id)
+ (let* ((s (conc (current-process-id)))
+ (l (string-length s)))
+ (string->number (substring s (- l 3) l))
+ ))
+
+(define (run)
+ (let* ((th1 (make-thread
+ (lambda ()
+ (let loop ((r 0)
+ (i 1)
+ (s 0)) ;; sum
+ (let ((start-time (current-milliseconds))
+ (run-id (+ r (make-run-id))))
+ (rmt:register-test run-id "test1" (conc "item_" i))
+ (thread-sleep! 0.01)
+ (let* ((qry-time (- (current-milliseconds) start-time))
+ (tot-query-time (+ qry-time s))
+ (avg-query-time (* 1.0 (/ tot-query-time (max i 1)))))
+ (if (> qry-time 500)
+ (print "WARNING: rmt:register-test took more than 500ms, "qry-time"ms, i="i", avg-query-time="avg-query-time))
+ (if (eq? (modulo i 100) 0)
+ (print "For run-id="run-id", "(rmt:get-keys-write)" num tests registered="i" avg-query-time="avg-query-time))
+ (if (< i 500)
+ (loop r (+ i 1) tot-query-time)
+ (if (< r 100)
+ (let* ((start-time (current-milliseconds)))
+ (print "rmt:get-keys "(rmt:get-keys)" in "(- (current-milliseconds) start-time))
+ ;; run-id testpatt states statuses offset limit not-in sort-by sort-order qryvals last-update mode
+ (print "Got "(length (rmt:get-tests-for-run run-id "%" '() '() #f #f #f #f #f #f 0 #f))" tests for run "run-id)
+ (print "Average query time: "avg-query-time)
+ (loop (+ r 1) 0 tot-query-time))))))))
+ )))
+ (thread-start! th1)
+ (thread-join! th1)))
+
+(run)
+)
+
+
Index: tests/simplerun/megatest.config
==================================================================
--- tests/simplerun/megatest.config
+++ tests/simplerun/megatest.config
@@ -20,10 +20,14 @@
RELEASE TEXT
[setup]
# Adjust max_concurrent_jobs to limit how much you load your machines
max_concurrent_jobs 50
+
+[server]
+timeout 3
+# 3600
# Uncomment this to make the in-mem db into a disk based db (slower but good for debug)
# be aware that some unit tests will fail with this due to persistent data
#
# tmpdb /tmp
@@ -35,15 +39,15 @@
[validvalues]
state start end completed
# Job tools are more advanced ways to control how your jobs are launched
[jobtools]
-useshell yes
-launcher nbfind
+# useshell yes
+launcher nbfake
# You can override environment variables for all your tests here
[env-override]
EXAMPLE_VAR example value
# As you run more tests you may need to add additional disks, the names are arbitrary but must be unique
[disks]
disk0 #{getenv MT_RUN_AREA_HOME}/../simpleruns
Index: tests/simplerun/tests/test1/testconfig
==================================================================
--- tests/simplerun/tests/test1/testconfig
+++ tests/simplerun/tests/test1/testconfig
@@ -24,11 +24,11 @@
[requirements]
# waiton setup
priority 0
# Iteration for your tests are controlled by the items section
-[items]
+# [items]
# PARTOFDAY morning noon afternoon evening night
# test_meta is a section for storing additional data on your test
[test_meta]
author matt
ADDED tests/simplerun/thebeginning.scm
Index: tests/simplerun/thebeginning.scm
==================================================================
--- /dev/null
+++ tests/simplerun/thebeginning.scm
@@ -0,0 +1,109 @@
+(use trace test (prefix sqlite3 sqlite3:))
+(import dbfile)
+(trace-call-sites #t)
+
+(trace
+ ;; dbfile:setup
+ ;; dbfile:open-sqlite3-db
+ ;; dbfile:init-subdb
+ ;; dbfile:add-dbdat
+ ;; db:initialize-main-db
+ ;; dbfile:set-subdb
+ ;; db:with-db
+ ;; dbfile:get-subdb
+ )
+
+;; *************** dbfile.scm tests ****************
+
+
+ (debug:print 0 *default-log-port* " tmp area: " (common:get-db-tmp-area))
+
+(define tmpdir (common:get-db-tmp-area))
+(test #f #t (dbr:dbstruct? (dbfile:setup #t *toppath* tmpdir)))
+(test #f #t (dbr:dbstruct? (db:setup #t)))
+(define dbstruct *dbstruct-dbs*)
+(test #f #t (dbr:subdb? (dbfile:init-subdb dbstruct #f db:initialize-main-db))) ;; this opens the nfs main db
+
+;; (test #f #t (dbr:dbdat? (dbfile:open-db *dbstruct-dbs* #f db:initialize-main-db))) ;; this opens the tmp db.
+;; (define maindbdat (dbfile:open-db *dbstruct-dbs* #f db:initialize-main-db)) ;; this opens the tmp db.
+;; (dbfile:add-dbdat dbstruct #f maindbdat)
+
+;;(test #f #t (dbr:subdb? (dbfile:get-subdb dbstruct #f)))
+;; (test #f #t (dbr:dbdat? (dbfile:get-dbdat dbstruct #f)))
+;; (test #f #f (dbr:dbdat? (dbfile:get-dbdat dbstruct #f))) ;; stack empty so should fail.
+
+;; (test #f #t (hash-table? (dbr:dbstruct-subdbs dbstruct)))
+;; (test #f #t (stack? (dbr:subdb-dbstack (dbfile:get-subdb dbstruct #f))))
+;; (test #f '("SYSTEM" "RELEASE") (db:get-keys *dbstruct-dbs*))
+
+
+ (test #f #t (dbr:dbdat? (dbfile:open-db dbstruct 1 db:initialize-main-db)))
+ (test #f #t (dbr:dbdat? (dbfile:open-db dbstruct 2 db:initialize-main-db)))
+ (define rundbdat (dbfile:open-db dbstruct 1 db:initialize-main-db))
+ (define rundbdat2 (dbfile:open-db dbstruct 1 db:initialize-main-db))
+ (dbfile:add-dbdat dbstruct 1 rundbdat)
+ (dbfile:add-dbdat dbstruct 2 rundbdat2)
+;; (test #f #t (dbr:subdb? (dbfile:get-subdb dbstruct 1)))
+;; (test #f #t (dbr:dbdat? (dbfile:get-dbdat dbstruct 1)))
+;; (test #f #t (dbr:subdb? (dbfile:get-subdb dbstruct 2)))
+;; (test #f #t (dbr:dbdat? (dbfile:get-dbdat dbstruct 2)))
+
+;; (test #f #t (db:close-all dbstruct))
+
+
+;; (test #f #t (> (dbfile:lazy-sqlite-db-modification-time ".db/main.db") 0))
+;; (test #f #t (> (dbfile:lazy-sqlite-db-modification-time ".db/1.db") 0))
+;; (test #f #t (> (dbfile:lazy-sqlite-db-modification-time ".db/2.db") 0))
+
+;; (test #f #t (common:simple-file-lock "./db.lock"))
+;; (test #f "./db.lock" (common:simple-file-release-lock "./db.lock"))
+
+
+
+;; *************** db.scm tests ****************
+
+
+;; (define thisdbdat (db:open-db dbstruct #f))
+;; (test #f #t (dbr:dbdat? thisdbdat))
+
+;; (test #f #t (dbr:dbdat? (db:get-db dbstruct #f)))
+;; (test #f #t (dbr:dbdat? (db:get-db dbstruct 1)))
+;; (test #f #t (dbr:dbdat? (db:get-db dbstruct 2)))
+
+;; (dbfile:add-dbdat dbstruct #f maindbdat)
+;; (define maindbdat (dbfile:get-dbdat dbstruct #f))
+;; (dbfile:add-dbdat dbstruct #f maindbdat)
+
+(define mtdbdat2 (dbr:subdb-mtdbdat (dbfile:get-subdb dbstruct #f)))
+
+(define areapath (dbr:dbstruct-areapath dbstruct))
+(define mtdbpath (dbfile:run-id->path areapath #f))
+(define init-proc db:initialize-main-db)
+
+(define mtdbdat (dbfile:open-sqlite3-db mtdbpath init-proc))
+
+(define maindb-handle (dbr:dbdat-dbh mtdbdat))
+(define maindb-handle2 (dbr:dbdat-dbh mtdbdat2))
+(debug:print 0 *default-log-port* "maindb handle: " maindb-handle)
+(debug:print 0 *default-log-port* "maindb handle2: " maindb-handle2)
+
+(sqlite3:execute maindb-handle "vacuum")
+(sqlite3:execute maindb-handle2 "vacuum")
+
+(define full-sel (conc "SELECT * from runs"))
+
+(sqlite3:for-each-row
+ (lambda (a . b)
+ (debug:print 0 *default-log-port* "a: " a " b: " b)
+ )
+ maindb-handle
+ full-sel)
+
+(test #f #t (db:sync-touched dbstruct #f))
+(test #f #t (db:sync-touched dbstruct 1))
+(test #f #t (db:sync-touched dbstruct 2))
+
+(test #f #t (db:safely-close-sqlite3-db (dbr:dbdat-dbh rundbdat) (dbr:dbdat-stmt-cache rundbdat)))
+(test #f #t (db:safely-close-sqlite3-db (dbr:dbdat-dbh rundbdat2) (dbr:dbdat-stmt-cache rundbdat2)))
+(test #f #t (db:safely-close-sqlite3-db (dbr:dbdat-dbh mtdbdat) (dbr:dbdat-stmt-cache mtdbdat)))
+