Index: Makefile ================================================================== --- Makefile +++ Makefile @@ -22,17 +22,24 @@ 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 commonmod.scm + +all : $(PREFIX)/bin/.$(ARCHSTR) mtest dboard mtut tcmt + +# dbmod.import.o is just a hack here +mofiles/dbfile.o : mofiles/debugprint.o dbmod.import.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 @@ -78,12 +85,10 @@ ARCHSTR=$(shell if [[ -e /usr/bin/sw_vers ]]; then /usr/bin/sw_vers -productVersion; else lsb_release -sr; fi) # ARCHSTR=$(shell bash -c "echo \$$MACHTYPE") PNGFILES = $(shell cd docs/manual;ls *png) -# all : $(PREFIX)/bin/.$(ARCHSTR) mtest dboard mtut ndboard -all : $(PREFIX)/bin/.$(ARCHSTR) mtest dboard mtut tcmt mtest: $(OFILES) readline-fix.scm megatest.o $(MOFILES) $(MOIMPFILES) megatest-version.scm csc $(CSCOPTS) $(OFILES) $(MOFILES) $(MOIMPFILES) megatest.o -o mtest showmtesthash: @@ -150,11 +155,13 @@ $(INSTALL) mt-pg.sql $(PREFIX)/share/db/mt-pg.sql # Special dependencies for the includes $(MOFILE) $(MOIMPFILES) : megatest-fossil-hash.scm -# common.o : mofiles/commonmod.o megatest-fossil-hash.scm +mofiles/commonmod.o : megatest-fossil-hash.scm +common.o : mofiles/commonmod.o + # mofiles/dbmod.o : mofiles/configfmod.o # commonmod.o dashboard.o megatest.o tcmt.o apimod.o : megatest-fossil-hash.scm tests.o db.o launch.o runs.o dashboard-tests.o \ @@ -162,21 +169,23 @@ 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 mofiles/commonmod.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/dbfile.o : mofiles/commonmod.o # mofiles/stml2.o : mofiles/cookie.o # configf.o : mofiles/commonmod.o vg.o dashboard.o : vg_records.scm megatest-version.scm @@ -293,10 +302,19 @@ chmod a+x $@ $(PREFIX)/bin/mtrunner : utils/mtrunner $(INSTALL) $< $@ chmod a+x $@ + +$(PREFIX)/bin/mt-old-to-new.sh : utils/mt-old-to-new.sh + $(INSTALL) $< $@ + chmod a+x $@ + +$(PREFIX)/bin/mt-new-to-old.sh : utils/mt-new-to-old.sh + $(INSTALL) $< $@ + chmod a+x $@ + deploytarg/nbfake : utils/nbfake $(INSTALL) $< $@ chmod a+x $@ @@ -339,10 +357,11 @@ install : $(PREFIX)/bin/.$(ARCHSTR) $(PREFIX)/bin/.$(ARCHSTR)/mtest $(PREFIX)/bin/megatest \ $(PREFIX)/bin/.$(ARCHSTR)/dboard $(PREFIX)/bin/dashboard $(HELPERS) $(PREFIX)/bin/nbfake \ $(PREFIX)/bin/.$(ARCHSTR)/mtexec $(PREFIX)/bin/mtexec $(PREFIX)/bin/serialize-env \ $(PREFIX)/bin/nbfind $(PREFIX)/bin/mtrunner $(PREFIX)/bin/viewscreen $(PREFIX)/bin/mt_xterm \ + $(PREFIX)/bin/mt-old-to-new.sh $(PREFIX)/bin/mt-new-to-old.sh \ $(PREFIX)/share/docs/megatest_manual.html $(PREFIX)/bin/remrun \ $(PREFIX)/share/docs/megatest_manual.html $(PREFIX)/bin/remrun $(PREFIX)/bin/mtutil \ $(PREFIX)/bin/tcmt $(PREFIX)/share/db/mt-pg.sql \ $(PREFIX)/share/js/jquery-3.1.0.slim.min.js \ $(PREFIX)/bin/.$(ARCHSTR)/lib/libpangox-1.0.so \ @@ -455,12 +474,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,21 +146,26 @@ ;; - 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) - (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)) - (debug:print 0 *default-log-port* " message: " ((condition-property-accessor 'exn 'message) exn)) - (vector #f (vector exn call-chain dat))) ;; return some stuff for debug if an exception happens + (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)) +;; (debug:print 0 *default-log-port* " message: " ((condition-property-accessor 'exn 'message) exn)) + ;; (vector #f (vector exn call-chain dat))) ;; return some stuff for debug if an exception happens + (if (> *api-process-request-count* 200) + (begin + (debug:print 0 *default-log-port* "WARNING: Over 200 threads, overload, taking a five second nap.") + (thread-sleep! 5))) ;; take a nap (cond ((not (vector? dat)) ;; it is an error to not receive a vector (vector #f (vector #f "remote must be called with a vector"))) - ((> *api-process-request-count* 20) ;; 20) + #;((> *api-process-request-count* 200) ;; 20) (debug:print 0 *default-log-port* "WARNING: api:execute-requests received an overloaded message.") (set! *server-overloaded* #t) (vector #f (vector #f 'overloaded))) ;; the inner vector is what gets returned. nope, don't know why. please refactor! (else (let* ((cmd-in (vector-ref dat 0)) @@ -228,19 +235,19 @@ ((del-var) (apply db:del-var dbstruct params)) ((add-var) (apply db:add-var dbstruct params)) ;; STEPS ((teststep-set-status!) (apply db:teststep-set-status! dbstruct params)) - ((delete-steps-for-test!) (apply db:delete-steps-for-test! dbstruct params)) + ((delete-steps-for-test!) (apply db:delete-steps-for-test! dbstruct params)) ;; TEST DATA ((test-data-rollup) (apply db:test-data-rollup dbstruct params)) ((csv->test-data) (apply db:csv->test-data dbstruct params)) ;; MISC ((sync-inmem->db) (let ((run-id (car params))) - (db:sync-touched dbstruct run-id force-sync: #t))) + (db:sync-touched dbstruct run-id db:initialize-main-db force-sync: #t))) ((mark-incomplete) (apply db:find-and-mark-incomplete dbstruct params)) ((create-all-triggers) (db:create-all-triggers dbstruct)) ((drop-all-triggers) (db:drop-all-triggers dbstruct)) ;; TESTMETA @@ -342,11 +349,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 @@ -372,11 +379,11 @@ (vector #f res)) (begin #;(common:telemetry-log (conc "api-out:"(->string cmd)) payload: `((params . ,params) (ok-res . #f))) - (vector #t res)))))))) + (vector #t res))))))) ;; ) ;; http-server send-response ;; api:process-request ;; db:* ;; 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: client.scm ================================================================== --- client.scm +++ client.scm @@ -71,12 +71,18 @@ ;; ;; client:setup ;; ;; lookup_server, need to remove *runremote* stuff ;; - + (define (client:setup-http areapath #!key (remaining-tries 100) (failed-connects 0)(area-dat #f)) + (mutex-lock! *rmt-mutex*) + (let ((res (client:setup-http-baby areapath remaining-tries: remaining-tries failed-connects: failed-connects area-dat: area-dat))) + (mutex-unlock! *rmt-mutex*) + res)) + +(define (client:setup-http-baby areapath #!key (remaining-tries 100) (failed-connects 0)(area-dat #f)) (debug:print-info 2 *default-log-port* "client:setup remaining-tries=" remaining-tries) (server:start-and-wait areapath) (if (<= remaining-tries 0) (begin (debug:print-error 0 *default-log-port* "failed to start or connect to server") @@ -86,11 +92,11 @@ ;; through them searching for a good one. ;; (let* ((server-dat (server:get-rand-best areapath)) ;; (server:get-first-best areapath)) (runremote (or area-dat *runremote*))) (if (not server-dat) ;; no server found - (client:setup-http areapath remaining-tries: (- remaining-tries 1)) + (client:setup-http-baby areapath remaining-tries: (- remaining-tries 1)) (let ((host (cadr server-dat)) (port (caddr server-dat)) (server-id (caddr (cddr server-dat)))) (debug:print-info 4 *default-log-port* "client:setup server-dat=" server-dat ", remaining-tries=" remaining-tries) (if (and (not area-dat) @@ -108,23 +114,28 @@ (ping-res (case *transport-type* ((http)(rmt:login-no-auto-client-setup start-res))))) (if (and start-res ping-res) (let ((runremote (or area-dat *runremote*))) ;; it might have been generated only a few statements ago - (remote-conndat-set! runremote start-res) ;; (hash-table-set! runremote run-id start-res) - (debug:print-info 2 *default-log-port* "connected to " (http-transport:server-dat-make-url start-res)) - start-res) + (if runremote + (begin + (remote-conndat-set! runremote start-res) ;; (hash-table-set! runremote run-id start-res) + (debug:print-info 2 *default-log-port* "connected to " (http-transport:server-dat-make-url start-res)) + start-res) + (client:setup-http-baby areapath remaining-tries: (- remaining-tries 1)))) (begin ;; login failed but have a server record, clean out the record and try again (debug:print-info 0 *default-log-port* "client:setup, login unsuccessful, will attempt to start server ... start-res=" start-res ", server-dat=" server-dat) ;; had runid. Fixes part of Randy;s ticket 1405717332 (case *transport-type* ((http)(http-transport:close-connections))) - (remote-conndat-set! runremote #f) ;; (hash-table-delete! runremote run-id) + (if *runremote* + (remote-conndat-set! runremote #f) ;; (hash-table-delete! runremote run-id) + ) (thread-sleep! 1) - (client:setup-http areapath remaining-tries: (- remaining-tries 1)) + (client:setup-http-baby areapath remaining-tries: (- remaining-tries 1)) ))) (begin ;; no server registered ;; (server:kind-run areapath) (server:start-and-wait areapath) (debug:print-info 0 *default-log-port* "client:setup, no server registered, remaining-tries=" remaining-tries) (thread-sleep! 1) ;; (+ 5 (random (- 20 remaining-tries)))) ;; give server a little time to start up, randomize a little to avoid start storms. - (client:setup-http areapath remaining-tries: (- remaining-tries 1))))))))) + (client:setup-http-baby areapath remaining-tries: (- remaining-tries 1))))))))) Index: common.scm ================================================================== --- common.scm +++ common.scm @@ -26,12 +26,12 @@ (prefix sqlite3 sqlite3:) pkts (prefix dbi dbi:) ) (declare (unit common)) -;; (declare (uses commonmod)) -;; (import commonmod) +(declare (uses commonmod)) +(import commonmod) (include "common_records.scm") ;; (require-library margs) @@ -129,37 +129,37 @@ (define *test-meta-updated* (make-hash-table)) (define *globalexitstatus* 0) ;; attempt to work around possible thread issues (define *passnum* 0) ;; when running track calls to run-tests or similar ;; (define *alt-log-file* #f) ;; used by -log -(define *common:denoise* (make-hash-table)) ;; for low noise printing +;; (define *common:denoise* (make-hash-table)) ;; for low noise printing (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 -(define *db-write-access* #t) +;; (define *db-write-access* #t) ;; db sync -(define *db-last-sync* 0) ;; last time the sync to megatest.db happened +;; (define *db-last-sync* 0) ;; last time the sync to megatest.db happened (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* +;; (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-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 @@ -172,12 +172,12 @@ (define *run-id* #f) (define *server-kind-run* (make-hash-table)) (define *home-host* #f) ;; (define *total-non-write-delay* 0) (define *heartbeat-mutex* (make-mutex)) -(define *api-process-request-count* 0) -(define *max-api-process-requests* 0) +;; (define *api-process-request-count* 0) +;; (define *max-api-process-requests* 0) (define *server-overloaded* #f) ;; client (define *rmt-mutex* (make-mutex)) ;; remote access calls mutex @@ -310,10 +310,11 @@ (hh-dat (common:get-homehost)) ;; homehost record ( addr . hhflag ) (server-url #f) ;; (server:check-if-running *toppath*) #f)) (server-id #f) (server-info (if *toppath* (server:check-if-running *toppath*) #f)) (last-server-check 0) ;; last time we checked to see if the server was alive + (connect-time (current-seconds)) (conndat #f) (transport *transport-type*) (server-timeout (server:expiration-timeout)) (force-server #f) (ro-mode #f) @@ -405,19 +406,15 @@ ;; (define (common:cleanup-db dbstruct #!key (full #f)) (apply db:multi-db-sync dbstruct 'schema - ;; 'new2old 'killservers 'adj-target - ;; 'old2new 'new2old - ;; (if full - '(dejunk) - ;; '()) - ) + '(dejunk) + ) (if (common:api-changed?) (common:set-last-run-version))) (define (common:snapshot-file filepath #!key (subdir ".") ) (if (file-exists? filepath) @@ -591,13 +588,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 @@ -724,54 +721,10 @@ (print-call-chain (current-error-port)) #f) (read (open-input-string (base64:base64-decode instr)))) (read (open-input-string (z3:decode-buffer (base64:base64-decode instr)))))) -;; 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 (common:simple-file-lock fname #!key (expire-time 300)) - (let ((fmod-time (handle-exceptions - ext - (current-seconds) - (file-modification-time fname)))) - (if (common:file-exists? fname) - (if (> (- (current-seconds) fmod-time) expire-time) - (begin - (handle-exceptions exn #f (delete-file* fname)) - (common:simple-file-lock fname expire-time: expire-time)) - #f) - (let ((key-string (conc (get-host-name) "-" (current-process-id)))) - (with-output-to-file fname - (lambda () - (print key-string))) - (thread-sleep! 0.25) - (if (common:file-exists? fname) - (handle-exceptions exn - #f - (with-input-from-file fname - (lambda () - (equal? key-string (read-line))))) - #f))))) - -(define (common:simple-file-lock-and-wait fname #!key (expire-time 300)) - (let ((end-time (+ expire-time (current-seconds)))) - (let loop ((got-lock (common:simple-file-lock fname expire-time: expire-time))) - (if got-lock - #t - (if (> end-time (current-seconds)) - (begin - (thread-sleep! 3) - (loop (common:simple-file-lock fname expire-time: expire-time))) - #f))))) - -(define (common:simple-file-release-lock fname) - (handle-exceptions - exn - #f ;; I don't really care why this failed (at least for now) - (delete-file* fname))) ;;====================================================================== ;; S T A T E S A N D S T A T U S E S ;;====================================================================== @@ -952,10 +905,22 @@ (begin (debug:print-error 0 *default-log-port* "Unable to find megatest home directory.") #f) (loop (pathname-directory thepath))))) )) + + +(define (common:db-tmp-area-path) + (conc "/tmp/" + (current-user-name) + "/megatest_localdb/" + (common:get-testsuite-name) + "/" + (string-translate *toppath* "/" ".") + ) +) + ;;====================================================================== ;; redefine for future cleanup (converge on area-name, the more generic ;; (define common:get-area-name common:get-testsuite-name) @@ -979,10 +944,18 @@ "/megatest_localdb/" tsname (string-translate *toppath* "/" ".")) )))) (set! *db-cache-path* dbpath) + ;; ensure megatest area has .megatest + (let ((dbarea (conc *toppath* "/.megatest"))) + (if (not (file-exists? dbarea)) + (create-directory dbarea))) + ;; ensure tmp area has .megatest + (let ((dbarea (conc dbpath "/.megatest"))) + (if (not (file-exists? dbarea)) + (create-directory dbarea))) dbpath)) #f))) (define (common:get-area-path-signature) (message-digest-string (md5-primitive) *toppath*)) @@ -999,118 +972,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) @@ -2621,17 +2486,10 @@ ;;====================================================================== ;; E N V I R O N M E N T V A R S ;;====================================================================== -(define (bb-check-path #!key (msg "check-path: ")) - (let ((path (or (get-environment-variable "PATH") "none"))) - (debug:print-info 0 *default-log-port* (conc msg" : $PATH="path)) - (if (string-match "^.*/isoenv-core/.*" path) - (debug:print-error 0 *default-log-port* (conc msg" : !!ISOENV PRESENT!!")) ;; remove for prod - (debug:print-info 1 *default-log-port* (conc msg" : **no isoenv present**"))))) - (define (save-environment-as-files fname #!key (ignorevars (list "USER" "HOME" "DISPLAY" "LS_COLORS" "XKEYSYMDB" "EDITOR" "MAKEFLAGS" "MAKEF" "MAKEOVERRIDES" "HOSTNAME"))) ;;(bb-check-path msg: "save-environment-as-files entry") (let ((envvars (get-environment-variables)) (whitesp (regexp "[^a-zA-Z0-9_\\-:,\\.\\/%$]")) (mungeval (lambda (val) @@ -2642,13 +2500,16 @@ (with-output-to-file (conc fname ".csh") (lambda () (for-each (lambda (keyval) (let* ((key (car keyval)) (val (cdr keyval)) - (delim (if (string-search whitesp val) + (delim (if (and (string-search whitesp val) + (not (string-search "^\".*\"$" val)) + (not (string-search "^'.*'$" val))) "\"" ""))) + (print (if (or (member key ignorevars) (string-search whitesp key)) "# setenv " "setenv ") key " " delim (mungeval val) delim))) @@ -2656,11 +2517,13 @@ (with-output-to-file (conc fname ".sh") (lambda () (for-each (lambda (keyval) (let* ((key (car keyval)) (val (cdr keyval)) - (delim (if (string-search whitesp val) + (delim (if (and (string-search whitesp val) + (not (string-search "^\".*\"$" val)) + (not (string-search "^'.*'$" val))) "\"" ""))) (print (if (or (member key ignorevars) (string-search whitesp key) (string-search ":" key)) ;; internal only values to be skipped. Index: commonmod.scm ================================================================== --- commonmod.scm +++ commonmod.scm @@ -17,16 +17,19 @@ ;; along with Megatest. If not, see . ;;====================================================================== (declare (unit commonmod)) + +(use srfi-69) (module commonmod * - + (import scheme chicken data-structures extras files) -(import (prefix sqlite3 sqlite3:) posix typed-records srfi-18 srfi-69 +(import (prefix sqlite3 sqlite3:) + posix typed-records srfi-18 srfi-69 md5 message-digest regex srfi-1) ;;====================================================================== ;; CONTENTS @@ -44,10 +47,21 @@ (conc megatest-version "-" megatest-fossil-hash)) (define (version-signature) (conc megatest-version "-" (substring megatest-fossil-hash 0 4))) +(define *common:denoise* (make-hash-table)) ;; for low noise printing + +(define (common:low-noise-print waitval . keys) + (let* ((key (string-intersperse (map conc keys) "-" )) + (lasttime (hash-table-ref/default *common:denoise* key 0)) + (currtime (current-seconds))) + (if (> (- currtime lasttime) waitval) + (begin + (hash-table-set! *common:denoise* key currtime) + #t) + #f))) ;;====================================================================== ;; config file utils ;;====================================================================== @@ -72,10 +86,55 @@ '()))) ;; should it return empty list or #f to indicate not set? (define (get-section cfgdat section) (hash-table-ref/default cfgdat section '())) + +;; 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 (common:simple-file-lock fname #!key (expire-time 300)) + (let ((fmod-time (handle-exceptions + ext + (current-seconds) + (file-modification-time fname)))) + (if (file-exists? fname) ;; (common:file-exists? fname) + (if (> (- (current-seconds) fmod-time) expire-time) + (begin + (handle-exceptions exn #f (delete-file* fname)) + (common:simple-file-lock fname expire-time: expire-time)) + #f) + (let ((key-string (conc (get-host-name) "-" (current-process-id)))) + (with-output-to-file fname + (lambda () + (print key-string))) + (thread-sleep! 0.25) + (if (file-exists? fname) ;; (common:file-exists? fname) + (handle-exceptions exn + #f + (with-input-from-file fname + (lambda () + (equal? key-string (read-line))))) + #f))))) + +(define (common:simple-file-lock-and-wait fname #!key (expire-time 300)) + (let ((end-time (+ expire-time (current-seconds)))) + (let loop ((got-lock (common:simple-file-lock fname expire-time: expire-time))) + (if got-lock + #t + (if (> end-time (current-seconds)) + (begin + (thread-sleep! 3) + (loop (common:simple-file-lock fname expire-time: expire-time))) + #f))))) + +(define (common:simple-file-release-lock fname) + (handle-exceptions + exn + #f ;; I don't really care why this failed (at least for now) + (delete-file* fname))) ;;====================================================================== ;; misc conversion, data manipulation functions ;;====================================================================== 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 @@ -26,10 +26,11 @@ (use canvas-draw) (import canvas-draw-iup) (use ducttape-lib) (use sqlite3 srfi-1 posix regex regex-case srfi-69 typed-records sparse-vectors) ;; defstruct (import (prefix sqlite3 sqlite3:)) +(import dbfile) (declare (uses common)) (declare (uses margs)) (declare (uses keys)) (declare (uses items)) @@ -37,133 +38,74 @@ (declare (uses configf)) (declare (uses process)) (declare (uses launch)) (declare (uses runs)) (declare (uses dashboard-tests)) -(declare (uses dashboard-guimonitor)) (declare (uses tree)) (declare (uses dcommon)) (declare (uses dashboard-context-menu)) (declare (uses vg)) (declare (uses subrun)) -;; (declare (uses dashboard-main)) (declare (uses mt)) +(declare (uses dbfile)) (include "common_records.scm") (include "db_records.scm") (include "run_records.scm") (include "task_records.scm") (include "megatest-version.scm") (include "megatest-fossil-hash.scm") (include "vg_records.scm") +(dbfile:db-init-proc db:initialize-main-db) + (define help (conc - "Megatest Dashboard, documentation at http://www.kiatoa.com/fossils/megatest - version " megatest-version " - license GPL, Copyright (C) Matt Welland 2012-2017 + "Megatest Dashboard, documentation at http://www.kiatoa.com/fossils/megatest version " megatest-version + " license GPL, Copyright (C) Matt Welland 2012-2017 Usage: dashboard [options] -h : this help - -test run-id,test-id : control test identified by testid + -test run-id test-id : open a test control panel on this test -skip-version-check : skip the version check - -use-db-cache : access database via cache - -Misc -rows R : set number of rows -cols C : set number of columns -")) + -start-dir dir : start dashboard in the given directory + -target target : filter runs tab to given target. + -debug n[,n] : set debug level(s) e.g. -debug 4 or -debug 0,9 + -repl : Start a chicken scheme interpreter +" +)) -;; -server host:port : connect to host:port instead of db access -;; -xterm run-id,test-id : Start a new xterm with specified run-id and test-id -;; -guimonitor : control panel for runs ;; process args (define remargs (args:get-args (argv) + ;; parameters (need arguments) (list "-rows" "-cols" - "-run" - "-test" - "-xterm" - "-debug" - "-host" - "-transport" - "-start-dir" - ) - (list "-h" - "-use-server" - "-guimonitor" - "-main" - "-v" - "-q" - "-use-db-cache" + "-test" ;; given a run id and test id, open only a test control panel on that test.. + "-debug" + "-start-dir" + "-target" + ) + ;; switches (don't take arguments) + (list "-h" "-skip-version-check" "-repl" - "-rh5.11" ;; fix to allow running on rh5.11 "-:p" ;; ignore the built in chicken profiling switch ) args:arg-hash 0)) -;; check for MT_* environment variables and exit if found -(if (not (args:get-arg "-test")) - (begin - (display "Checking for MT_ vars: ") - (for-each (lambda (var) - (display " ")(display var) - (if (get-environment-variable var) - (begin - (print "ERROR: environment variable " var " is set in this terminal, this will cause you problems. Exiting now.") - (exit 1)))) - '("MT_RUN_AREA_HOME" "MT_MEGATEST" "MT_CMDINFO" "MT_TEST_RUN_DIR" "MT_LINKTREE" "MT_TESTSUITENAME")) - (print ". Done. All ok."))) - -(if (not (null? remargs)) - (begin - (print "Unrecognised arguments: " (string-intersperse remargs " ")) - (exit))) - -(if (args:get-arg "-h") - (begin - (print help) - (exit))) - -(if (args:get-arg "-start-dir") - (if (directory-exists? (args:get-arg "-start-dir")) - (let ((fullpath (common:real-path (args:get-arg "-start-dir")))) - (setenv "PWD" fullpath) - (change-directory fullpath)) - (begin - (debug:print-error 0 *default-log-port* "non-existant start dir " (args:get-arg "-start-dir") " specified, exiting.") - (exit 1)))) - -;; TODO: Move this inside (main) -;; -(if (not (launch:setup)) - (begin - (print "Failed to find megatest.config, exiting") - (exit 1))) - -;; deal with RH 5.11 gtk lib or iup lib missing detachbox feature -;; first check for the switch -;; -(if (or (args:get-arg "-rh5.11") - (configf:lookup *configdat* "dashboard" "no-detachbox") - (not (file-exists? "/etc/os-release"))) - (set! iup:detachbox iup:vbox)) - -(if (not (common:on-homehost?)) - (begin - (debug:print 0 *default-log-port* "WARNING: Current policy requires running dashboard on homehost: " (common:get-homehost)))) ;; RA => Might require revert for filters ;; 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)));;;) @@ -178,10 +120,11 @@ update-mutex updaters updating uidat ;; needs to move to tabdat at some time hide-not-hide-tabs + target ) (define (dboard:commondat-make) (make-dboard:commondat curr-tab-num: 0 @@ -189,10 +132,11 @@ please-update: #t update-mutex: (make-mutex) updaters: (make-hash-table) updating: #f hide-not-hide-tabs: #f + target: "" )) ;;====================================================================== ;; buttons color using image ;;====================================================================== @@ -260,19 +204,20 @@ tabdat)) ;; gets and calls updater list based on curr-tab-num ;; (define (dboard:common-run-curr-updaters commondat #!key (tab-num #f)) + (sync-db-to-tmp (dboard:common-get-tabdat commondat tab-num: tab-num)) (if (dboard:common-get-tabdat commondat tab-num: tab-num) ;; only update if there is a tabdat (let* ((tnum (or tab-num (dboard:commondat-curr-tab-num commondat))) (updaters (hash-table-ref/default (dboard:commondat-updaters commondat) tnum '()))) (debug:print 4 *default-log-port* "Found these updaters: " updaters " for tab-num: " tnum) (for-each ;; perform the function calls for the complete updaters list (lambda (updater) - ;; (debug:print 3 *default-log-port* "Running " updater) + ;; (debug:print 3 *default-log-port* "Running " updater) (updater)) updaters)))) ;; if tab-num passed in then use it, otherwise look in commondat at curr-tab-num ;; adds the updater passed in the updaters list at that hashkey @@ -428,14 +373,14 @@ (define (dboard:setup-tabdat tabdat) (dboard:tabdat-dbdir-set! tabdat (db:dbfile-path)) ;; (conc (configf:lookup *configdat* "setup" "linktree") "/.db")) (dboard:tabdat-dbfpath-set! tabdat (db:dbfile-path)) (dboard:tabdat-monitor-db-path-set! tabdat (conc (dboard:tabdat-dbdir tabdat) "/monitor.db")) + ;; HACK ALERT: this is a hack, please fix. (dboard:tabdat-ro-set! tabdat (not (file-read-access? (dboard:tabdat-dbfpath tabdat)))) - (dboard:tabdat-keys-set! tabdat (rmt:get-keys)) (dboard:tabdat-dbkeys-set! tabdat (append (dboard:tabdat-keys tabdat) (list "runname"))) (dboard:tabdat-tot-runs-set! tabdat (rmt:get-num-runs "%")) ) @@ -473,11 +418,11 @@ hierdat ;; put hierarchial sorted list here tests ;; hash of id => testdat ((tests-by-name (make-hash-table)) : hash-table) ;; hash of testfullname => testdat key-vals ((last-update 0) : number) ;; last query to db got records from before last-update - ((last-db-time 0) : number) ;; last timestamp on megatest.db + ((last-db-time 0) : number) ;; last timestamp on main.db ((data-changed #f) : boolean) ((run-data-offset 0) : number) ;; get only 100 items per call, set back to zero when received less than 100 items (db-path #f)) ;; for the new runs view lets build up a few new record types and then consolidate later @@ -719,11 +664,11 @@ (last-db-time (if do-not-use-db-file-timestamps 0 (dboard:rundat-last-db-time run-dat))) (db-path (or (dboard:rundat-db-path run-dat) (let* ((db-dir (common:get-db-tmp-area)) - (db-pth (conc db-dir "/megatest.db"))) + (db-pth (conc db-dir "/.megatest/main.db"))) (dboard:rundat-db-path-set! run-dat db-pth) db-pth))) (db-mod-time (common:lazy-sqlite-db-modification-time db-path)) (db-modified (>= db-mod-time last-db-time)) (multi-get (> (dboard:rundat-run-data-offset run-dat) 0)) ;; multi-get in progress @@ -750,11 +695,11 @@ ) ;; if we saw the db modified, reset it (the signal has already been used) (if (and got-all ;; (not multi-get) db-modified) - (dboard:rundat-last-db-time-set! run-dat (- start-time 2))) + (dboard:rundat-last-db-time-set! run-dat (- start-time 2))) ;; to limit the amount of data transferred each cycle use limit of num-to-get and offset ;; DO NOT bump time indexes last-update and last-db-time until all the first pass of the ;; data has been read ;; set last-update to 0 if still getting data incrementally ;; NO NEED, handled above @@ -1671,11 +1616,11 @@ ;; NAMEid from IupTree to avoid ;; conflict with the common attribute ;; NAME. Use the TITLEid attribute." #:expand "YES" #:addexpanded "YES" - #:size "10x" + ;; #:size "10x" #:selection-cb (lambda (obj id state) (debug:catch-and-dump (lambda () (let* ((run-path (tree:node->path obj id)) @@ -1996,11 +1941,11 @@ (dashboard:run-id->tests-mindat dest-run-id tabdat runs-hash) hide-clean: hide-clean) #f))) -(define (dashboard:get-runs-hash tabdat) +(define (dashboard:get-runs-hash tabdat) (let* ((access-mode (dboard:tabdat-access-mode tabdat)) (last-runs-update 0);;(dboard:tabdat-last-runs-update tabdat)) (runs-dat (rmt:get-runs-by-patt (dboard:tabdat-keys tabdat) "%" #f #f #f #f last-runs-update)) (runs-header (vector-ref runs-dat 0)) ;; 0 is header, 1 is list of records (runs (vector-ref runs-dat 1)) @@ -2783,11 +2728,12 @@ (dboard:runs-tree-new-browser commondat rdat) (dboard:runs-new-matrix commondat rdat) ))) (define (make-dashboard-buttons commondat) ;; runs-sum-dat new-view-dat) - (let* ((stats-dat (dboard:tabdat-make-data)) + (let* ( + (stats-dat (dboard:tabdat-make-data)) (runs-dat (dboard:tabdat-make-data)) (runs2-dat (make-dboard:rdat)) ;; (dboard:tabdat-make-data)) (onerun-dat (dboard:tabdat-make-data)) ;; name for run-summary structure (runcontrols-dat (dboard:tabdat-make-data)) (runtimes-dat (dboard:tabdat-make-data)) @@ -2809,11 +2755,13 @@ (btn-fontsz (dboard:tabdat-runs-btn-fontsz runs-dat)) (cell-width (dboard:tabdat-runs-cell-width runs-dat)) (use-bgcolor (equal? (configf:lookup *configdat* "dashboard" "use-bgcolor") "yes"))) ;; controls (along bottom) ;; (set! controls (dboard:make-controls commondat runs-dat)) - + + + ;; create the left most column for the run key names and the test names (set! lftlst (list (iup:hbox (iup:label) ;; (iup:valuator) (apply iup:vbox @@ -2969,14 +2917,14 @@ #:title (conc "Megatest dashboard " (current-user-name) ":" *toppath*) #:menu (dcommon:main-menu) (let* ((runs-view (iup:vbox (iup:split #:orientation "VERTICAL" ;; "HORIZONTAL" - #:value 100 + #:value 250 (dboard:runs-tree-browser commondat runs-dat) (iup:split - #:value 100 + #:value 200 ;; left most block, including row names (apply iup:vbox lftlst) ;; right hand block, including cells (iup:vbox #:expand "YES" @@ -3027,20 +2975,22 @@ (let* ((tab-num (dboard:commondat-curr-tab-num commondat)) (tabdat (dboard:common-get-tabdat commondat tab-num: tab-num))) (dboard:commondat-please-update-set! commondat #t) (dboard:tabdat-layout-update-ok-set! tabdat #t))) "tabchangepos")) - (dashboard:summary commondat stats-dat tab-num: 0) runs-view + (dashboard:summary commondat stats-dat tab-num: 1) ;; (make-runs-view commondat runs2-dat 2) (dashboard:runs-summary commondat onerun-dat tab-num: 2) (dashboard:run-controls commondat runcontrols-dat tab-num: 3) (dashboard:run-times commondat runtimes-dat tab-num: 4) - additional-views))) + additional-views)) + (target-run (dboard:commondat-target commondat)) + ) ;; (set! (iup:callback tabs tabchange-cb:) (lambda (a b c)(print "SWITCHED TO TAB: " a " " b " " c))) - (iup:attribute-set! tabs "TABTITLE0" "Summary") - (iup:attribute-set! tabs "TABTITLE1" "Runs") + (iup:attribute-set! tabs "TABTITLE0" "Runs") + (iup:attribute-set! tabs "TABTITLE1" "Summary") ;; (iup:attribute-set! tabs "TABTITLE2" "Runs2") (iup:attribute-set! tabs "TABTITLE2" "Run Summary") (iup:attribute-set! tabs "TABTITLE3" "Run Control") (iup:attribute-set! tabs "TABTITLE4" "Run Times") ;; (iup:attribute-set! tabs "TABTITLE3" "New View") @@ -3054,12 +3004,18 @@ (iup:attribute-set! tabs "BGCOLOR" "190 190 190") ;; make the iup tabs object available (for changing color for example) (dboard:commondat-hide-not-hide-tabs-set! commondat tabs) ;; now set up the tabdat lookup - (dboard:common-set-tabdat! commondat 0 stats-dat) - (dboard:common-set-tabdat! commondat 1 runs-dat) + ;; (dboard:common-set-tabdat! commondat 0 stats-dat) + + (if target-run + (begin + (dboard:tabdat-target-set! runs-dat (string-split target-run "/")) + ) + ) + (dboard:common-set-tabdat! commondat 0 runs-dat) ;;(dboard:common-set-tabdat! commondat 2 runs2-dat) (dboard:common-set-tabdat! commondat 2 onerun-dat) (dboard:common-set-tabdat! commondat 3 runcontrols-dat) (dboard:common-set-tabdat! commondat 4 runtimes-dat) @@ -3298,11 +3254,10 @@ (filtrstr (conc targpatt "/" runpatt "/" testpatt))) ;; (print "targpatt: " targpatt " runpatt: " runpatt " testpatt: " testpatt) (if (not (equal? (dboard:tabdat-last-filter-str tabdat) filtrstr)) (let ((dwg (dboard:tabdat-drawing tabdat))) - (print "reseting drawing") (dboard:tabdat-layout-update-ok-set! tabdat #f) (vg:drawing-libs-set! dwg (make-hash-table)) (vg:drawing-insts-set! dwg (make-hash-table)) (vg:drawing-cache-set! dwg '()) (dboard:tabdat-allruns-by-id-set! tabdat (make-hash-table)) @@ -3360,11 +3315,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 ... ;; @@ -3812,16 +3767,42 @@ ;;====================================================================== ;; The heavy lifting starts here ;;====================================================================== (define (main) - (let ((mtdb-path (conc *toppath* "/megatest.db"))) ;; + (print "Starting dashboard main") + + (let* ((mtdb-path (conc *toppath* "/.megatest/main.db")) + (target (args:get-arg "-target")) + (commondat (dboard:commondat-make))) + (if target + (begin + (args:remove-arg-from-ht "-target") + (dboard:commondat-target-set! commondat target) + ) + ) + + (if (not (launch:setup)) + (begin + (print "Failed to find megatest.config, exiting") + (exit 1) + ) + ) + + (if (not (common:on-homehost?)) + (begin + (debug:print 0 *default-log-port* "WARNING: You are starting the dashboard on a machine that is not the homehost:" (common:get-homehost)) + (debug:print 0 *default-log-port* "It will be slower.") + )) + + (if (and (common:file-exists? mtdb-path) (file-write-access? mtdb-path)) (if (not (args:get-arg "-skip-version-check")) (common:exit-on-version-changed))) - (let* ((commondat (dboard:commondat-make))) + + (let* () ;; Move this stuff to db.scm? I'm not sure that is the right thing to do... (cond ((args:get-arg "-test") ;; run-id,test-id (let* ((dat (let ((d (map string->number (string-split (args:get-arg "-test") ",")))) (if (> (length d) 1) @@ -3834,26 +3815,24 @@ (>= test-id 0)) (dashboard-tests:examine-test run-id test-id) (begin (debug:print 3 *default-log-port* "INFO: tried to open test with invalid run-id,test-id. " (args:get-arg "-test")) (exit 1))))) - ;; ((args:get-arg "-guimonitor") - ;; (gui-monitor (dboard:tabdat-dblocal tabdat))) (else (dboard:commondat-uidat-set! commondat (make-dashboard-buttons commondat)) (dboard:commondat-curr-tab-num-set! commondat 0) (dboard:commondat-add-updater commondat (lambda () - (dashboard:runs-tab-updater commondat 1)) - tab-num: 1) + (dashboard:runs-tab-updater commondat 0)) + tab-num: 0) ;; may not want this alive (manually merged it from v1.66) - (dboard:commondat-add-updater - commondat - (lambda () - (dashboard:runs-tab-updater commondat 1)) - tab-num: 2) + ;; (dboard:commondat-add-updater + ;; commondat + ;; (lambda () + ;; (dashboard:runs-tab-updater commondat 1)) + ;; tab-num: 2) (iup:callback-set! *tim* "ACTION_CB" (lambda (time-obj) (let ((update-is-running #f)) (mutex-lock! (dboard:commondat-update-mutex commondat)) @@ -3867,23 +3846,102 @@ (mutex-lock! (dboard:commondat-update-mutex commondat)) (dboard:commondat-updating-set! commondat #f) (mutex-unlock! (dboard:commondat-update-mutex commondat))) )) 1)))) - + (print "Starting updaters") (let ((th1 (make-thread (lambda () (thread-sleep! 1) (dboard:common-run-curr-updaters commondat 0) ;; force update of summary tab ) "update buttons once")) (th2 (make-thread iup:main-loop "Main loop"))) + (print "Starting main loop") (thread-start! th2) - (thread-join! th2))))) + (thread-join! th2) + ) + ) + ) +) + +(define last-copy-time 0) + + +;; Sync to tmp only if in read-only mode. + +(define (sync-db-to-tmp tabdat) + (let* ((db-file "./.megatest/main.db")) + (if (and (not (file-write-access? db-file)) ( > (current-seconds) (+ last-copy-time 5))) + (begin + (db:multi-db-sync (db:setup #f) 'old2new) + (set! last-copy-time (current-seconds)) + ) + ) + ) +) + +;; ########################### top level code ######################## +;; check for MT_* environment variables and exit if found +(if (not (args:get-arg "-test")) + (begin + (for-each (lambda (var) + ;; (display " ")(display var) + (if (get-environment-variable var) + (begin + (print "ERROR: environment variable " var " is set in this terminal, this will cause you problems. Exiting now.") + (exit 1)))) + '("MT_RUN_AREA_HOME" "MT_MEGATEST" "MT_CMDINFO" "MT_TEST_RUN_DIR" "MT_LINKTREE" "MT_TESTSUITENAME")) + ) +) + +(setenv "MT_RUN_AREA_HOME" (get-environment-variable "PWD")) + +(if (not (null? remargs)) + (if remargs + (begin + (print "Unrecognised arguments: " (string-intersperse remargs " ")) + (exit) + ) + (begin + (print help) + (exit) + ) + ) +) + +(if (args:get-arg "-h") + (begin + (print help) + (exit))) + + + + +(if (args:get-arg "-start-dir") + (if (directory-exists? (args:get-arg "-start-dir")) + (let ((fullpath (common:real-path (args:get-arg "-start-dir")))) + (setenv "PWD" fullpath) + (change-directory fullpath)) + (begin + (debug:print-error 0 *default-log-port* "non-existant start dir " (args:get-arg "-start-dir") " specified, exiting.") + (exit 1)))) + + +;; deal with RH 5.11 gtk lib or iup lib missing detachbox feature +;; first check for the switch +;; +(if (or + (configf:lookup *configdat* "dashboard" "no-detachbox") + (not (file-exists? "/etc/os-release"))) + (set! iup:detachbox iup:vbox)) + + ;; ease debugging by loading ~/.dashboardrc (let ((debugcontrolf (conc (get-environment-variable "HOME") "/.dashboardrc"))) (if (common:file-exists? debugcontrolf) (load debugcontrolf))) + (if (args:get-arg "-repl") (repl) (main)) Index: db.scm ================================================================== --- db.scm +++ db.scm @@ -22,17 +22,37 @@ ;; 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 + files) (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,43 +62,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 +92,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,37 +126,63 @@ (begin (debug:print-error 0 *default-log-port* " query " stmt " failed, params: " params ", error: " ((condition-property-accessor 'exn 'message) exn) ", exn=" exn) (print-call-chain (current-error-port)) default))) (apply sqlite3:first-result db stmt params))) + +(define (db:setup do-sync) + (assert *toppath* "FATAL: db:setup called before launch:setup has been run.") + (let* ((tmpdir (common:get-db-tmp-area))) + (if (not *dbstruct-dbs*) + (dbfile:setup do-sync *toppath* tmpdir) + *dbstruct-dbs*))) + +;; 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 @@ -164,71 +189,10 @@ ", error: " ((condition-property-accessor 'exn 'message) exn) ", arguments: " ((condition-property-accessor 'exn 'arguments) exn) ", location: " ((condition-property-accessor 'exn 'location) exn) )) -;; (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) - #f)) - (db (if have-struct - (db:dbdat-get-db dbdat) - dbstruct)) - (fname (db:dbdat-get-path dbdat)) - (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))) ;; 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 +206,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 +276,113 @@ (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))) - -;; sync run to disk if touched -;; -(define (db:sync-touched dbstruct run-id #!key (force-sync #f)) - (let ((tmpdb (db:get-db dbstruct)) - (mtdb (dbr:dbstruct-mtdb dbstruct)) - (refndb (dbr:dbstruct-refndb dbstruct)) - (start-t (current-seconds))) - (debug:print-info 4 *default-log-port* "Syncing for run-id: " run-id) - (mutex-lock! *db-multi-sync-mutex*) - (let ((update_info (cons (if force-sync 0 *db-last-sync*) "last_update"))) - (mutex-unlock! *db-multi-sync-mutex*) - (db:sync-tables (db:sync-all-tables-list dbstruct) update_info tmpdb refndb mtdb)) - (mutex-lock! *db-multi-sync-mutex*) - (set! *db-last-sync* start-t) - (set! *db-last-access* start-t) - (mutex-unlock! *db-multi-sync-mutex*) - (stack-push! (dbr:dbstruct-dbstack dbstruct) tmpdb))) - -(define (db:safely-close-sqlite3-db db 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)))))) + ;; (cons db dbpath))) + (make-dbr:dbdat dbfile: dbpath dbh: db read-only: (not write-access)))) + + + +;; 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)) @@ -498,114 +393,14 @@ ;; (handler (make-busy-timeout 3600))) ;; (sqlite3:set-busy-handler! db handler) ;; (db:initialize-run-id-db db) ;; (cons db #f))) -;; just tests, test_steps and test_data tables -(define db:sync-tests-only - (list - ;; (list "strs" - ;; '("id" #f) - ;; '("str" #f)) - (list "tests" - '("id" #f) - '("run_id" #f) - '("testname" #f) - '("host" #f) - '("cpuload" #f) - '("diskfree" #f) - '("uname" #f) - '("rundir" #f) - '("shortdir" #f) - '("item_path" #f) - '("state" #f) - '("status" #f) - '("attemptnum" #f) - '("final_logf" #f) - '("logdat" #f) - '("run_duration" #f) - '("comment" #f) - '("event_time" #f) - '("fail_count" #f) - '("pass_count" #f) - '("archived" #f) - '("last_update" #f)) - (list "test_steps" - '("id" #f) - '("test_id" #f) - '("stepname" #f) - '("state" #f) - '("status" #f) - '("event_time" #f) - '("comment" #f) - '("logfile" #f) - '("last_update" #f)) - (list "test_data" - '("id" #f) - '("test_id" #f) - '("category" #f) - '("variable" #f) - '("value" #f) - '("expected" #f) - '("tol" #f) - '("units" #f) - '("comment" #f) - '("status" #f) - '("type" #f) - '("last_update" #f)))) - -;; needs db to get keys, this is for syncing all tables -;; -(define (db:sync-main-list dbstruct) - (let ((keys (db:get-keys dbstruct))) - (list - (list "keys" - '("id" #f) - '("fieldname" #f) - '("fieldtype" #f)) - (list "metadat" '("var" #f) '("val" #f)) - (append (list "runs" - '("id" #f)) - (map (lambda (k)(list k #f)) - (append keys - (list "runname" "state" "status" "owner" "event_time" "comment" "fail_count" "pass_count" "contour" "last_update")))) - (list "archive_disks" - '("id" #f) - '("archive_area_name" #f) - '("disk_path" #f) - '("last_df" #f) - '("last_df_time" #f) - '("creation_time" #f)) - - (list "archive_blocks" - '("id" #f) - '("archive_disk_id" #f) - '("disk_path" #f) - '("last_du" #f) - '("last_du_time" #f) - '("creation_time" #f)) - - (list "test_meta" - '("id" #f) - '("testname" #f) - '("owner" #f) - '("description" #f) - '("reviewed" #f) - '("iterated" #f) - '("avg_runtime" #f) - '("avg_disk" #f) - '("tags" #f) - '("jobgroup" #f))))) - -(define (db:sync-all-tables-list dbstruct) - (append (db:sync-main-list dbstruct) - 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 +417,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)) @@ -675,213 +470,10 @@ (sqlite3:execute db "vacuum;"))) (sqlite3:finalize! db) #t)))))) -;; tbls is ( ("tablename" ( "field1" [#f|proc1] ) ( "field2" [#f|proc2] ) .... ) ) -;; db's are dbdat's -;; -;; if last-update specified ("field-name" . time-in-seconds) -;; then sync only records where field-name >= time-in-seconds -;; IFF field-name exists -;; -(define (db:sync-tables tbls last-update fromdb todb . slave-dbs) - (handle-exceptions - exn - (begin - (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)) - (for-each (lambda (dbdat) - (let ((dbpath (db:dbdat-get-path 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 - (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))) - (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))) - (debug:print-error 0 *default-log-port* "db:sync-tables called with todb not a database " todb) - -4) - - ((not (file-write-access? (db:dbdat-get-path 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)))) - 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 - (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)) - (for-each ;; table - (lambda (tabledat) - (let* ((tablename (car tabledat)) - (fields (cdr tabledat)) - (has-last-update (member "last_update" fields)) - (use-last-update (cond - ((and has-last-update - (member "last_update" fields)) - #t) ;; if given a number, just use it for all fields - ((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 - (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 - (if (number? last-update) - last-update - (cdr last-update)) - #f)) - (last-update-field (if use-last-update - (if (number? last-update) - "last_update" - (car last-update)) - #f)) - (num-fields (length fields)) - (field->num (make-hash-table)) - (num->field (apply vector (map car fields))) ;; BBHERE - (full-sel (conc "SELECT " (string-intersperse (map car fields) ",") - " FROM " tablename (if use-last-update ;; apply last-update criteria - (conc " WHERE " last-update-field " >= " last-update-value) - "") - ";")) - (full-ins (conc "INSERT OR REPLACE INTO " tablename " ( " (string-intersperse (map car fields) ",") " ) " - " VALUES ( " (string-intersperse (make-list num-fields "?") ",") " );")) - (fromdat '()) - (fromdats '()) - (totrecords 0) - (batch-len (string->number (or (configf:lookup *configdat* "sync" "batchsize") "100"))) - (todat (make-hash-table)) - (count 0) - (field-names (map car fields)) - (delay-handicap (string->number (or (configf:lookup *configdat* "sync" "delay-handicap") "0"))) - ) - - ;; set up the field->num table - (for-each - (lambda (field) - (hash-table-set! field->num field count) - (set! count (+ count 1))) - fields) - - ;; read the source table - (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) - full-sel) - - ;; 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")) - - ;; 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) - 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)) - (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))) - ;; (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 () - (for-each ;; - (lambda (fromrow) - (let* ((a (vector-ref fromrow 0)) - (curr (hash-table-ref/default todat a #f)) - (same #t)) - (let loop ((i 0)) - (if (or (not curr) - (not (equal? (vector-ref fromrow i)(vector-ref curr i)))) - (set! same #f)) - (if (and same - (< 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))))))) - fromdat-lst)))) - fromdats) - (sqlite3:finalize! stmth) - (if (member "last_update" field-names) - (db:create-trigger db tablename)))) - (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")) - (for-each - (lambda (dat) - (let ((tblname (car dat)) - (count (cdr dat))) - (set! tot-count (+ tot-count count)) - (if (> count 0) - (if should-print (debug:print 0 *default-log-port* (format #f " ~10a ~5a" tblname count)))))) - (sort (hash-table->alist numrecs)(lambda (a b)(> (cdr a)(cdr b)))))) - tot-count))))) (define (db:patch-schema-rundb frundb) ;; ;; remove this some time after September 2016 (added in version v1.6031 ;; @@ -1042,20 +634,74 @@ ;; (lambda () ;; (if (and (common:file-exists? megatest-db) ;; (file-write-access? megatest-db)) ;; (begin ;; (db:sync-to-megatest.db dbstruct 'timestamps) ;; internally mutexes on *db-local-sync* -;; (debug:print-info 2 *default-log-port* "Done syncing to megatest.db")))) +;; (debug:print-info 2 *default-log-port* "Done syncing to megatest.db")))) ;; "call-with-cached-db sync-to-megatest.db")) ;; (cache-db (db:cache-for-read-only ;; megatest-db ;; (conc cache-dir "/" fname) ;; use-last-update: #t))) ;; (thread-start! th1) ;; (apply proc cache-db params) ;; )))) + + + +(define (db:all-db-sync dbstruct) + (let* ((dbdat (db:open-db dbstruct #f db:initialize-main-db)) + (data-synced 0) ;; count of changed records + (tmp-area (common:get-db-tmp-area)) + (dbfiles (glob (conc tmp-area"/.megatest/*.db"))) + (sync-durations (make-hash-table)) + (no-sync-db (db:open-no-sync-db))) + (for-each + (lambda (file) + (debug:print-info 3 *default-log-port* "file: " file) + (let* ((fname (conc (pathname-file file) ".db")) + (fulln (conc *toppath*"/.megatest/"fname)) + (time1 (if (file-exists? file) + (file-modification-time file) + (begin + (debug:print-info 2 *default-log-port* "Sync - I do not see file "file) + 1))) + (time2 (if (file-exists? fulln) + (file-modification-time fulln) + (begin + (debug:print-info 2 *default-log-port* "Sync - I do not see file "fulln) + 0))) + (changed (> (- time1 time2) (+ (random 5) 1))) ;; it has been at some few seconds since last synced + (changed10 (> (- time1 time2) 10)) ;; it has been at least ten seconds since sync'd + (jfile-exists (file-exists? (conc file"-journal"))) ;; i.e. are we busy? + (do-cp (cond + ((not (file-exists? fulln)) ;; shouldn't happen, but this might recover + (cons #t (conc "File "fulln" not found! Copying "fname" to "fulln))) + ((and (not jfile-exists) changed) + (cons #t "not busy, changed")) ;; not busy and changed + ((and jfile-exists changed10) + (cons #t "busy but not synced in a while")) ;; busy but not sync'd in over 10 seconds + ((and changed *time-to-exit*) + (cons #t "Time to exit, forced final sync")) ;; last sync + (else + (cons #f "No sync needed"))))) + (if (car do-cp) + (let* ((start-time (current-milliseconds)) + (fname (pathname-file file)) + (runid (if (string= fname "main") #f (string->number fname)))) + (debug:print-info 3 *default-log-port* "db:all-db-sync: fname: " + fname", delta: " (- time1 time2) " seconds, reason: "(cdr do-cp)) + (db:lock-and-delta-sync no-sync-db dbstruct fname runid (db:get-keys dbstruct) db:initialize-main-db) + (hash-table-set! sync-durations (conc fname".db") + (- (current-milliseconds) start-time))) + (debug:print-info 3 *default-log-port* "skipping sync. " file " is up to date") + ))) + dbfiles) + (if dbdat (dbfile:add-dbdat dbstruct #f dbdat))) + #t) + ;; options: ;; ;; 'killservers - kills all servers ;; 'dejunk - removes junk records ;; 'adj-testids - move test-ids into correct ranges @@ -1064,26 +710,27 @@ ;; '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 + (let* (;; (dbdat (db:open-db dbstruct #f dbfile:db-init-proc)) + (data-synced 0) ;; count of changed records + (tmp-area (common:get-db-tmp-area)) + (old2new (member 'old2new options)) + (dejunk (member 'dejunk options)) + (killservers (member 'killservers options)) + (servers (server:get-list *toppath*)) + (src-area (if old2new *toppath* tmp-area)) + (dest-area (if old2new tmp-area *toppath*)) + (dbfiles (if old2new (glob (conc *toppath* "/.megatest/*.db")) (glob (conc tmp-area "/.megatest/*.db")))) + (keys (db:get-keys dbstruct)) + (sync-durations (make-hash-table))) + + + (if killservers + (begin + (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) @@ -1090,61 +737,95 @@ #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) + ) + ) + (for-each + (lambda (srcfile) + (debug:print-info 3 *default-log-port* "file: " srcfile) + (let* ((fname (conc (pathname-file srcfile) ".db")) + (basename (pathname-file srcfile)) + (run-id (if (string= basename "main") #f (string->number basename))) + (destfile (conc dest-area "/.megatest/" fname)) + (dest-directory (conc dest-area "/.megatest/")) + (dummy (debug:print-info 2 *default-log-port* "destfile = " destfile)) + (dummy2 (debug:print-info 2 *default-log-port* "dejunk = " dejunk)) + (time1 (file-modification-time srcfile)) + (time2 (if (file-exists? destfile) + (begin + (debug:print-info 2 *default-log-port* "destfile " destfile " exists") + (file-modification-time destfile) + ) + (begin + (debug:print-info 0 *default-log-port* "Sync - I do not see file " destfile) + 0))) + (changed ( < (- time2 time1) 6.0)) ;; dest db not updated within last 6 seconds + + (do-cp (cond + ((not (file-exists? destfile)) ;; shouldn't happen, but this might recover + (debug:print-info 2 *default-log-port* "File " destfile " not found. Copying "srcfile" to "destfile) + (system (conc "/bin/mkdir -p " dest-directory)) + (system (conc "/bin/cp " srcfile " " destfile)) + #t) + (changed ;; (and changed + ;; (> (- (current-seconds) time1) 3)) ;; if file is changed and three seconds have passed. + #t) + ((and changed *time-to-exit*) ;; last sync + #t) + (else + #f)))) + (if (or dejunk do-cp) + (let* ( + (start-time (current-milliseconds)) + + (subdb (or (dbfile:get-subdb dbstruct run-id) (dbfile:init-subdb dbstruct run-id dbfile:db-init-proc))) + (mtdb (dbr:subdb-mtdbdat subdb)) + (tmpdb (dbfile:open-db dbstruct run-id dbfile:db-init-proc)) + + ) + (debug:print-info 2 *default-log-port* "delta syncing file: " srcfile ", time diff: " (- time1 time2) " seconds") + + (if old2new + (begin + (if dejunk (db:clean-up run-id mtdb)) + (db:sync-tables (db:sync-all-tables-list dbstruct (db:get-keys dbstruct)) #f mtdb tmpdb) + ) + (begin + (if dejunk (db:clean-up run-id tmpdb)) + (db:sync-tables (db:sync-all-tables-list dbstruct (db:get-keys dbstruct)) #f tmpdb mtdb) + ) + ) + (hash-table-set! sync-durations (conc srcfile ".db") (- (current-milliseconds) start-time))) + (debug:print-info 2 *default-log-port* "skipping delta sync. " srcfile " is up to date") + ) + ) + ) + dbfiles + ) + data-synced + ) +) + +;; Sync all changed db's +;; +(define (db:tmp->megatest.db-sync dbstruct run-id last-update) + (let* ((subdbs (hash-table-values (dbr:dbstruct-subdbs dbstruct))) + (res '())) + (for-each + (lambda (subdb) + (let* ((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 (db:get-keys dbstruct)) last-update tmpdb refndb mtdb))) + ;; (stack-push! (dbr:subdb-dbstack subdb) tmpdb) + (dbfile:add-dbdat dbstruct run-id tmpdb) + (set! res (cons newres res)))) + subdbs) res)) ;;;; run-ids ;; if #f use *db-local-sync* : or 'local-sync-flags ;; if #t use timestamps : or 'timestamps @@ -1186,11 +867,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)) @@ -1223,107 +904,20 @@ #;(define open-run-close open-run-close-exception-handling) ;; open-run-close-no-exception-handling ;; open-run-close-exception-handling) ;;) -(define db:trigger-list - (list (list "update_runs_trigger" "CREATE TRIGGER IF NOT EXISTS update_runs_trigger AFTER UPDATE ON runs - FOR EACH ROW - BEGIN - UPDATE runs SET last_update=(strftime('%s','now')) - WHERE id=old.id; - END;" ) - (list "update_run_stats_trigger" "CREATE TRIGGER IF NOT EXISTS update_run_stats_trigger AFTER UPDATE ON run_stats - FOR EACH ROW - BEGIN - UPDATE run_stats SET last_update=(strftime('%s','now')) - WHERE id=old.id; - END;" ) - (list "update_tests_trigger" "CREATE TRIGGER IF NOT EXISTS update_tests_trigger AFTER UPDATE ON tests - FOR EACH ROW - BEGIN - UPDATE tests SET last_update=(strftime('%s','now')) - WHERE id=old.id; - END;" ) - (list "update_teststeps_trigger" "CREATE TRIGGER IF NOT EXISTS update_teststeps_trigger AFTER UPDATE ON test_steps - FOR EACH ROW - BEGIN - UPDATE test_steps SET last_update=(strftime('%s','now')) - WHERE id=old.id; - END;" ) - (list "update_test_data_trigger" "CREATE TRIGGER IF NOT EXISTS update_test_data_trigger AFTER UPDATE ON test_data - FOR EACH ROW - BEGIN - UPDATE test_data SET last_update=(strftime('%s','now')) - WHERE id=old.id; - END;" ))) - -(define (db:create-all-triggers dbstruct) -(db:with-db - dbstruct #f #f - (lambda (db) -(db:create-triggers db)))) - -(define (db:create-triggers db) - (for-each (lambda (key) - (sqlite3:execute db (cadr key))) - db:trigger-list)) - -(define (db:drop-all-triggers dbstruct) - (db:with-db - dbstruct #f #f - (lambda (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" - (conc "update_" tbl-name "_trigger"))) - (res #f)) - (sqlite3:for-each-row - (lambda (name) - (if (equal? name trigger-name) - (set! res #t))) - db - "SELECT name FROM sqlite_master WHERE type = 'trigger' ;" - ))) - -(define (db:drop-triggers db) - (for-each - (lambda (key) - (sqlite3:execute db (conc "drop trigger if exists " (car key)))) - db:trigger-list)) - -(define (db:drop-trigger db tbl-name) - (let* ((trigger-name (if (equal? tbl-name "test_steps") - "update_teststeps_trigger" - (conc "update_" tbl-name "_trigger")))) - (for-each - (lambda (key) - (if (equal? (car key) trigger-name) - (sqlite3:execute db (conc "drop trigger if exists " trigger-name)))) - db:trigger-list))) - -(define (db:create-trigger db tbl-name) - (let* ((trigger-name (if (equal? tbl-name "test_steps") - "update_teststeps_trigger" - (conc "update_" tbl-name "_trigger")))) - (for-each (lambda (key) - (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 +1133,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 +1145,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))) @@ -1577,19 +1170,19 @@ "SELECT d.id,d.archive_area_name,disk_path,last_df,last_df_time FROM archive_disks AS d INNER JOIN archive_blocks AS b ON d.id=b.archive_disk_id WHERE b.id IN (" (string-intersperse (map conc res) ",") ") AND last_df > ?;") dneeded)) - (stack-push! (dbr:dbstruct-dbstack dbstruct) dbdat) + (dbfile:add-dbdat dbstruct #f dbdat) blocks)) ;; returns id of the record, register a disk allocated to archiving and record it's last known ;; available space ;; (define (db:archive-register-disk dbstruct bdisk-name bdisk-path df) - (let* ((dbdat (db:get-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 @@ -1598,28 +1191,28 @@ (if res ;; record exists, update df and return id (begin (sqlite3:execute db "UPDATE archive_disks SET last_df=?,last_df_time=(strftime('%s','now')) WHERE archive_area_name=? AND disk_path=?;" df bdisk-name bdisk-path) - (stack-push! (dbr:dbstruct-dbstack dbstruct) dbdat) + (dbfile:add-dbdat dbstruct #f dbdat) res) (begin (sqlite3:execute db "INSERT OR REPLACE INTO archive_disks (archive_area_name,disk_path,last_df) VALUES (?,?,?);" bdisk-name bdisk-path df) - (stack-push! (dbr:dbstruct-dbstack dbstruct) dbdat) + (dbfile:add-dbdat dbstruct #f dbdat) (db:archive-register-disk dbstruct bdisk-name bdisk-path df))))) ;; record an archive path created on a given archive disk (identified by it's bdisk-id) ;; if path starts with / then it is full, otherwise it is relative to the archive disk ;; preference is to store the relative path. ;; (define (db:archive-register-block-name dbstruct bdisk-id archive-path #!key (du #f)) - (let* ((dbdat (db:get-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)) @@ -1633,11 +1226,11 @@ (begin (sqlite3:execute db "INSERT OR REPLACE INTO archive_blocks (archive_disk_id,disk_path,last_du) VALUES (?,?,?);" bdisk-id archive-path (or du 0)) (set! res (db:archive-register-block-name dbstruct bdisk-id archive-path du: du)))) - (stack-push! (dbr:dbstruct-dbstack dbstruct) dbdat) + (dbfile:add-dbdat dbstruct #f dbdat) res)) ;; The "archived" field in tests is overloaded; 0 = not archived, > 0 archived in block with given id ;; @@ -1644,11 +1237,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 +1248,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 +1260,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 +1317,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 @@ -1774,12 +1367,12 @@ (define (db:get-status-from-final-status-file run-dir) (let ((infile (conc run-dir "/.final-status"))) ;; first verify we are able to write the output file (if (not (file-read-access? infile)) (begin - (debug:print 0 *default-log-port* "ERROR: cannot read " infile) - (debug:print 0 *default-log-port* "ERROR: run-dir is " run-dir) + (debug:print 2 *default-log-port* "ERROR: cannot read " infile) + (debug:print 2 *default-log-port* "ERROR: run-dir is " run-dir) #f ) (with-input-from-file infile read-lines) ))) @@ -1807,24 +1400,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 +1521,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: ;; @@ -1941,54 +1534,20 @@ ;; b. If test dir gone, delete the test record ;; 2. Look at run records ;; a. If have tests that are not deleted, set state='unknown' ;; b. .... ;; -(define (db:clean-up dbdat) - ;; (debug:print 0 *default-log-port* "WARNING: db clean up not fully ported to v1.60, cleanup action will be on megatest.db") - (let* ((keep-record-age ( - (current-seconds) (common:hms-string->seconds (or (configf:lookup *configdat* "setup" "delete-record-age") "30d")))) - (db (db:dbdat-get-db dbdat)) - (count-stmt (sqlite3:prepare db "SELECT (SELECT count(id) FROM tests)+(SELECT count(id) FROM runs);")) - (statements - (map (lambda (stmt) - (sqlite3:prepare db stmt)) - (list - ;; delete all tests that belong to runs that are 'deleted' - (conc "DELETE FROM tests WHERE run_id in (SELECT id FROM runs WHERE state='deleted') and last_update < " keep-record-age ";") - ;; delete all tests that are 'DELETED' - (conc "DELETE FROM tests WHERE state='DELETED' and last_update < " keep-record-age " ;") - ;; delete all tests that have no run - (conc "DELETE FROM tests WHERE run_id NOT IN (SELECT DISTINCT id FROM runs) and last_update < " keep-record-age "; ") - ;; delete all runs that are state='deleted' - (conc "DELETE FROM runs WHERE state='deleted' and last_update < " keep-record-age ";") - ;; delete empty runs - (conc "DELETE FROM runs WHERE id NOT IN (SELECT DISTINCT r.id FROM runs AS r INNER JOIN tests AS t ON t.run_id=r.id) and last_update < " keep-record-age ";") - ;; remove orphaned test_rundat entries - (conc "DELETE FROM test_rundat where test_id NOT IN (SELECT id FROM tests);") - ;; remove orphaned test_steps entries - (conc "DELETE FROM test_steps WHERE test_id NOT IN (SELECT id FROM tests);") - ;; remove orphaned test_dat entries - (conc "DELETE FROM test_data WHERE test_id NOT IN (SELECT id FROM tests);") - - )))) - ;; (db:delay-if-busy dbdat) - ;(debug:print-info 0 *default-log-port* statements) - (sqlite3:with-transaction - db - (lambda () - (sqlite3:for-each-row (lambda (tot) - (debug:print-info 0 *default-log-port* "Records count before clean: " tot)) - count-stmt) - (map sqlite3:execute statements) - (sqlite3:for-each-row (lambda (tot) - (debug:print-info 0 *default-log-port* "Records count after clean: " tot)) - count-stmt))) - (map sqlite3:finalize! statements) - (sqlite3:finalize! count-stmt) - ;; (db:find-and-mark-incomplete db) - ;; (db:delay-if-busy dbdat) - (sqlite3:execute db "VACUUM;"))) +(define (db:clean-up run-id dbdat) + (debug:print 2 *default-log-port* "db:clean-up") + + + (if run-id + (db:clean-up-rundb dbdat) + (db:clean-up-maindb dbdat) + ) +) + ;; Clean out old junk and vacuum the database ;; ;; Ultimately do something like this: ;; @@ -1999,11 +1558,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 +1599,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 +1644,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 +1659,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 +1681,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 +1730,24 @@ ;; 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 +1787,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 +1804,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 +1819,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 @@ -2351,18 +1863,22 @@ (andstr (if (> (length keys) 0) " AND " "")) (valslots (keys->valslots keys)) ;; ?,?,? ... (allvals (append (list runname state status user contour) (map cadr keyvals))) (qryvals (append (list runname) (map cadr keyvals))) (key=?str (string-intersperse (map (lambda (k)(conc k "=?")) keys) " AND "))) + ;; (debug:print 0 *default-log-port* "Got here 0.") (debug:print 3 *default-log-port* "keys: " keys " allvals: " allvals " keyvals: " keyvals " key=?str is " key=?str) (debug:print 2 *default-log-port* "NOTE: using target " (string-intersperse (map cadr keyvals) "/") " for this run") (if (and runname (null? (filter (lambda (x)(not x)) keyvals))) ;; there must be a better way to "apply and" (db:with-db dbstruct #f #f - (lambda (db) + (lambda (dbdat db) + ;; (debug:print 0 *default-log-port* "Got here 1.") (let ((res #f)) - (apply sqlite3:execute db (conc "INSERT OR IGNORE INTO runs (runname,state,status,owner,event_time,contour" comma keystr ") VALUES (?,?,?,?,strftime('%s','now'),?" comma valslots ");") + (apply sqlite3:execute db + (conc "INSERT OR IGNORE INTO runs (runname,state,status,owner,event_time,contour" + comma keystr ") VALUES (?,?,?,?,strftime('%s','now'),?" comma valslots ");") allvals) (apply sqlite3:for-each-row (lambda (id) (set! res id)) db @@ -2406,11 +1922,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 +1965,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 @@ -2461,19 +1977,21 @@ (debug:print-info 11 *default-log-port* "db:get-runs END qrystr: " qrystr " target: " target " offset: " offset " limit: " count) res)) ;; TODO: Switch this to use max(update_time) from each run db? Then if using a server there is no disk traffic (using inmem db) ;; +;; NOTE: This DOESN'T (necessarily) get the real run ids, but the number of the .db!! + (define (db:get-changed-run-ids since-time) (let* ((dbdir (db:dbfile-path)) ;; (configf:lookup *configdat* "setup" "dbdir")) - (alldbs (glob (conc dbdir "/[0-9]*.db"))) + (alldbs (glob (conc dbdir "/.megatest/[0-9]*.db"))) (changed (filter (lambda (dbfile) (> (file-modification-time dbfile) since-time)) alldbs))) (delete-duplicates (map (lambda (dbfile) - (let* ((res (string-match ".*\\/(\\d)*\\.db" dbfile))) + (let* ((res (string-match ".*\\/(\\d\\d)\\.db" dbfile))) (if res (string->number (cadr res)) (begin (debug:print 2 *default-log-port* "WARNING: Failed to process " dbfile " for run-id") 0)))) @@ -2490,11 +2008,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 +2027,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 +2044,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 +2082,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 +2101,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 +2125,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 +2158,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 +2182,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 +2198,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 +2260,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 +2286,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 +2301,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 +2322,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 +2341,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 +2371,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 +2392,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 +2409,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 +2441,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 +2536,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 +2573,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 +2603,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 +2617,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 +2652,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 +2668,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 +2986,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 +3015,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 +3031,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 +3046,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 +3062,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 +3080,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 +3096,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,26 +3109,26 @@ (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 "SELECT id,test_id,stepname,state,status,event_time,logfile,comment FROM test_steps WHERE status != 'DELETED' AND test_id=? ORDER BY id ASC;" ;; event_time DESC,id ASC; test-id) (reverse res))))) - (define (db:get-steps-info-by-id dbstruct test-step-id) + (define (db:get-steps-info-by-id dbstruct run-id test-step-id) (db:with-db dbstruct - #f + run-id #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 +3139,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 @@ -3636,18 +3153,18 @@ ;;====================================================================== ;; T E S T D A T A ;;====================================================================== -(define (db:get-data-info-by-id dbstruct test-data-id) +(define (db:get-data-info-by-id dbstruct run-id test-data-id) (let* ((stmt "SELECT id,test_id, category, variable, value, expected, tol, units, comment, status, type, last_update FROM test_data WHERE id=? ORDER BY id ASC;")) ;; event_time DESC,id ASC; (db:with-db dbstruct - #f + run-id #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 +3178,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 +3278,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 +3341,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 +3355,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 +3371,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 +3398,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 +3412,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 +3463,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 +3478,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 +3496,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 +3528,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 +3623,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 +3673,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 +3859,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 +3892,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 +3937,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 +3948,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 +3984,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 +4027,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 +4046,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 +4068,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 +4080,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 @@ -4830,50 +4347,160 @@ ;;====================================================================== ;; To sync individual run ;;====================================================================== (define (db:get-run-record-ids dbstruct target run keynames test-patt) -(let ((backcons (lambda (lst item)(cons item lst)))) - (db:with-db - dbstruct #f #f - (lambda (db) - (let* ((keystr (string-intersperse - (map (lambda (key val) + (let* ((backcons (lambda (lst item)(cons item lst))) + (all_tests '()) + (all_test_steps '()) + (all_test_data '()) + (keystr (string-intersperse + (map (lambda (key val) (conc key " like '" val "'")) - keynames - (string-split target "/")) - " AND ")) + keynames + (string-split target "/")) + " AND ") + ) (run-qry (conc "SELECT id FROM runs WHERE " keystr " and runname='" run"'")) - (test-qry (conc "SELECT id FROM tests WHERE run_id in (" run-qry ") and testname like '" test-patt "'"))) - (print run-qry) - (print test-qry) - `((runs . ,(sqlite3:fold-row backcons '() db run-qry)) - (tests . ,(sqlite3:fold-row backcons '() db test-qry)) - (test_steps . ,(sqlite3:fold-row backcons '() db (conc "SELECT id FROM test_steps WHERE test_id in (" test-qry ")"))) - (test_data . ,(sqlite3:fold-row backcons '() db (conc "SELECT id FROM test_data WHERE test_id in (" test-qry ")" ))) - )))))) + (test-qry (conc "SELECT id FROM tests WHERE run_id in (" run-qry ") and testname like '" test-patt "'")) + (run_ids + (db:with-db dbstruct #f #f + (lambda (dbdat db) + (sqlite3:fold-row backcons '() db run-qry)) + ) + ) + ) + (for-each + (lambda (run_id) + (set! all_tests + (append + (map (lambda (x) (cons x run_id)) + (db:with-db dbstruct run_id #f + (lambda (dbdat db) + (sqlite3:fold-row backcons '() db (conc "SELECT id FROM tests WHERE run_id in (" run_id ") and testname like '" test-patt "'")) + ) + ) + ) all_tests + ) + ) + (set! all_test_steps + (append + (map (lambda (x) (cons x run_id)) + (db:with-db dbstruct run_id #f + (lambda (dbdat db) + (sqlite3:fold-row backcons '() db (conc "SELECT id FROM test_steps WHERE test_id in (" test-qry ")")) + ) + ) + ) all_test_steps + ) + ) + (set! all_test_data + (append + (map (lambda (x) (cons x run_id)) + (db:with-db dbstruct run_id #f + (lambda (dbdat db) + (sqlite3:fold-row backcons '() db (conc "SELECT id FROM test_data WHERE test_id in (" test-qry ")")) + ) + ) + ) all_test_data + ) + ) + ) + run_ids + ) + `((runs . ,run_ids) + (tests . ,all_tests) + (test_steps . ,all_test_steps) + (test_data . ,all_test_data) + ) + + ) +) ;;====================================================================== ;; Just for sync, procedures to make sync easy ;;====================================================================== -;; get an alist of record ids changed since time since-time -;; '((runs . (1 2 3 ...))(steps . (5 6 7 ...) ...)) +;; get an alist of run ids and test/run, test_step/run pairs changed since time since-time +;; '((runs . (1 2 3 ...))(tests . ((5 . 1) (6 . 3) (6 . 2) (7 . 1) ... ;; (define (db:get-changed-record-ids dbstruct since-time) ;; no transaction, allow the db to be accessed between the big queries - (let ((backcons (lambda (lst item)(cons item lst)))) - (db:with-db - dbstruct #f #f - (lambda (db) - `((runs . ,(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)) - (run_stats . ,(sqlite3:fold-row backcons '() db "SELECT id FROM run_stats WHERE last_update>=?" since-time)) - ))))) + (let* ((backcons (lambda (lst item)(cons item lst))) + (all_tests '()) + (all_test_steps '()) + (all_test_data '()) + (changed_run_dbs (db:get-changed-run-ids since-time)) ;; gets the rundb numbers + (all_run_ids + (db:with-db dbstruct #f #f + (lambda (dbdat db) + (sqlite3:fold-row backcons '() db "SELECT id FROM runs")) + ) + ) + (changed_run_ids (filter (lambda (run) (member (modulo run 100) changed_run_dbs)) all_run_ids)) + (run_ids + (db:with-db dbstruct #f #f + (lambda (dbdat db) + (sqlite3:fold-row backcons '() db "SELECT id FROM runs WHERE last_update>=?" since-time)) + ) + ) + (run_stat_ids + (db:with-db dbstruct #f #f + (lambda (dbdat db) + (sqlite3:fold-row backcons '() db "SELECT id FROM run_stats WHERE last_update>=?" since-time)) + ) + ) + ) + (for-each + (lambda (run_id) + (set! all_tests + (append + (map (lambda (x) (cons x run_id)) + (db:with-db dbstruct run_id #f + (lambda (dbdat db) + (sqlite3:fold-row backcons '() db "SELECT id FROM tests WHERE run_id=? and last_update>=?" run_id since-time) + ) + ) + ) all_tests + ) + ) + (set! all_test_steps + (append + (map (lambda (x) (cons x run_id)) + (db:with-db dbstruct run_id #f + (lambda (dbdat db) + (sqlite3:fold-row backcons '() db "SELECT id FROM test_steps WHERE last_update>=?" since-time) + ) + ) + ) all_test_steps + ) + ) + (set! all_test_data + (append + (map (lambda (x) (cons x run_id)) + (db:with-db dbstruct run_id #f + (lambda (dbdat db) + (sqlite3:fold-row backcons '() db "SELECT id FROM test_data WHERE last_update>=?" since-time) + ) + ) + ) all_test_data + ) + ) + ) + changed_run_ids + ) + (debug:print 2 *default-log-port* "run_ids = " run_ids) + (debug:print 2 *default-log-port* "all_tests = " all_tests) + + `((runs . ,run_ids) + (tests . ,all_tests) + (test_steps . ,all_test_steps) + (test_data . ,all_test_data) + (run_stats . ,run_stat_ids) + ) + ) +) ;;====================================================================== ;; Extract ods file from the db ;;====================================================================== @@ -4880,16 +4507,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 @@ -4996,11 +4624,427 @@ (begin (debug:print 0 *default-log-port* "WARNING: path given, " outputfile " is relative, prefixing with current directory") (conc (current-directory) "/" outputfile))) results) ;; brutal clean up - (stack-push! (dbr:dbstruct-dbstack dbstruct) dbdat) + (dbfile:add-dbdat dbstruct #f dbdat) (system "rm -rf tempdir"))) ;; (db:extract-ods-file db "outputfile.ods" '(("sysname" "%")("fsname" "%")("datapath" "%")) "%") +;;====================================================================== +;; moving watch dogs here due to dependencies +;;====================================================================== + +;;====================================================================== +;; currently the primary job of the watchdog is to run the sync back to megatest.db from the db in /tmp +;; if we are on the homehost and we are a server (by definition we are on the homehost if we are a server) +;; +(define (common:readonly-watchdog dbstruct) + (thread-sleep! 0.05) ;; delay for startup + (debug:print-info 13 *default-log-port* "common:readonly-watchdog entered.") + ;; sync megatest.db to /tmp/.../megatst.db + (let* ((sync-cool-off-duration 3) + (golden-mtdb (dbr:dbstruct-mtdb dbstruct)) + (golden-mtpath (db:dbdat-get-path golden-mtdb)) + (tmp-mtdb (dbr:dbstruct-tmpdb dbstruct)) + (tmp-mtpath (db:dbdat-get-path tmp-mtdb))) + (debug:print-info 0 *default-log-port* "Read-only periodic sync thread started.") + (let loop ((last-sync-time 0)) + (debug:print-info 13 *default-log-port* "loop top tmp-mtpath="tmp-mtpath" golden-mtpath="golden-mtpath) + (let* ((duration-since-last-sync (- (current-seconds) last-sync-time))) + (debug:print-info 13 *default-log-port* "duration-since-last-sync="duration-since-last-sync) + (if (and (not *time-to-exit*) + (< duration-since-last-sync sync-cool-off-duration)) + (thread-sleep! (- sync-cool-off-duration duration-since-last-sync))) + (if (not *time-to-exit*) + (let ((golden-mtdb-mtime (file-modification-time golden-mtpath)) + (tmp-mtdb-mtime (file-modification-time tmp-mtpath))) + (if (> golden-mtdb-mtime tmp-mtdb-mtime) + (if (< golden-mtdb-mtime (- (current-seconds) 3)) ;; file has NOT been touched in past three seconds, this way multiple servers won't fight to sync back + (let ((res (db:multi-db-sync dbstruct 'old2new))) + (debug:print-info 13 *default-log-port* "rosync called, " res " records transferred.")))) + (loop (current-seconds))) + #t))) + (debug:print-info 0 *default-log-port* "Exiting readonly-watchdog timer, *time-to-exit* = " *time-to-exit*" pid="(current-process-id)" mtpath="golden-mtpath))) + +;;====================================================================== +;; 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 no-sync-db) + (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 + ;; sync all dbs for this area + + + + + (db:all-db-sync dbstruct) + #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"/.megatest/*.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*"/.megatest/"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,1353 @@ +;;====================================================================== +;; 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 + matchable) + +(import (prefix sqlite3 sqlite3:) + posix typed-records srfi-18 srfi-1 + 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) ;; .megatest/1.db + (mtdbfile #f) ;; mtrah/.megatest/1.db + (mtdbdat #f) ;; only need one of these for syncing + ;; (dbdats (make-hash-table)) ;; id => dbdat + (tmpdbfile #f) ;; /tmp/.../.megatest/1.db + ;; (refndbfile #f) ;; /tmp/.../.megatest/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) + (birth-sec (current-seconds))) + +(define *dbstruct-dbs* #f) +(define *db-open-mutex* (make-mutex)) +(define *db-access-mutex* (make-mutex)) ;; used in common.scm +(define *no-sync-db* #f) +(define *db-sync-in-progress* #f) +(define *db-with-db-mutex* (make-mutex)) +(define *max-api-process-requests* 0) +(define *api-process-request-count* 0) +(define *db-write-access* #t) +(define *db-last-sync* 0) ;; last time the sync to megatest.db happened +(define *db-multi-sync-mutex* (make-mutex)) ;; protect access to *db-sync-in-progress*, *db-last-sync* + +(define (db:generic-error-printout exn . message) + (print-call-chain (current-error-port)) + (apply dbfile:print-err message) + (dbfile:print-err + ", error: " ((condition-property-accessor 'exn 'message) exn) + ", arguments: " ((condition-property-accessor 'exn 'arguments) exn) + ", location: " ((condition-property-accessor 'exn 'location) exn) + )) + +(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)) + +;; POTENTIAL BUG: this implementation could produce a db file if run-id is neither #f or a number +(define (dbfile:run-id->dbname run-id) + (cond + ((number? run-id) (conc ".megatest/" (modulo run-id 100) ".db")) + ((not run-id) (conc ".megatest/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* + (dbfile:print-err "WARNING: dbfile:setup called when *dbstruct-dbs* is already initialized") + *dbstruct-dbs*) ;; TODO: when multiple areas are supported, this optimization will be a hazard + (else + (let* ((dbstruct (make-dbr:dbstruct))) + (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* ((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)) + +(define *dbfile:num-handles-in-use* 0) + +;; 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 + (begin + (set! *dbfile:num-handles-in-use* (+ *dbfile:num-handles-in-use* 1)) + (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))) + (set! *dbfile:num-handles-in-use* (- *dbfile:num-handles-in-use* 1)) + (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 +;; +;; NOTE: the handle is on /tmp db file! +;; +;; 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) + (if (> *dbfile:num-handles-in-use* 10) + (let* ((wait-delay (- *dbfile:num-handles-in-use* 9))) + (dbfile:print-err "INFO: over ten dbfile handle threads in use ("*dbfile:num-handles-in-use*") delaying "wait-delay" second") + (thread-sleep! wait-delay))) + + (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 +;; + +;; this stuff is for initial debugging, please remove it when +;; this code stabilizes +(define *dbopens* (make-hash-table)) +(define (dbfile:inc-db-open dbfile) + (let* ((curr-opens-count (+ (hash-table-ref/default *dbopens* dbfile 0) 1))) + ;; (if (> curr-opens-count 1) ;; this should NOT be happening + ;; (dbfile:print-err "INFO: db "dbfile" has been opened "curr-opens-count" times!")) + (hash-table-set! *dbopens* dbfile curr-opens-count) + curr-opens-count)) + +;; 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) + (dbfile:inc-db-open dbpath) + ;; (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//.megatest/[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)) + + +(define (dbfile:cautious-open-database fname init-proc #!optional (tries-left 500)) + + (let* ((busy-file (conc fname"-journal")) + (delay-time (* (- 51 tries-left) 1.1)) + (write-access (file-write-access? fname)) + (dir-access (file-write-access? (pathname-directory fname))) + (retry (lambda () + (thread-sleep! delay-time) + (if (> tries-left 0) + (dbfile:cautious-open-database fname init-proc (- tries-left 1)))))) + (assert (>= tries-left 0) (conc "FATAL: too many attempts in dbfile:cautious-open-database of "fname", giving up.")) + + (if (and (file-write-access? fname) + (file-exists? busy-file)) + (begin + (if (common:low-noise-print 120 busy-file) + (dbfile:print-err "INFO: dbfile:cautious-open-database: journal file " + busy-file" exists, trying again in few seconds.")) + (thread-sleep! 1) + (if (eq? tries-left 2) + (begin + (dbfile:print-err "INFO: forcing journal rollup "busy-file) + (dbfile:brute-force-salvage-db fname))) + (dbfile:cautious-open-database fname init-proc (- tries-left 1))) + + (let* ((result (condition-case + (if dir-access + (dbfile:with-simple-file-lock + (conc fname ".lock") + (lambda () + (let* ((db-exists (file-exists? fname)) + (db (sqlite3:open-database fname))) ;; creates an empty db if it did not already exist. + (sqlite3:set-busy-handler! db (sqlite3:make-busy-timeout 30000)) + (sqlite3:execute db (conc "PRAGMA synchronous = 0;")) + (if (and init-proc (not db-exists)) + (init-proc db)) + db))) + (begin + (if (file-exists? fname ) + (begin + (sqlite3:open-database fname) + ) + (print "file doesn't exist: " fname) + ) + ) + ) + (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))))) + result)))) + +(define (dbfile:brute-force-salvage-db fname) + (let* ((backupfname (conc fname"-"(current-process-id)".bak")) + (cmd (conc "cp "fname" "backupfname";mv "fname" "(conc fname ".delme;") + "cp "backupfname" "fname))) + (dbfile:print-err "WARNING: attempting recovery of file "fname" by running commands:\n" + " "cmd) + (system cmd))) + +#;(define (dbfile:cautious-open-database-orig fname init-proc #!optional (tries-left 50)) + (let* ((lock-file (conc fname".lock")) + (delay-time (* (- 51 tries-left) 1.1)) + (retry (lambda () + (thread-sleep! delay-time) + (if (> tries-left 0) + (dbfile:cautious-open-database fname init-proc (- tries-left 1)))))) + (assert (>= tries-left 0) (conc "FATAL: too many attempts in dbfile:cautious-open-database of "fname", giving up.")) + (if (and (file-write-access? fname) (not (dbfile:simple-file-lock lock-file expire-time: 3))) + (begin + (dbfile:print-err "INFO: dbfile:cautious-open-database: lock file " lock-file " exists, trying again in few seconds.") + (thread-sleep! 1) + (if (eq? tries-left 2) + (begin + (dbfile:print-err "INFO: stealing the lock "lock-file) + (delete-file* lock-file))) + (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 "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:execute db "PRAGMA synchronous = 0;") + (sqlite3:set-busy-handler! db (sqlite3:make-busy-timeout 136000)) + (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 () + (condition-case + (let* ((curr-val (db:no-sync-get/default db keyname #f))) + (if curr-val + `(#f . ,curr-val) ;; (sqlite3:first-result db "SELECT val FROM no_sync_metadat WHERE var=?;" keyname)) + (let ((lock-time (current-seconds))) + (sqlite3:execute db "INSERT OR REPLACE INTO no_sync_metadat (var,val) VALUES(?,?);" keyname lock-time) + `(#t . ,lock-time)))) + (exn (io-error) (dbfile:print-err "ERROR: i/o error with no-sync db. Check permissions, disk space etc. and try again.")) + (exn (corrupt) (dbfile:print-err "ERROR: database no-sync db is corrupt. Repair it to proceed.")) + (exn (busy) (dbfile:print-err "ERROR: database no-sync db is locked. Try copying to another location, remove original and copy back.")) + (exn (permission)(dbfile:print-err "ERROR: database no-sync db has some permissions problem.")) + (exn () ;; (status done) ;; I don't know how to detect status done but no data! + (dbfile:print-err "ERROR: Unknown error with database no-sync db message: exn="(condition->list exn)", \n" + ((condition-property-accessor 'exn 'message) exn)) + `(#f . ,(current-seconds))))))) + +(define (db:no-sync-get-lock-timeout db keyname timeout) + (let* ((lockdat (db:no-sync-get-lock db keyname))) + (match lockdat + ((#f . lock-time) + (if (> (- (current-seconds) (if (string? lock-time)(string->number lock-time)lock-time)) timeout) + (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 OR REPLACE INTO no_sync_metadat (var,val) VALUES(?,?);" keyname lock-time) + `(#t . ,lock-time)) + lockdat)) + (else lockdat)))) + +;; NOTE: This will steal the lock after timeout of waiting. +;; +(define (db:with-no-sync-lock db keyname timeout proc) + (let* ((lockdat (db:no-sync-get-lock-timeout db keyname)) + (gotlock (car lockdat)) + (locktime (cdr lockdat))) + (if gotlock + (let ((res (proc))) + (db:no-sync-del! db keyname) + res)))) + +;;====================================================================== +;; sync back functions pulled from db.scm +;;====================================================================== + +;; 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 dbstruct from-db-file runid keys dbinit) + (assert (not *db-sync-in-progress*) "FATAL: db:lock-and-sync called while a sync is in progress.") + ;; (dbfile:print-err *default-log-port* "db:lock-and-delta-sync") + (let* ((lock-file (conc from-db-file ".lock"))) + (if (common:simple-file-lock lock-file) + (begin + (dbfile:print-err "INFO: db:lock-and-delta-sync copying db "runid" at "(current-seconds)) + (set! *db-sync-in-progress* #t) + (db:sync-touched dbstruct runid keys dbinit) + (set! *db-sync-in-progress* #f) + (delete-file* lock-file) + #t) + (begin + (dbfile:print-err "INFO: could not get lock for " from-db-file ", sync likely in progress.") + #f + )))) + +;; ;; 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-orig no-sync-db dbstruct from-db-file runid keys dbinit) +;; (assert (not *db-sync-in-progress*) "FATAL: db:lock-and-sync called while a sync is in progress.") +;; ;; (dbfile:print-err *default-log-port* "db:lock-and-delta-sync") +;; (let* ((lockdat (db:no-sync-get-lock-timeout no-sync-db from-db-file 60)) +;; (gotlock (car lockdat)) +;; (locktime (cdr lockdat))) +;; ;; (debug:print-info 3 *default-log-port* "db:lock-and-delta-sync: got lock?") +;; +;; (if gotlock +;; (begin +;; (dbfile:print-err "INFO: db:lock-and-delta-sync copying db "runid" at "(current-seconds)) +;; (set! *db-sync-in-progress* #t) +;; (db:sync-touched dbstruct runid keys dbinit) +;; (set! *db-sync-in-progress* #f) +;; (db:no-sync-del! no-sync-db from-db-file) +;; #t) +;; (begin +;; (dbfile:print-err "ERROR: could not get lock for " from-db-file " from no-sync-db") +;; #f +;; )))) + +;; sync run from tmp disk to nfs disk if touched +;; +;; call with dbinit=db:initialize-main-db +;; +(define (db:sync-touched dbstruct run-id keys #!key dbinit (force-sync #f)) + (dbfile:print-err "db:sync-touched Syncing: " (conc (if run-id run-id "main") ".db")) + (let* (;; the subdb is needed to access the mtdbdat + (subdb (or (dbfile:get-subdb dbstruct run-id) + (dbfile:init-subdb dbstruct run-id dbinit))) + (tmpdbfile (dbr:subdb-tmpdbfile subdb)) + (mtdb (dbr:subdb-mtdbdat subdb)) + (tmpdb (db:open-db dbstruct run-id dbinit)) ;; sqlite3-db tmpdbfile #f)) + (start-t (current-seconds))) + (mutex-lock! *db-multi-sync-mutex*) + (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 keys) 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*) + (dbfile:add-dbdat dbstruct run-id tmpdb) + #t)) + +;; just tests, test_steps and test_data tables +(define db:sync-tests-only + (list + ;; (list "strs" + ;; '("id" #f) + ;; '("str" #f)) + (list "tests" + '("id" #f) + '("run_id" #f) + '("testname" #f) + '("host" #f) + '("cpuload" #f) + '("diskfree" #f) + '("uname" #f) + '("rundir" #f) + '("shortdir" #f) + '("item_path" #f) + '("state" #f) + '("status" #f) + '("attemptnum" #f) + '("final_logf" #f) + '("logdat" #f) + '("run_duration" #f) + '("comment" #f) + '("event_time" #f) + '("fail_count" #f) + '("pass_count" #f) + '("archived" #f) + '("last_update" #f)) + (list "test_steps" + '("id" #f) + '("test_id" #f) + '("stepname" #f) + '("state" #f) + '("status" #f) + '("event_time" #f) + '("comment" #f) + '("logfile" #f) + '("last_update" #f)) + (list "test_data" + '("id" #f) + '("test_id" #f) + '("category" #f) + '("variable" #f) + '("value" #f) + '("expected" #f) + '("tol" #f) + '("units" #f) + '("comment" #f) + '("status" #f) + '("type" #f) + '("last_update" #f)))) + +;; needs db to get keys, this is for syncing all tables +;; +(define (db:sync-main-list dbstruct keys) + (let ((keys keys)) ;; (db:get-keys dbstruct))) + (list + (list "keys" + '("id" #f) + '("fieldname" #f) + '("fieldtype" #f)) + (list "metadat" '("var" #f) '("val" #f)) + (append (list "runs" + '("id" #f)) + (map (lambda (k)(list k #f)) + (append keys + (list "runname" "state" "status" "owner" "event_time" "comment" "fail_count" "pass_count" "contour" "last_update")))) + (list "archive_disks" + '("id" #f) + '("archive_area_name" #f) + '("disk_path" #f) + '("last_df" #f) + '("last_df_time" #f) + '("creation_time" #f)) + + (list "archive_blocks" + '("id" #f) + '("archive_disk_id" #f) + '("disk_path" #f) + '("last_du" #f) + '("last_du_time" #f) + '("creation_time" #f)) + + (list "test_meta" + '("id" #f) + '("testname" #f) + '("owner" #f) + '("description" #f) + '("reviewed" #f) + '("iterated" #f) + '("avg_runtime" #f) + '("avg_disk" #f) + '("tags" #f) + '("jobgroup" #f))))) + +(define (db:sync-all-tables-list dbstruct keys) + (append (db:sync-main-list dbstruct keys) + db:sync-tests-only)) + +;; tbls is ( ("tablename" ( "field1" [#f|proc1] ) ( "field2" [#f|proc2] ) .... ) ) +;; db's are dbdat's +;; +;; if last-update specified ("field-name" . time-in-seconds) +;; then sync only records where field-name >= time-in-seconds +;; IFF field-name exists +;; +(define (db:sync-tables tbls last-update fromdb todb . slave-dbs) + (handle-exceptions + exn + (begin + (dbfile:print-err "EXCEPTION: database probably overloaded or unreadable in db:sync-tables.") + (print-call-chain (current-error-port)) + (dbfile:print-err " message: " ((condition-property-accessor 'exn 'message) exn)) + (dbfile:print-err "exn=" (condition->list exn)) + (dbfile:print-err " status: " ((condition-property-accessor 'sqlite3 'status) exn)) + (dbfile:print-err " src db: " (dbr:dbdat-dbfile fromdb)) + (for-each (lambda (dbdat) + (let ((dbpath (dbr:dbdat-dbfile dbdat))) + (dbfile:print-err " dbpath: " dbpath) + (if #t ;; (not (db:repair-db dbdat)) + (begin + (dbfile:print-err "Failed to rebuild (repair is turned off) " dbpath ", exiting now.") + (exit))))) + (cons todb slave-dbs)) + + 0) + + ;; this is the work to be done") + (cond + ((not fromdb) (dbfile:print-err "WARNING: db:sync-tables called with fromdb missing") + -1) + ((not todb) (dbfile:print-err "WARNING: db:sync-tables called with todb missing") + -2) + ((not (sqlite3:database? (dbr:dbdat-dbh fromdb))) + (dbfile:print-err "db:sync-tables called with fromdb not a database " fromdb) + -3) + ((not (sqlite3:database? (dbr:dbdat-dbh todb))) + (dbfile:print-err "db:sync-tables called with todb not a database " todb) + -4) + + ((not (file-write-access? (dbr:dbdat-dbfile todb))) + (dbfile:print-err "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? (dbr:dbdat-dbfile todb)))) + slave-dbs))) + (for-each + (lambda (bad-dbdat) + (dbfile:print-err "db:sync-tables called with todb not a read-only database " bad-dbdat)) + readonly-slave-dbs) + readonly-slave-dbs))) -6) + (else + ;; (dbfile:print-err "db:sync-tables: args are good") + + (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)) + (for-each ;; table + (lambda (tabledat) + (let* ((tablename (car tabledat)) + (fields (cdr tabledat)) + (has-last-update (member "last_update" fields)) + (use-last-update (cond + ((and has-last-update + (member "last_update" fields)) + #t) ;; if given a number, just use it for all fields + ((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) + ((and last-update (not (pair? last-update)) (not (number? last-update))) + (dbfile:print-err "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 + (if (number? last-update) + last-update + (cdr last-update)) + #f)) + (last-update-field (if use-last-update + (if (number? last-update) + "last_update" + (car last-update)) + #f)) + (num-fields (length fields)) + (field->num (make-hash-table)) + (num->field (apply vector (map car fields))) ;; BBHERE + (full-sel (conc "SELECT " (string-intersperse (map car fields) ",") + " FROM " tablename (if use-last-update ;; apply last-update criteria + (conc " WHERE " last-update-field " >= " last-update-value) + "") + ";")) + (full-ins (conc "INSERT OR REPLACE INTO " tablename " ( " (string-intersperse (map car fields) ",") " ) " + " VALUES ( " (string-intersperse (make-list num-fields "?") ",") " );")) + (fromdat '()) + (fromdats '()) + (totrecords 0) + (batch-len 100) ;; (string->number (or (configf:lookup *configdat* "sync" "batchsize") "100"))) + (todat (make-hash-table)) + (count 0) + (field-names (map car fields)) + (delay-handicap 0) ;; (string->number (or (configf:lookup *configdat* "sync" "delay-handicap") "0"))) + ) + + ;; set up the field->num table + (for-each + (lambda (field) + (hash-table-set! field->num field count) + (set! count (+ count 1))) + fields) + + ;; 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))) + ) + ) + (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))) + + (sqlite3:for-each-row + (lambda (a . b) + (hash-table-set! todat a (apply vector a b))) + (dbr:dbdat-dbh todb) + full-sel) + + (when (and delay-handicap (> delay-handicap 0)) + (dbfile:print-err "imposing synthetic sync delay of "delay-handicap" seconds since sync/delay-handicap is configured") + (thread-sleep! delay-handicap) + (dbfile:print-err "synthetic sync delay of "delay-handicap" seconds completed") + ) + + ;; first pass implementation, just insert all changed rows + + (for-each + (lambda (targdb) + (let* ((db (dbr:dbdat-dbh targdb)) + (drp-trigger (if (member "last_update" field-names) + (db:drop-trigger db tablename) + #f)) + (has-last-update (member "last_update" field-names)) + (is-trigger-dropped (if has-last-update + (db:is-trigger-dropped db tablename) + #f)) + (stmth (sqlite3:prepare db full-ins)) + (changed-rows 0)) + (for-each + (lambda (fromdat-lst) + (sqlite3:with-transaction + db + (lambda () + (for-each ;; + (lambda (fromrow) + (let* ((a (vector-ref fromrow 0)) + (curr (hash-table-ref/default todat a #f)) + (same #t)) + (let loop ((i 0)) + (if (or (not curr) + (not (equal? (vector-ref fromrow i)(vector-ref curr i)))) + (set! same #f)) + (if (and same + (< 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))) + (set! changed-rows (+ changed-rows 1)) + ) + ) + )) + fromdat-lst)))) + fromdats) + + (sqlite3:finalize! stmth) + (if (member "last_update" field-names) + (db:create-trigger db tablename)))) + (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. + (for-each + (lambda (dat) + (let ((tblname (car dat)) + (count (cdr dat))) + (set! tot-count (+ tot-count count)) + )) + (sort (hash-table->alist numrecs)(lambda (a b)(> (cdr a)(cdr b)))))) + tot-count))))) + +;;====================================================================== +;; trigger setup/takedown +;;====================================================================== + +(define db:trigger-list + (list (list "update_runs_trigger" "CREATE TRIGGER IF NOT EXISTS update_runs_trigger AFTER UPDATE ON runs + FOR EACH ROW + BEGIN + UPDATE runs SET last_update=(strftime('%s','now')) + WHERE id=old.id; + END;" ) + (list "update_run_stats_trigger" "CREATE TRIGGER IF NOT EXISTS update_run_stats_trigger AFTER UPDATE ON run_stats + FOR EACH ROW + BEGIN + UPDATE run_stats SET last_update=(strftime('%s','now')) + WHERE id=old.id; + END;" ) + (list "update_tests_trigger" "CREATE TRIGGER IF NOT EXISTS update_tests_trigger AFTER UPDATE ON tests + FOR EACH ROW + BEGIN + UPDATE tests SET last_update=(strftime('%s','now')) + WHERE id=old.id; + END;" ) + (list "update_teststeps_trigger" "CREATE TRIGGER IF NOT EXISTS update_teststeps_trigger AFTER UPDATE ON test_steps + FOR EACH ROW + BEGIN + UPDATE test_steps SET last_update=(strftime('%s','now')) + WHERE id=old.id; + END;" ) + (list "update_test_data_trigger" "CREATE TRIGGER IF NOT EXISTS update_test_data_trigger AFTER UPDATE ON test_data + FOR EACH ROW + BEGIN + UPDATE test_data SET last_update=(strftime('%s','now')) + WHERE id=old.id; + END;" ))) +;; +;; ADD run-id SUPPORT +;; +(define (db:create-all-triggers dbstruct) + (db:with-db + dbstruct #f #f + (lambda (dbdat db) + (db:create-triggers db)))) + +(define (db:create-triggers db) + (for-each (lambda (key) + (sqlite3:execute db (cadr key))) + db:trigger-list)) + +(define (db:drop-all-triggers dbstruct) + (db:with-db + dbstruct #f #f + (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" + (conc "update_" tbl-name "_trigger"))) + (res #f)) + (sqlite3:for-each-row + (lambda (name) + (if (equal? name trigger-name) + (set! res #t))) + db + "SELECT name FROM sqlite_master WHERE type = 'trigger' ;") + res)) + +(define (db:drop-triggers db) + (for-each + (lambda (key) + (sqlite3:execute db (conc "drop trigger if exists " (car key)))) + db:trigger-list)) + +(define (db:drop-trigger db tbl-name) + (let* ((trigger-name (if (equal? tbl-name "test_steps") + "update_teststeps_trigger" + (conc "update_" tbl-name "_trigger")))) + (for-each + (lambda (key) + (if (equal? (car key) trigger-name) + (sqlite3:execute db (conc "drop trigger if exists " trigger-name)))) + db:trigger-list))) + +(define (db:create-trigger db tbl-name) + (let* ((trigger-name (if (equal? tbl-name "test_steps") + "update_teststeps_trigger" + (conc "update_" tbl-name "_trigger")))) + (for-each (lambda (key) + (if (equal? (car key) trigger-name) + (sqlite3:execute db (cadr key)))) + db:trigger-list))) + +;;====================================================================== +;; db access stuff +;;====================================================================== + +;; call with dbinit=db:initialize-main-db +;; +(define (db:open-db dbstruct run-id dbinit) + (mutex-lock! *db-open-mutex*) + (let* ((dbdat (dbfile:open-db dbstruct run-id dbinit))) + (set! *db-write-access* (not (dbr:dbdat-read-only dbdat))) + (mutex-unlock! *db-open-mutex*) + dbdat)) + +(define dbfile:db-init-proc (make-parameter #f)) + +;; (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 ;; this stuff just allows us to call with a db handle directly + (db:open-db dbstruct run-id (dbfile:db-init-proc)) ;; (dbfile:get-subdb dbstruct run-id) + #f)) + (db (if have-struct ;; this stuff just allows us to call with a db handle directly + (dbr:dbdat-dbh dbdat) + dbstruct)) + (fname (if dbdat + (dbr:dbdat-dbfile dbdat) + "nofilenameavailable")) + (jfile (conc fname"-journal")) + #;(subdb (if have-struct + (dbfile:get-subdb dbstruct run-id) + #f)) + (use-mutex (> *api-process-request-count* 25))) ;; was 25 + (if (file-exists? jfile) + (begin + (dbfile:print-err "INFO: "jfile" exists, delaying few seconds to reduce database load") + (thread-sleep! 2))) + (if (and use-mutex + (common:low-noise-print 120 "over-50-parallel-api-requests")) + (dbfile:print-err *api-process-request-count* " parallel api requests being processed in process " + (current-process-id) ", throttling access")) + (condition-case + (begin + (if use-mutex (mutex-lock! *db-with-db-mutex*)) + (let ((res (apply proc dbdat db params))) ;; the actual call is here. + (if use-mutex (mutex-unlock! *db-with-db-mutex*)) + ;; (if (vector? dbstruct)(db:done-with dbstruct run-id r/w)) + (if dbdat + (dbfile:add-dbdat dbstruct run-id 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)))))) + +;;====================================================================== +;; another attempt at a transactionized queue +;;====================================================================== + +;; ;; ;; (define *transaction-queues* (make-hash-table)) +;; ;; ;; +;; ;; ;; (define (db:get-queue run-id) +;; ;; ;; (let* ((res (hash-table-ref/default *transaction-queues* run-id #f))) +;; ;; ;; (if res +;; ;; ;; res +;; ;; ;; (let* ((newq (make-queue))) +;; ;; ;; (hash-table-set! *transaction-queues* run-id newq) +;; ;; ;; newq)))) +;; ;; ;; +;; ;; ;; (define (db:add-to-transaction-queue dbstruct proc params) +;; ;; ;; (let* ((mbox (make-mailbox)) +;; ;; ;; (q (db:get-queue run-id))) +;; ;; ;; (queue-add! *transaction-queue* (list dbstruct proc mbox)) +;; ;; ;; (mailbox-receive mbox))) +;; ;; ;; +;; ;; ;; (define (db:process-transaction-queue *dbstruct-dbs*) +;; ;; ;; (for-each +;; ;; ;; (lambda (run-id) +;; ;; ;; (let* ((q (hash-table-ref *transaction-queue* run-id))) +;; ;; ;; ;; with-transaction +;; ;; ;; ;; dbstruct +;; ;; ;; ;; pop items from queue and execute them, return results via mailbox +;; ;; ;; q +;; ;; ;; ;; pop +;; ;; ;; )) +;; ;; ;; (hash-table-keys *transaction-queues*))) + +;;====================================================================== +;; 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))) + +(define (dbfile:with-simple-file-lock fname proc #!key (expire-time 300)) + (let ((gotlock (dbfile:simple-file-lock-and-wait fname expire-time: expire-time))) + (if gotlock + (let ((res (proc))) + (dbfile:simple-file-release-lock fname) + res) + (assert #t "FATAL: simple file lock never got a lock.")))) + +) Index: dbmod.scm ================================================================== --- dbmod.scm +++ dbmod.scm @@ -31,7 +31,26 @@ (define (db:run-id->dbname run-id) (cond ((number? run-id)(conc run-id ".db")) ((not run-id) "main.db") (else run-id))) - + + +;;====================================================================== +;; hash of hashs +;;====================================================================== + + +(define (db:hoh-set! dat key1 key2 val) + (let* ((subhash (hash-table-ref/default dat key1 #f))) + (if subhash + (hash-table-set! subhash key2 val) + (begin + (hash-table-set! dat key1 (make-hash-table)) + (db:hoh-set! dat key1 key2 val))))) + +(define (db:hoh-get dat key1 key2) + (let* ((subhash (hash-table-ref/default dat key1 #f))) + (and subhash + (hash-table-ref/default subhash key2 #f)))) + ) Index: dcommon.scm ================================================================== --- dcommon.scm +++ dcommon.scm @@ -528,11 +528,14 @@ (common:without-vars command "MT_.*")) (message-window (conc "Directory " rundir " not found")))))) (xterm) - (print "Adding xterm code"))))) + ) + ) + ) +) ;;====================================================================== ;; D A T A T A B L E S ;;====================================================================== 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,18 @@ (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)) +(declare (uses commonmod)) (include "common_records.scm") (include "db_records.scm") (include "js-path.scm") + +(import dbfile commonmod) (require-library stml) (define (http-transport:make-server-url hostport) (if (not hostport) #f @@ -97,11 +101,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 +175,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")))) ;;====================================================================== @@ -281,29 +285,32 @@ (begin (debug:print 0 *default-log-port* "WARNING: failure in with-input-from-request to " fullurl ".") (debug:print 0 *default-log-port* " message: " msg ", exn=" exn) (debug:print 0 *default-log-port* " cmd: " cmd " params: " params " key:" (or server-id "thekey")) (debug:print 0 *default-log-port* " call-chain: " call-chain))) - (if runremote - (remote-conndat-set! runremote #f)) + (set! *runremote* #f) + (set! runremote #f) + ;; (if runremote + ;; (remote-conndat-set! runremote #f)) ;; Killing associated server to allow clean retry.") ;; (tasks:kill-server-run-id run-id) ;; better to kill the server in the logic that called this routine? (mutex-unlock! *http-mutex*) - ;;; (signal (make-composite-condition - ;;; (make-property-condition 'commfail 'message "failed to connect to server"))) - ;;; "communications failed" + ;; (signal (make-composite-condition + ;; (make-property-condition 'commfail 'message "failed to connect to server"))) + ;; "communications failed" + (close-all-connections!) (db:obj->string #f)) - (with-input-from-request ;; was dat - fullurl - (list (cons 'key (or server-id "thekey")) - (cons 'cmd cmd) - (cons 'params sparams)) - read-string)) + (with-input-from-request ;; was dat + fullurl + (list (cons 'key (or server-id "thekey")) + (cons 'cmd cmd) + (cons 'params sparams)) + read-string)) transport: 'http) - 0)) ;; added this speculatively + 0)) ;; added this speculatively ;; Shouldn't this be a call to the managed call-all-connections stuff above? - (close-all-connections!) + ;; (close-all-connections!) ;; BUG? WHY IS THIS HERE? Are we failing to reuse connections? (mutex-unlock! *http-mutex*) )) (time-out (lambda () (thread-sleep! 45) (debug:print 0 *default-log-port* "WARNING: send-receive took more than 45 seconds!!") @@ -350,11 +357,11 @@ exn (begin (print-call-chain *default-log-port*) (debug:print-error 0 *default-log-port* " closing connection failed with error: " ((condition-property-accessor 'exn 'message) exn) ", exn=" exn)) (close-connection! api-dat) - ;;(close-idle-connections!) + (close-idle-connections!) #t)) #f))) (define (make-http-transport:server-dat)(make-vector 6)) @@ -390,10 +397,13 @@ (let* ((api-url (conc "http://" iface ":" port "/api")) (api-uri (uri-reference (conc "http://" iface ":" port "/api"))) (api-req (make-request method: 'POST uri: api-uri)) (server-dat (vector iface port api-uri api-url api-req (current-seconds) server-id))) server-dat)) + + + ;; run http-transport:keep-running in a parallel thread to monitor that the db is being ;; used and to shutdown after sometime if it is not. ;; (define (http-transport:keep-running) @@ -400,10 +410,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 +468,36 @@ (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 (and no-sync-db + (common:low-noise-print 5 "sync-all")) ;; cheesy way to reduce frequency of running sync :) + (begin + (debug:print 0 *default-log-port* "keep-running calling db:all-db-sync at " (time->string (seconds->local-time) "%H:%M:%S")) + + ;; This is tougher than it seems - have to deal with multiple dbs + ;; (db:process-transaction-queue *dbstruct-dbs*) + + (db:all-db-sync *dbstruct-dbs*) + + ;; (db:do-sync no-sync-db) + ;; (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 +519,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,31 +530,47 @@ (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))) (cond + #;((and *server-run* + (> (- (current-seconds) server-start-time) 420)) ;; let's try server replacement + ;; ((adj-proc-load . 0.056875) (adj-core-load . 0.11375) (1m-load . 0.91) (5m-load . 0.77) (15m-load . 1.0) (proc . 16) (core . 8) (phys . 1)) + (let* ((loaddat (common:get-normalized-cpu-load #f)) + (adj-proc-load (alist-ref 'adj-proc-load loaddat)) + (adj-core-load (alist-ref 'adj-core-load loaddat)) + (adj-load (max adj-proc-load adj-core-load))) + (if (< adj-load 2) ;; reduce chance of runaway + (server:run *toppath*)) + (db:all-db-sync *dbstruct-dbs*) + (thread-sleep! 30) + (http-transport:server-shutdown port))) ((and *server-run* (> (+ last-access server-timeout) (current-seconds))) (if (common:low-noise-print 120 "server continuing") (debug:print-info 0 *default-log-port* "Server continuing, seconds since last db access: " (- (current-seconds) last-access)) (let ((curr-time (current-seconds))) (handle-exceptions exn (debug:print 0 *default-log-port* "ERROR: Failed to change timestamp on log file " server-log-file ". Are you out of space on that disk? exn=" exn) - (if (not *server-overloaded*) - (change-file-times server-log-file curr-time curr-time))))) + (if (and (< (- (current-seconds) server-start-time) 600) ;; run for ten minutes for experiment, 3600 thereafter + (not *server-overloaded*)) + (change-file-times server-log-file curr-time curr-time) + (if (common:low-noise-print 120 "start new server") + (server:kind-run *toppath*) ;; server:kind-run uses [servers] numservers + ))))) (loop 0 server-state bad-sync-count (current-milliseconds))) (else (debug:print-info 0 *default-log-port* "Server timed out. seconds since last db access: " (- (current-seconds) last-access)) (http-transport:server-shutdown port))))))) 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)))) @@ -593,11 +593,11 @@ (list "MT_TARGET" target) (list "MT_LINKTREE" (common:get-linktree)) ;; (configf:lookup *configdat* "setup" "linktree")) (list "MT_TESTSUITENAME" (common:get-testsuite-name)))) ;;(bb-check-path msg: "launch:execute post block 3") - (if mt-bindir-path (setenv "PATH" (conc (getenv "PATH") ":" mt-bindir-path))) + (if mt-bindir-path (setenv "PATH" (conc "\""(getenv "PATH")":"mt-bindir-path"\""))) ;;(bb-check-path msg: "launch:execute post block 4") ;; (change-directory top-path) ;; Can setup as client for server mode now ;; (client:setup) @@ -1450,12 +1450,12 @@ (contour #f)) ;; NOT READY FOR THIS (args:get-arg "-contour"))) (let loop ((delta (- (current-seconds) *last-launch*)) (launch-delay (configf:lookup-number *configdat* "setup" "launch-delay" default: 0))) (if (> launch-delay delta) (begin - (if (common:low-noise-print 1200 "test launch delay") ;; every two hours or so remind the user about launch delay. - (debug:print-info 0 *default-log-port* "NOTE: test launches are delayed by " launch-delay " seconds. See megatest.config launch-delay setting to adjust.")) ;; launch of " test-name " for " (- launch-delay delta) " seconds")) + ;; (if (common:low-noise-print 1200 "test launch delay") ;; every two hours or so remind the user about launch delay. + ;; (debug:print-info 0 *default-log-port* "NOTE: test launches are delayed by " launch-delay " seconds. See megatest.config launch-delay setting to adjust.")) ;; launch of " test-name " for " (- launch-delay delta) " seconds")) (thread-sleep! (- launch-delay delta)) (loop (- (current-seconds) *last-launch*) launch-delay)))) (change-directory *toppath*) (alist->env-vars ;; consolidate this code with the code in megatest.scm for "-execute", *maybe* - the longer they are set the longer each launch takes (must be non-overlapping with the vars) (append Index: margs.scm ================================================================== --- margs.scm +++ margs.scm @@ -33,10 +33,15 @@ (define (args:get-arg-from ht arg . default) (if (null? default) (hash-table-ref/default ht arg #f) (hash-table-ref/default ht arg (car default)))) + +(define (args:remove-arg-from-ht arg) + (hash-table-delete! args:arg-hash arg) +) + (define (args:usage . args) (if (> (length args) 0) (apply print "ERROR: " args)) (if (string? help) (print help) 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.7006) Index: megatest.scm ================================================================== --- megatest.scm +++ megatest.scm @@ -30,21 +30,38 @@ (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 db)) +(declare (uses dbmod)) +(declare (uses dbmod.import)) +(declare (uses commonmod)) +(declare (uses commonmod.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 + commonmod + dbfile) (define *db* #f) ;; this is only for the repl, do not use in general!!!! (include "common_records.scm") (include "key_records.scm") @@ -62,10 +79,12 @@ (require-library mutils) (define *usage-log-file* #f) ;; put path to file for logging usage in this var in the ~/.megatestrc file (define *usage-use-seconds* #t) ;; for Epoc seconds in usage logging change this to #t in ~/.megatestrc file + +(dbfile:db-init-proc db:initialize-main-db) ;; load the ~/.megatestrc file, put (use trace)(trace-call-sites #t)(trace function-you-want-to-trace) in this file ;; (let ((debugcontrolf (conc (get-environment-variable "HOME") "/.megatestrc"))) (if (common:file-exists? debugcontrolf) @@ -494,19 +513,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 +553,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 +952,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 +2311,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 +2378,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 +2398,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,27 +2469,29 @@ ;; ;; ;; 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 'old2new - ;; '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 +2557,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 @@ -21,14 +21,15 @@ (use format typed-records) ;; RADT => purpose of json format?? (declare (unit rmt)) (declare (uses api)) (declare (uses http-transport)) +(declare (uses dbfile)) (include "common_records.scm") ;; (declare (uses rmtmod)) -;; (import rmtmod) +(import dbfile) ;; rmtmod) ;; ;; THESE ARE ALL CALLED ON THE CLIENT SIDE!!! ;; @@ -63,11 +64,11 @@ (define (rmt:send-receive cmd rid params #!key (attemptnum 1)(area-dat #f)) ;; start attemptnum at 1 so the modulo below works as expected #;(common:telemetry-log (conc "rmt:"(->string cmd)) payload: `((rid . ,rid) (params . ,params))) - + (if (> attemptnum 2) (debug:print 0 *default-log-port* "INFO: attemptnum in rmt:send-receive is " attemptnum)) (cond ((> attemptnum 2) (thread-sleep! 0.05)) @@ -119,10 +120,17 @@ (thread-sleep! 0.1) ;; since we shouldn't get here, delay a little (remote-hh-dat-set! runremote (common:get-homehost))) ;;(print "BB> readonly-mode is "readonly-mode" dbfile is "dbfile) (cond + #;((> (- (current-seconds)(remote-connect-time runremote)) 180) ;; reconnect to server every 180 seconds + (debug:print 0 *default-log-port* "Forcing reconnect to server(s) due to 180 second timeout.") + (set! *runremote* #f) + ;; BUG: close-connections should go here? + (mutex-unlock! *rmt-mutex*) + (rmt:send-receive cmd rid params attemptnum: 1 area-dat: area-dat)) + ;;DOT EXIT; ;;DOT MUTEXLOCK -> EXIT [label="> 15 attempts"]; {rank=same "case 1" "EXIT" } ;; give up if more than 150 attempts ((> attemptnum 150) (debug:print 0 *default-log-port* "ERROR: 150 tries to start/connect to server. Giving up.") @@ -368,28 +376,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)) @@ -412,16 +420,16 @@ (mutex-unlock! *db-multi-sync-mutex*))))) res)) (define (rmt:send-receive-no-auto-client-setup connection-info cmd run-id params) (let* ((run-id (if run-id run-id 0)) - (res (handle-exceptions - exn - (begin - (print "transport failed. exn=" exn) - #f) - (http-transport:client-api-send-receive run-id connection-info cmd params)))) + (res ;; (handle-exceptions + ;; exn + ;; (begin + ;; (print "transport failed. exn=" exn) + ;; #f) + (http-transport:client-api-send-receive run-id connection-info cmd params))) ;; ) (if (and res (vector-ref res 0)) (vector-ref res 1) ;;; YES!! THIS IS CORRECT!! CHANGE IT HERE, THEN CHANGE rmt:send-receive ALSO!!! #f))) ;;====================================================================== @@ -525,10 +533,11 @@ (define (rmt:get-targets) (rmt:send-receive 'get-targets #f '())) (define (rmt:get-target run-id) + (assert (number? run-id) "FATAL: Run id required.") (rmt:send-receive 'get-target run-id (list run-id))) (define (rmt:get-run-times runpatt targetpatt) (rmt:send-receive 'get-run-times #f (list runpatt targetpatt ))) @@ -537,13 +546,15 @@ ;; T E S T S ;;====================================================================== ;; Just some syntatic sugar (define (rmt:register-test run-id test-name item-path) + (assert (number? run-id) "FATAL: Run id required.") (rmt:general-call 'register-test run-id run-id test-name item-path)) (define (rmt:get-test-id run-id testname item-path) + (assert (number? run-id) "FATAL: Run id required.") (rmt:send-receive 'get-test-id run-id (list run-id testname item-path))) ;; run-id is NOT used ;; (define (rmt:get-test-info-by-id run-id test-id) @@ -556,39 +567,46 @@ (define (rmt:test-get-rundir-from-test-id run-id test-id) (rmt:send-receive 'test-get-rundir-from-test-id run-id (list run-id test-id))) (define (rmt:open-test-db-by-test-id run-id test-id #!key (work-area #f)) + (assert (number? run-id) "FATAL: Run id required.") (let* ((test-path (if (string? work-area) work-area (rmt:test-get-rundir-from-test-id run-id test-id)))) (debug:print 3 *default-log-port* "TEST PATH: " test-path) (open-test-db test-path))) ;; WARNING: This currently bypasses the transaction wrapped writes system (define (rmt:test-set-state-status-by-id run-id test-id newstate newstatus newcomment) + (assert (number? run-id) "FATAL: Run id required.") (rmt:send-receive 'test-set-state-status-by-id run-id (list run-id test-id newstate newstatus newcomment))) -(define (rmt:set-tests-state-status run-id testnames currstate currstatus newstate newstatus) +(define (rmt:set-tests-state-status run-id testnames currstate currstatus newstate newstatus) + (assert (number? run-id) "FATAL: Run id required.") (rmt:send-receive 'set-tests-state-status run-id (list run-id testnames currstate currstatus newstate newstatus))) (define (rmt:get-tests-for-run run-id testpatt states statuses offset limit not-in sort-by sort-order qryvals last-update mode) + (assert (number? run-id) "FATAL: Run id required.") ;; (if (number? run-id) (rmt:send-receive 'get-tests-for-run run-id (list run-id testpatt states statuses offset limit not-in sort-by sort-order qryvals last-update mode))) ;; (begin ;; (debug:print-error 0 *default-log-port* "rmt:get-tests-for-run called with bad run-id=" run-id) ;; (print-call-chain (current-error-port)) ;; '()))) (define (rmt:get-tests-for-run-state-status run-id testpatt last-update) + (assert (number? run-id) "FATAL: Run id required.") (rmt:send-receive 'get-tests-for-run-state-status run-id (list run-id testpatt last-update))) ;; get stuff via synchash (define (rmt:synchash-get run-id proc synckey keynum params) + (assert (number? run-id) "FATAL: Run id required.") (rmt:send-receive 'synchash-get run-id (list run-id proc synckey keynum params))) (define (rmt:get-tests-for-run-mindata run-id testpatt states status not-in) + (assert (number? run-id) "FATAL: Run id required.") (rmt:send-receive 'get-tests-for-run-mindata run-id (list run-id testpatt states status not-in))) ;; IDEA: Threadify these - they spend a lot of time waiting ... ;; (define (rmt:get-tests-for-runs-mindata run-ids testpatt states status not-in) @@ -631,40 +649,50 @@ ;; (apply append (map (lambda (run-id) ;; (rmt:send-receive 'get-tests-for-run-mindata run-id (list run-ids testpatt states status not-in))) ;; run-id-list)))) (define (rmt:delete-test-records run-id test-id) + (assert (number? run-id) "FATAL: Run id required.") (rmt:send-receive 'delete-test-records run-id (list run-id test-id))) (define (rmt:test-set-state-status run-id test-id state status msg) + (assert (number? run-id) "FATAL: Run id required.") (rmt:send-receive 'test-set-state-status run-id (list run-id test-id state status msg))) (define (rmt:test-toplevel-num-items run-id test-name) + (assert (number? run-id) "FATAL: Run id required.") (rmt:send-receive 'test-toplevel-num-items run-id (list run-id test-name))) ;; (define (rmt:get-previous-test-run-record run-id test-name item-path) ;; (rmt:send-receive 'get-previous-test-run-record run-id (list run-id test-name item-path))) (define (rmt:get-matching-previous-test-run-records run-id test-name item-path) + (assert (number? run-id) "FATAL: Run id required.") (rmt:send-receive 'get-matching-previous-test-run-records run-id (list run-id test-name item-path))) (define (rmt:test-get-logfile-info run-id test-name) + (assert (number? run-id) "FATAL: Run id required.") (rmt:send-receive 'test-get-logfile-info run-id (list run-id test-name))) (define (rmt:test-get-records-for-index-file run-id test-name) + (assert (number? run-id) "FATAL: Run id required.") (rmt:send-receive 'test-get-records-for-index-file run-id (list run-id test-name))) (define (rmt:get-testinfo-state-status run-id test-id) + (assert (number? run-id) "FATAL: Run id required.") (rmt:send-receive 'get-testinfo-state-status run-id (list run-id test-id))) (define (rmt:test-set-log! run-id test-id logf) + (assert (number? run-id) "FATAL: Run id required.") (if (string? logf)(rmt:general-call 'test-set-log run-id logf test-id))) (define (rmt:test-set-top-process-pid run-id test-id pid) + (assert (number? run-id) "FATAL: Run id required.") (rmt:send-receive 'test-set-top-process-pid run-id (list run-id test-id pid))) (define (rmt:test-get-top-process-pid run-id test-id) + (assert (number? run-id) "FATAL: Run id required.") (rmt:send-receive 'test-get-top-process-pid run-id (list run-id test-id))) (define (rmt:get-run-ids-matching-target keynames target res runname testpatt statepatt statuspatt) (rmt:send-receive 'get-run-ids-matching-target #f (list keynames target res runname testpatt statepatt statuspatt))) @@ -676,57 +704,71 @@ (map (lambda (run-id) (rmt:send-receive 'test-get-paths-matching-keynames-target-new run-id (list run-id keynames target res testpatt statepatt statuspatt runname))) run-ids)))) (define (rmt:get-prereqs-not-met run-id waitons ref-test-name ref-item-path #!key (mode '(normal))(itemmaps #f)) + (assert (number? run-id) "FATAL: Run id required.") (rmt:send-receive 'get-prereqs-not-met run-id (list run-id waitons ref-test-name ref-item-path mode itemmaps))) (define (rmt:get-count-tests-running-for-run-id run-id) + (assert (number? run-id) "FATAL: Run id required.") (rmt:send-receive 'get-count-tests-running-for-run-id run-id (list run-id))) (define (rmt:get-not-completed-cnt run-id) + (assert (number? run-id) "FATAL: Run id required.") (rmt:send-receive 'get-not-completed-cnt run-id (list run-id))) ;; Statistical queries (define (rmt:get-count-tests-running run-id) + (assert (number? run-id) "FATAL: Run id required.") (rmt:send-receive 'get-count-tests-running run-id (list run-id))) (define (rmt:get-count-tests-running-for-testname run-id testname) + (assert (number? run-id) "FATAL: Run id required.") (rmt:send-receive 'get-count-tests-running-for-testname run-id (list run-id testname))) (define (rmt:get-count-tests-running-in-jobgroup run-id jobgroup) + (assert (number? run-id) "FATAL: Run id required.") (rmt:send-receive 'get-count-tests-running-in-jobgroup run-id (list run-id jobgroup))) ;; state and status are extra hints not usually used in the calculation ;; (define (rmt:set-state-status-and-roll-up-items run-id test-name item-path state status comment) + (assert (number? run-id) "FATAL: Run id required.") (rmt:send-receive 'set-state-status-and-roll-up-items run-id (list run-id test-name item-path state status comment))) (define (rmt:set-state-status-and-roll-up-run run-id state status) + (assert (number? run-id) "FATAL: Run id required.") (rmt:send-receive 'set-state-status-and-roll-up-run run-id (list run-id state status))) (define (rmt:update-pass-fail-counts run-id test-name) + (assert (number? run-id) "FATAL: Run id required.") (rmt:general-call 'update-pass-fail-counts run-id test-name test-name test-name)) (define (rmt:top-test-set-per-pf-counts run-id test-name) + (assert (number? run-id) "FATAL: Run id required.") (rmt:send-receive 'top-test-set-per-pf-counts run-id (list run-id test-name))) (define (rmt:get-raw-run-stats run-id) + (assert (number? run-id) "FATAL: Run id required.") (rmt:send-receive 'get-raw-run-stats run-id (list run-id))) (define (rmt:get-test-times runname target) (rmt:send-receive 'get-test-times #f (list runname target ))) ;;====================================================================== ;; R U N S ;;====================================================================== +;; BUG - LOOK AT HOW THIS WORKS!!! +;; (define (rmt:get-run-info run-id) - (rmt:send-receive 'get-run-info run-id (list run-id))) + (assert (number? run-id) "FATAL: Run id required.") + (rmt:send-receive 'get-run-info #f (list run-id))) (define (rmt:get-num-runs runpatt) (rmt:send-receive 'get-num-runs #f (list runpatt))) (define (rmt:get-runs-cnt-by-patt runpatt targetpatt keys) @@ -735,14 +777,15 @@ ;; Use the special run-id == #f scenario here since there is no run yet (define (rmt:register-run keyvals runname state status user contour) (rmt:send-receive 'register-run #f (list keyvals runname state status user contour))) (define (rmt:get-run-name-from-id run-id) - (rmt:send-receive 'get-run-name-from-id run-id (list run-id))) + (assert (number? run-id) "FATAL: Run id required.") + (rmt:send-receive 'get-run-name-from-id #f (list run-id))) (define (rmt:delete-run run-id) - (rmt:send-receive 'delete-run run-id (list run-id))) + (rmt:send-receive 'delete-run #f (list run-id))) (define (rmt:update-run-stats run-id stats) (rmt:send-receive 'update-run-stats #f (list run-id stats))) (define (rmt:delete-old-deleted-test-records) @@ -756,43 +799,52 @@ (define (rmt:get-all-run-ids) (rmt:send-receive 'get-all-run-ids #f '())) (define (rmt:get-prev-run-ids run-id) + (assert (number? run-id) "FATAL: Run id required.") (rmt:send-receive 'get-prev-run-ids #f (list run-id))) (define (rmt:lock/unlock-run run-id lock unlock user) + (assert (number? run-id) "FATAL: Run id required.") (rmt:send-receive 'lock/unlock-run #f (list run-id lock unlock user))) ;; set/get status (define (rmt:get-run-status run-id) + (assert (number? run-id) "FATAL: Run id required.") (rmt:send-receive 'get-run-status #f (list run-id))) (define (rmt:get-run-state run-id) + (assert (number? run-id) "FATAL: Run id required.") (rmt:send-receive 'get-run-state #f (list run-id))) (define (rmt:set-run-status run-id run-status #!key (msg #f)) + (assert (number? run-id) "FATAL: Run id required.") (rmt:send-receive 'set-run-status #f (list run-id run-status msg))) (define (rmt:set-run-state-status run-id state status ) + (assert (number? run-id) "FATAL: Run id required.") (rmt:send-receive 'set-run-state-status #f (list run-id state status))) (define (rmt:update-tesdata-on-repilcate-db old-lt new-lt) (rmt:send-receive 'update-tesdata-on-repilcate-db #f (list old-lt new-lt))) (define (rmt:update-run-event_time run-id) + (assert (number? run-id) "FATAL: Run id required.") (rmt:send-receive 'update-run-event_time #f (list run-id))) (define (rmt:get-runs-by-patt keys runnamepatt targpatt offset limit fields last-runs-update #!key (sort-order "asc")) ;; fields of #f uses default (rmt:send-receive 'get-runs-by-patt #f (list keys runnamepatt targpatt offset limit fields last-runs-update sort-order))) (define (rmt:find-and-mark-incomplete run-id ovr-deadtime) + (assert (number? run-id) "FATAL: Run id required.") ;; (if (rmt:send-receive 'have-incompletes? run-id (list run-id ovr-deadtime)) (rmt:send-receive 'mark-incomplete run-id (list run-id ovr-deadtime))) ;; ) (define (rmt:get-main-run-stats run-id) + (assert (number? run-id) "FATAL: Run id required.") (rmt:send-receive 'get-main-run-stats #f (list run-id))) (define (rmt:get-var varname) (rmt:send-receive 'get-var #f (list varname))) @@ -869,39 +921,46 @@ ;; ;;(define (rmt:get-steps-for-test run-id test-id) ;; (rmt:send-receive 'get-steps-data run-id (list test-id))) (define (rmt:teststep-set-status! run-id test-id teststep-name state-in status-in comment logfile) + (assert (number? run-id) "FATAL: Run id required.") (let* ((state (items:check-valid-items "state" state-in)) (status (items:check-valid-items "status" status-in))) (if (or (not state)(not status)) (debug:print 3 *default-log-port* "WARNING: Invalid " (if status "status" "state") " value \"" (if status state-in status-in) "\", update your validvalues section in megatest.config")) (rmt:send-receive 'teststep-set-status! run-id (list run-id test-id teststep-name state-in status-in comment logfile)))) (define (rmt:delete-steps-for-test! run-id test-id) + (assert (number? run-id) "FATAL: Run id required.") (rmt:send-receive 'delete-steps-for-test! run-id (list run-id test-id))) (define (rmt:get-steps-for-test run-id test-id) + (assert (number? run-id) "FATAL: Run id required.") (rmt:send-receive 'get-steps-for-test run-id (list run-id test-id))) -(define (rmt:get-steps-info-by-id test-step-id) - (rmt:send-receive 'get-steps-info-by-id #f (list test-step-id))) +(define (rmt:get-steps-info-by-id run-id test-step-id) + (assert (number? run-id) "FATAL: Run id required.") + (rmt:send-receive 'get-steps-info-by-id #f (list run-id test-step-id))) ;;====================================================================== ;; T E S T D A T A ;;====================================================================== (define (rmt:read-test-data run-id test-id categorypatt #!key (work-area #f)) + (assert (number? run-id) "FATAL: Run id required.") (rmt:send-receive 'read-test-data run-id (list run-id test-id categorypatt))) (define (rmt:read-test-data-varpatt run-id test-id categorypatt varpatt #!key (work-area #f)) + (assert (number? run-id) "FATAL: Run id required.") (rmt:send-receive 'read-test-data-varpatt run-id (list run-id test-id categorypatt varpatt))) -(define (rmt:get-data-info-by-id test-data-id) - (rmt:send-receive 'get-data-info-by-id #f (list test-data-id))) +(define (rmt:get-data-info-by-id run-id test-data-id) + (assert (number? run-id) "FATAL: Run id required.") + (rmt:send-receive 'get-data-info-by-id #f (list run-id test-data-id))) (define (rmt:testmeta-add-record testname) (rmt:send-receive 'testmeta-add-record #f (list testname))) (define (rmt:testmeta-get-record testname) @@ -909,13 +968,15 @@ (define (rmt:testmeta-update-field test-name fld val) (rmt:send-receive 'testmeta-update-field #f (list test-name fld val))) (define (rmt:test-data-rollup run-id test-id status) + (assert (number? run-id) "FATAL: Run id required.") (rmt:send-receive 'test-data-rollup run-id (list run-id test-id status))) (define (rmt:csv->test-data run-id test-id csvdata) + (assert (number? run-id) "FATAL: Run id required.") (rmt:send-receive 'csv->test-data run-id (list run-id test-id csvdata))) ;;====================================================================== ;; T A S K S ;;====================================================================== @@ -963,10 +1024,11 @@ (define (rmt:archive-register-disk bdisk-name bdisk-path df) (rmt:send-receive 'archive-register-disk #f (list bdisk-name bdisk-path df))) (define (rmt:test-set-archive-block-id run-id test-id archive-block-id) + (assert (number? run-id) "FATAL: Run id required.") (rmt:send-receive 'test-set-archive-block-id run-id (list run-id test-id archive-block-id))) (define (rmt:test-get-archive-block-info archive-block-id) (rmt:send-receive 'test-get-archive-block-info #f (list archive-block-id))) @@ -973,12 +1035,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 @@ -312,10 +312,25 @@ (begin (hash-table-set! *runs:denoise* key currtime) #t) #f))) +(define *last-test-launch* 0) +(define *too-soon-delays* (make-hash-table)) + +;; to-soon delay, when matching event happened in less than dseconds delay wseconds +;; +(define (runs:too-soon-delay key dseconds wseconds) + (let* ((last-time (hash-table-ref/default *too-soon-delays* key #f))) + (if (and last-time + (< (- (current-seconds) last-time) dseconds)) + (begin + (if (runs:lownoise (conc "too-soon-delay"key) 60) + (debug:print-info 2 *default-log-port* "Polling throttle for "key)) + (thread-sleep! wseconds))) + (hash-table-set! *too-soon-delays* key (current-seconds)))) + (define (runs:can-run-more-tests runsdat run-id jobgroup max-concurrent-jobs) ;; Take advantage of a good place to exit if running the one-pass methodology (if (and (> (runs:dat-can-run-more-tests-count runsdat) 20) (args:get-arg "-one-pass")) @@ -508,12 +523,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 +541,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) @@ -1287,10 +1302,11 @@ ;; we are going to reset all the counters for test retries by setting a new hash table ;; this means they will increment only when nothing can be run (set! *max-tries-hash* (make-hash-table)) (run:test run-id run-info keyvals runname test-record flags #f test-registry all-tests-registry runsdat testdat) + (set! *last-test-launch* (current-seconds)) (runs:incremental-print-results run-id) (hash-table-set! test-registry (db:test-make-full-name test-name item-path) 'running) (runs:shrink-can-run-more-tests-count runsdat) ;; DELAY TWEAKER (still needed?) ;; (thread-sleep! *global-delta*) (if (or (not (null? tal))(not (null? reg))) @@ -1502,10 +1518,12 @@ ;; (define *max-tries-hash* (make-hash-table)) (define (runs:pretty-long-list lst) (if (> (length lst) 8)(append (take lst 3)(list "...")) lst)) + +(define *last-loop-time-ms* 0) ;;====================================================================== ;; runs:run-tests-queue is called by runs:run-tests ;;====================================================================== ;; @@ -1640,12 +1658,29 @@ testmode: testmode newtal: newtal itemmaps: itemmaps ;; prereqs-not-met: prereqs-not-met ))) + + ;; too-tight loop detection and delay, this might hide issues + ;; that occur in long run times. Consider commenting when debugging + ;; + (if (and (>= num-running max-concurrent-jobs) + (< (- (current-milliseconds) *last-loop-time-ms*) 500)) + (begin + (if (runs:lownoise "too-tight-loop" 5) + (debug:print-info 2 *default-log-port* "Excessively fast loop, delaying 1/2 second")) + (thread-sleep! 0.5))) + (set! *last-loop-time-ms* (current-milliseconds)) + (runs:dat-regfull-set! runsdat regfull) - + + + (if (> (- (current-seconds) *last-test-launch*) 5) ;; be pretty aggressive for five seconds after + (runs:too-soon-delay (conc "loop delay " hed) 1 0.6) ;; starting a test then apply more delay + (runs:too-soon-delay (conc "loop delay " hed) 1 0.1)) + (if (> num-running 0) (set! last-time-some-running (current-seconds))) (if (> (current-seconds)(+ last-time-some-running (or (configf:lookup *configdat* "setup" "give-up-waiting") 36000))) (hash-table-set! *max-tries-hash* tfullname (+ (hash-table-ref/default *max-tries-hash* tfullname 0) 1))) @@ -1890,11 +1925,11 @@ (rmt:set-var (conc "lunch-complete-" run-id) "yes") ;; now *if* -run-wait we wait for all tests to be done ;; Now wait for any RUNNING tests to complete (if in run-wait mode) ;; (if (runs:dat-load-mgmt-function runsdat)((runs:dat-load-mgmt-function runsdat))) - (thread-sleep! 10) ;; I think there is a race condition here. Let states/statuses settle + (thread-sleep! 0.1) ;; I think there is a race condition here. Let states/statuses settle (let wait-loop ((num-running (rmt:get-count-tests-running-for-run-id run-id)) (prev-num-running 0)) ;; (debug:print-info 13 *default-log-port* "num-running=" num-running ", prev-num-running=" prev-num-running) (if (and (or (args:get-arg "-run-wait") @@ -2347,15 +2382,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* "/.megatest/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 @@ -23,18 +23,22 @@ (use spiffy uri-common intarweb http-client spiffy-request-vars) (declare (unit server)) +(declare (uses commonmod)) + (declare (uses common)) (declare (uses db)) (declare (uses tasks)) ;; tasks are where stuff is maintained about what is running. ;; (declare (uses synchash)) (declare (uses http-transport)) ;;(declare (uses rpc-transport)) (declare (uses launch)) ;; (declare (uses daemon)) + +(import commonmod) (include "common_records.scm") (include "db_records.scm") (define (server:make-server-url hostport) @@ -229,11 +233,11 @@ (exn (i/o file)(debug:print 0 *default-log-port* "ERROR: Cannot create directory at " (conc areapath "/logs"))) (exn ()(debug:print 0 *default-log-port* "ERROR: Unknown error attemtping to get server list. exn=" exn))) (directory-exists? (conc areapath "/logs"))) '())) - ;; Get the list of server logs. First remove logs for servers that have exited. + ;; Get the list of server logs. (let* ( ;; For some reason, when I uncomment the below line, ext-tests sometimes starts 1000's of servers. ;; (exiting-servers (system (conc "bash -c 'rm -f `grep -il exiting " areapath "/logs/server-*-*.log 2> /dev/null`'"))) (server-logs (glob (conc areapath "/logs/server-*-*.log"))) (num-serv-logs (length server-logs))) @@ -246,11 +250,11 @@ (tal (cdr server-logs)) (res '())) (let* ((mod-time (handle-exceptions exn (begin - (debug:print 0 *default-log-port* "failed to get modification time on " hed ", exn=" exn) + (debug:print 0 *default-log-port* "server:get-list: failed to get modification time on " hed ", exn=" exn) (current-seconds)) ;; 0 (file-modification-time hed))) ;; default to *very* old so log gets ignored if deleted (down-time (- (current-seconds) mod-time)) (serv-dat (if (or (< num-serv-logs 10) (< down-time 900)) ;; day-seconds)) @@ -565,17 +569,19 @@ (if (equal? *toppath* toppath) #t #f))) ;; timeout is hms string: 1h 5m 3s, default is 1 minute +;; This is currently broken. Just use the number of hours with no unit. +;; Default is 60 seconds. ;; (define (server:expiration-timeout) (let ((tmo (configf:lookup *configdat* "server" "timeout"))) (if (and (string? tmo) (common:hms-string->seconds tmo)) ;; BUG: hms-string->seconds is broken, if given "10" returns 0. Also, it doesn't belong in this logic unless the string->number is changed below (* 3600 (string->number tmo)) - 60))) + 1200))) (define (server:get-best-guess-address hostname) (let ((res #f)) (for-each (lambda (adr) @@ -606,11 +612,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 +712,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: subrun.scm ================================================================== --- subrun.scm +++ subrun.scm @@ -47,11 +47,11 @@ (define (subrun:launch-dashboard test-run-dir) (if (subrun:subrun-test-initialized? test-run-dir) (let* ((subarea (subrun:get-runarea test-run-dir))) (if (and subarea (common:file-exists? subarea)) - (system (conc "cd " subarea ";env -i PATH=$PATH DISPLAY=$DISPLAY HOME=$HOME USER=$USER dashboard &")))))) + (system (conc "cd " subarea ";env -i PATH=\"$PATH\" DISPLAY=$DISPLAY HOME=$HOME USER=$USER dashboard &")))))) (define (subrun:subrun-removed? test-run-dir) (if (subrun:subrun-test-initialized? test-run-dir) (let ((flagfile (conc test-run-dir "/subrun.removed"))) (if (common:file-exists? flagfile) Index: tasks.scm ================================================================== --- tasks.scm +++ tasks.scm @@ -20,15 +20,17 @@ (use sqlite3 srfi-1 posix regex regex-case srfi-69 dot-locking format) (import (prefix sqlite3 sqlite3:)) (declare (unit tasks)) +(declare (uses dbfile)) (declare (uses db)) (declare (uses rmt)) (declare (uses common)) (declare (uses pgdb)) +(import dbfile) ;; (import pgdb) ;; pgdb is a module (include "task_records.scm") (include "db_records.scm") @@ -327,11 +329,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 +364,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 +391,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 +408,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 +425,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 +442,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 +479,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 +491,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. ;; @@ -837,14 +838,20 @@ (define (tasks:sync-test-steps dbh cached-info test-step-ids smallest-last-update-time) ; (print "Sync Steps " test-step-ids ) (let ((test-ht (hash-table-ref cached-info 'tests)) - (step-ht (hash-table-ref cached-info 'steps))) + (step-ht (hash-table-ref cached-info 'steps)) + (run-id-in #f) + ) (for-each (lambda (test-step-id) - (let* ((test-step-info (rmt:get-steps-info-by-id test-step-id)) + (set! run-id-in (cdr test-step-id)) + (set! test-step-id (car test-step-id)) + + + (let* ((test-step-info (rmt:get-steps-info-by-id run-id-in test-step-id)) (step-id (tdb:step-get-id test-step-info)) (test-id (tdb:step-get-test_id test-step-info)) (stepname (tdb:step-get-stepname test-step-info)) (state (tdb:step-get-state test-step-info)) (status (tdb:step-get-status test-step-info)) @@ -879,14 +886,18 @@ (debug:print-info 1 *default-log-port* "Error: Could not get test step info for step id " test-step-id )))) ;; this is a wierd senario need to debug test-step-ids))) (define (tasks:sync-test-gen-data dbh cached-info test-data-ids smallest-last-update-time) (let ((test-ht (hash-table-ref cached-info 'tests)) - (data-ht (hash-table-ref cached-info 'data))) + (data-ht (hash-table-ref cached-info 'data)) + (run-id-in #f) + ) (for-each (lambda (test-data-id) - (let* ((test-data-info (rmt:get-data-info-by-id test-data-id)) + (set! run-id-in (cdr test-data-id)) + (set! test-data-id (car test-data-id)) + (let* ((test-data-info (rmt:get-data-info-by-id run-id-in test-data-id)) (data-id (db:test-data-get-id test-data-info)) (test-id (db:test-data-get-test_id test-data-info)) (category (db:test-data-get-category test-data-info)) (variable (db:test-data-get-variable test-data-info)) (value (db:test-data-get-value test-data-info)) @@ -938,15 +949,19 @@ test-data-ids))) (define (tasks:sync-tests-data dbh cached-info test-ids area-info smallest-last-update-time) - (let ((test-ht (hash-table-ref cached-info 'tests))) + (let ((test-ht (hash-table-ref cached-info 'tests)) + (run-id-in #f)) (for-each (lambda (test-id) - ; (print test-id) - (let* ((test-info (rmt:get-test-info-by-id #f test-id)) + (set! run-id-in (cdr test-id)) + (set! test-id (car test-id)) + + (debug:print 0 *default-log-port* "test-id: " test-id " run-id: " run-id-in) + (let* ((test-info (rmt:get-test-info-by-id run-id-in test-id)) (run-id (db:test-get-run_id test-info)) ;; look these up in db_records.scm (test-id (db:test-get-id test-info)) (test-name (db:test-get-testname test-info)) (item-path (db:test-get-item-path test-info)) (state (db:test-get-state test-info)) @@ -972,11 +987,11 @@ #f))) ;; "id" "run_id" "testname" "state" "status" "event_time" ;; "host" "cpuload" "diskfree" "uname" "rundir" "item_path" ;; "run_duration" "final_logf" "comment" "shortdir" "attemptnum" "archived" (if (or (not item-path) (string-null? item-path)) - (debug:print-info 0 *default-log-port* "Working on Run id : " run-id "and test name : " test-name)) + (debug:print-info 0 *default-log-port* "Working on Run id : " run-id " and test name : " test-name)) (if pgdb-run-id (begin (if pgdb-test-id ;; have a record (begin ;; let ((key-name (conc run-id "/" test-name "/" item-path))) (debug:print-info 4 *default-log-port* "Updating existing test with run-id: " run-id " and test-id: " test-id " pgdb run id: " pgdb-run-id " pgdb-test-id " pgdb-test-id) @@ -1031,64 +1046,69 @@ (print "In sync") (let* ((dbh (pgdb:open configdat dbname: dest)) (area-info (pgdb:get-area-by-path dbh *toppath*)) (cached-info (make-hash-table)) (start (current-seconds)) - (test-patt (if (args:get-arg "-testpatt") - (args:get-arg "-testpatt") + (test-patt (if (args:get-arg "-testpatt") + (args:get-arg "-testpatt") "%")) - (target (if (args:get-arg "-target") - (args:get-arg "-target") - #f)) - (run-name (if (args:get-arg "-runname") - (args:get-arg "-runname") - #f))) + (target (if (args:get-arg "-target") + (args:get-arg "-target") + #f)) + (run-name (if (args:get-arg "-runname") + (args:get-arg "-runname") + #f))) (if (and target (not run-name)) (begin - (print "Error: Provide runname") + (print "Error: Provide runname") (exit 1))) (if (and (not target) run-name) (begin - (print "Error: Provide target") + (print "Error: Provide target") (exit 1))) ;(print "123") - ;(exit 1) + ;(exit 1) (for-each (lambda (dtype) (hash-table-set! cached-info dtype (make-hash-table))) '(runs targets tests steps data)) (hash-table-set! cached-info 'start start) ;; when done we'll set sync times to this (if area-info - (let* ((last-sync-time (vector-ref area-info 3)) + (let* ((last-sync-time (if (args:get-arg "-since") (string->number (args:get-arg "-since")) (vector-ref area-info 3))) (smallest-last-update-time (make-hash-table)) - (changed (if (and target run-name) + (changed (if (and target run-name) (rmt:get-run-record-ids target run-name (rmt:get-keys) test-patt) (rmt:get-changed-record-ids last-sync-time))) (run-ids (alist-ref 'runs changed)) (test-ids (alist-ref 'tests changed)) (test-step-ids (alist-ref 'test_steps changed)) (test-data-ids (alist-ref 'test_data changed)) (run-stat-ids (alist-ref 'run_stats changed)) - (area-tag (if (args:get-arg "-area-tag") + (area-tag (if (args:get-arg "-area-tag") (args:get-arg "-area-tag") (if (args:get-arg "-area") (args:get-arg "-area") "")))) (if (and (equal? area-tag "") (not (pgdb:is-area-taged dbh (vector-ref area-info 0)))) (set! area-tag *default-area-tag*)) (if (not (equal? area-tag "")) (task:add-area-tag dbh area-info area-tag)) - (if (or (not (null? test-ids)) (not (null? run-ids))) - (begin - (debug:print-info 0 *default-log-port* "syncing runs") - (tasks:sync-run-data dbh cached-info run-ids area-info smallest-last-update-time) - (debug:print-info 0 *default-log-port* "syncing tests") - (tasks:sync-tests-data dbh cached-info test-ids area-info smallest-last-update-time) - (debug:print-info 0 *default-log-port* "syncing test steps") - (tasks:sync-test-steps dbh cached-info test-step-ids smallest-last-update-time) - (debug:print-info 0 *default-log-port* "syncing test data") - (tasks:sync-test-gen-data dbh cached-info test-data-ids smallest-last-update-time) - (print "----------done---------------"))) + (if (not (null? run-ids)) + (begin + (debug:print-info 0 *default-log-port* "syncing runs: " run-ids) + (tasks:sync-run-data dbh cached-info run-ids area-info smallest-last-update-time) + ) + ) + (if (not (null? test-ids)) + (begin + (debug:print-info 0 *default-log-port* "syncing tests: " test-ids) + (tasks:sync-tests-data dbh cached-info test-ids area-info smallest-last-update-time) + (debug:print-info 0 *default-log-port* "syncing test steps") + (tasks:sync-test-steps dbh cached-info test-step-ids smallest-last-update-time) + (debug:print-info 0 *default-log-port* "syncing test data") + (tasks:sync-test-gen-data dbh cached-info test-data-ids smallest-last-update-time) + ) + ) (let* ((smallest-time (hash-table-ref/default smallest-last-update-time "smallest-time" (current-seconds)))) (debug:print-info 0 "smallest-time :" smallest-time " last-sync-time " last-sync-time) (if (not (and target run-name)) (if (or (and smallest-time (> smallest-time last-sync-time)) (and smallest-time (eq? last-sync-time 0))) (pgdb:write-sync-time dbh area-info smallest-time))))) ;;this needs to be changed ADDED testlocking/justtest.scm Index: testlocking/justtest.scm ================================================================== --- /dev/null +++ testlocking/justtest.scm @@ -0,0 +1,9 @@ +(print "Starting at "(current-seconds)) + +(dbfile:with-simple-file-lock "justtesting.lock" + (lambda () + (print "got the lock at "(current-seconds)"!"))) + +(print "Done at: " (current-seconds)) +(exit) + ADDED testlocking/testlock.sh Index: testlocking/testlock.sh ================================================================== --- /dev/null +++ testlocking/testlock.sh @@ -0,0 +1,12 @@ +#!/bin/bash + +HRS=$(date +%H) +MINS=$(($(date +%M) + 1)) +if [[ $MINS -lt 10 ]];then + MINS="0${MINS}" +fi +THETIME="$HRS:$MINS" +echo "THETIME=$THETIME" +for x in a b c d e f g h i j;do + echo "megatest -load justtest.scm > $x.log" | at $THETIME +done Index: tests.scm ================================================================== --- tests.scm +++ tests.scm @@ -25,19 +25,21 @@ (declare (unit tests)) (declare (uses lock-queue)) (declare (uses db)) (declare (uses tdb)) (declare (uses common)) +(declare (uses commonmod)) ;; (declare (uses dcommon)) ;; needed for the steps processing (declare (uses items)) (declare (uses runconfig)) ;; (declare (uses sdb)) (declare (uses server)) ;;(declare (uses stml2)) (use sqlite3 srfi-1 posix regex regex-case srfi-69 dot-locking tcp directory-utils) (import (prefix sqlite3 sqlite3:)) +(import commonmod) (require-library stml) (include "common_records.scm") (include "key_records.scm") (include "db_records.scm") @@ -1775,11 +1777,11 @@ )))))) ;; (tests:run-dot (list "digraph tests {" "a -> b" "}") "plain") (define (tests:run-dot indat outtype) ;; outtype is plain, fig, dot, etc. http://www.graphviz.org/content/output-formats - (let-values (((inp oup pid)(process "env -i PATH=$PATH dot" (list "-T" outtype)))) + (let-values (((inp oup pid)(process "env -i PATH=\"$PATH\" dot" (list "-T" outtype)))) (with-output-to-port oup (lambda () (map print indat))) (close-output-port oup) (let ((res (with-input-from-port inp @@ -1797,14 +1799,14 @@ (tests:write-dot-file testrecords dfile sizex sizey) (if (common:file-exists? fname) (let ((res (with-input-from-file fname (lambda () (read-lines))))) - (system (conc "env -i PATH=$PATH dot -T " outtype " < " dfile " > " fname "&")) + (system (conc "env -i PATH=\"$PATH\" dot -T " outtype " < " dfile " > " fname "&")) res) (begin - (system (conc "env -i PATH=$PATH dot -T " outtype " < " dfile " > " fname)) + (system (conc "env -i PATH=\"$PATH\" dot -T " outtype " < " dfile " > " fname)) (with-input-from-file fname (lambda () (read-lines))))))) 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,126 @@ +(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 + ) + +(system "touch /tmp/mmgraham/megatest_localdb/simplerun/.nfs.pdx.disks.icf_gwa_001.mmgraham.fossil.megatest1.7.mod.tests.simplerun/.db/10.db") + +;; *************** 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 2 db:initialize-main-db)) +;; (define rundbdat3 (dbfile:open-db dbstruct 3 db:initialize-main-db)) +;; (dbfile:add-dbdat dbstruct 1 rundbdat) +;; (dbfile:add-dbdat dbstruct 2 rundbdat2) +;; (dbfile:add-dbdat dbstruct 3 rundbdat3) +;; (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 (> (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)) + +;; (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 (dbr:subdb? (dbfile:get-subdb dbstruct #f))) +;; (test #f #t (dbr:subdb? (dbfile:get-subdb dbstruct (string->number "1")))) +;; (test #f #t (dbr:subdb? (dbfile:get-subdb dbstruct 2))) + + +;; (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:all-db-sync dbstruct)) + +(exit) + +;; (test #f #t (db:close-all dbstruct)) +(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))) + ADDED utils/mt-new-to-old.sh Index: utils/mt-new-to-old.sh ================================================================== --- /dev/null +++ utils/mt-new-to-old.sh @@ -0,0 +1,8 @@ +#!/bin/bash + +cp .megatest/main.db megatest.db + +for db in $(ls .megatest/?.db); do + echo $db + sqlite3 $db "SELECT * FROM tests" | sqlite3 megatest.db ".import /dev/stdin tests" +done ADDED utils/mt-old-to-new.sh Index: utils/mt-old-to-new.sh ================================================================== --- /dev/null +++ utils/mt-old-to-new.sh @@ -0,0 +1,41 @@ +#!/bin/bash +if [ -d ".megatest" ] +then + echo ".megatest directory present." + echo "You have already migrated. " + exit +fi + +mkdir -p .megatest +cp megatest.db .megatest/main.db +sqlite3 .megatest/main.db << END_SQL +delete from tests; +delete from test_steps; +END_SQL +version_id=$(sqlite3 .megatest/main.db "select id from metadat where var = 'MEGATEST_VERSION'") +current_version=$(megatest -version) +sqlite3 .megatest/main.db "replace into metadat (id,var,val) values($version_id,'MEGATEST_VERSION','$current_version')" + + +sqlite3 megatest.db 'select id from runs' > runs.txt +for run in $(cat runs.txt) +do + echo "working on run id $run" + dbnum=$(($run%100)) + if [ ! -f ".megatest/$dbnum.db" ] + then + dbnum=$(($run%100)) + cp megatest.db .megatest/$dbnum.db + sqlite3 .megatest/$dbnum.db << END_SQL + delete from tests where run_id in (select id from runs where id%100!=$dbnum); + delete from test_data; + delete from test_meta; + delete from test_rundat; + delete from test_steps where not exists ( select id from tests where tests.id = test_steps.test_id); + replace into metadat (id,var,val) values($version_id,'MEGATEST_VERSION','$current_version'); + VACUUM; +END_SQL + + fi +done + Index: utils/mt_ezstep ================================================================== --- utils/mt_ezstep +++ utils/mt_ezstep @@ -31,11 +31,11 @@ exit fi # Since the user may not have . on the path and since we are likely to want to # run test scripts in the current directory add the current dir to the path -export PATH=$PATH:$PWD +export PATH="$PATH:$PWD" testrundir=$1; shift stepname=$1;shift command=$* Index: utils/mt_xterm ================================================================== --- utils/mt_xterm +++ utils/mt_xterm @@ -16,14 +16,25 @@ # # You should have received a copy of the GNU General Public License # along with Megatest. If not, see . MT_TMPDISPLAY=$DISPLAY -if [ -e megatest.sh ];then - source megatest.sh -fi +MT_TMPUSER=$USER +MT_HOME=$HOME + +tmpfile=`mktemp` + +grep -v "export USER=" megatest.sh | grep -v "export HOME=" > $tmpfile +source $tmpfile +rm $tmpfile + +# if [ -e megatest.sh ];then +#source megatest.sh +#fi export DISPLAY=$MT_TMPDISPLAY +export USER=$USER +export HOME=$MT_HOME if [ x"$MT_XTERM_CMD" == "x" ];then exec xterm "$@" else exec $MT_XTERM_CMD Index: utils/nbfake ================================================================== --- utils/nbfake +++ utils/nbfake @@ -96,10 +96,10 @@ #====================================================================== __EOF if [[ -z "$MY_NBFAKE_HOST" ]]; then # Run locally - sh -c "cd $CURRWD;export DISPLAY=$DISPLAY; export PATH=$PATH; nohup $WASHCMD $* >> $MY_NBFAKE_LOG 2>&1 &" + sh -c "cd $CURRWD;export DISPLAY=$DISPLAY; export PATH=\"$PATH\"; nohup $WASHCMD $* >> $MY_NBFAKE_LOG 2>&1 &" else # run remotely - ssh -X -n -f $MY_NBFAKE_HOST "sh -c \"cd $CURRWD;export DISPLAY=$DISPLAY; export PATH=$PATH; nohup $WASHCMD $* >> $MY_NBFAKE_LOG 2>&1 &\"" + ssh -X -n -f $MY_NBFAKE_HOST "sh -c \"cd $CURRWD;export DISPLAY=$DISPLAY; export PATH=\"$PATH\"; nohup $WASHCMD $* >> $MY_NBFAKE_LOG 2>&1 &\"" fi ADDED utils/open-files.sh Index: utils/open-files.sh ================================================================== --- /dev/null +++ utils/open-files.sh @@ -0,0 +1,3 @@ +echo "Database opens: $(lsof -c mtest|egrep '.*db$'|wc -l)" +echo "Logfile opens: $(lsof -c mtest|egrep '.*log$'|wc -l)" +echo "TCP connections: $(lsof -c mtest|grep TCP|wc -l)"