Index: Makefile
==================================================================
--- Makefile
+++ Makefile
@@ -4,13 +4,14 @@
INSTALL=install
SRCFILES = common.scm items.scm launch.scm \
ods.scm runconfig.scm server.scm configf.scm \
db.scm keys.scm margs.scm megatest-version.scm \
process.scm runs.scm tasks.scm tests.scm genexample.scm \
- fs-transport.scm http-transport.scm \
+ http-transport.scm filedb.scm \
client.scm gutils.scm synchash.scm daemon.scm mt.scm dcommon.scm \
- tree.scm ezsteps.scm lock-queue.scm sdb.scm
+ tree.scm ezsteps.scm lock-queue.scm sdb.scm \
+ rmt.scm api.scm tdb.scm
GUISRCF = dashboard-tests.scm dashboard-guimonitor.scm
OFILES = $(SRCFILES:%.scm=%.o)
GOFILES = $(GUISRCF:%.scm=%.o)
@@ -61,10 +62,11 @@
tests.o runs.o dashboard.o dashboard-tests.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
tests.o tasks.o dashboard-tasks.o : task_records.scm
runs.o : test_records.scm
megatest.o : megatest-fossil-hash.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 zmq-transport.scm : common_records.scm
# Temporary while transitioning to new routine
# runs.o : run-tests-queue-classic.scm run-tests-queue-new.scm
megatest-fossil-hash.scm : $(SRCFILES) megatest.scm *_records.scm
@@ -105,11 +107,11 @@
$(PREFIX)/bin/nbfind : utils/nbfind
$(INSTALL) $< $@
chmod a+x $@
-$(PREFIX)/bin/nbload : utils/nbload
+$(PREFIX)/bin/loadrunner : utils/loadrunner
$(INSTALL) $< $@
chmod a+x $@
$(PREFIX)/bin/refdb : refdb
$(INSTALL) $< $@
@@ -129,11 +131,11 @@
$(INSTALL) dboard $(PREFIX)/bin/dboard
utils/mk_wrapper $(PREFIX) dboard > $(PREFIX)/bin/dashboard
chmod a+x $(PREFIX)/bin/dashboard
install : bin $(PREFIX)/bin/mtest $(PREFIX)/bin/megatest $(PREFIX)/bin/dboard $(PREFIX)/bin/dashboard $(HELPERS) $(PREFIX)/bin/nbfake \
- $(PREFIX)/bin/nbfind $(PREFIX)/bin/nbload $(PREFIX)/bin/newdboard $(PREFIX)/bin/refdb $(PREFIX)/bin/mt_xterm $(PREFIX)/bin/revtagfsl
+ $(PREFIX)/bin/nbfind $(PREFIX)/bin/loadrunner $(PREFIX)/bin/newdboard $(PREFIX)/bin/refdb $(PREFIX)/bin/mt_xterm $(PREFIX)/bin/revtagfsl
deploytarg/apropos.so : Makefile
for i in apropos base64 canvas-draw csv-xml directory-utils dot-locking extras fmt format hostinfo http-client intarweb json md5 message-digest posix posix-extras readline regex regex-case s11n spiffy spiffy-request-vars sqlite3 srfi-1 srfi-18 srfi-69 tcp test uri-common check-errors synch matchable sql-null tcp-server rpc blob-utils string-utils variable-item defstruct uri-generic sendfile opensll openssl lookup-table list-utils stack; do \
chicken-install -prefix deploytarg -deploy $$i;done
Index: NOTES
==================================================================
--- NOTES
+++ NOTES
@@ -1,5 +1,75 @@
+======================================================================
+Try writing to in-memory db and every 2-5 seconds syncing to megatest.db
+======================================================================
+
+First, how much time will it take to write back the changes:
+
+1. Get the run table
+
+(define (get-all db)(let ((res '()))(for-each-row (lambda (a . b)(set! res (cons (apply vector a b) res))) db "SELECT * FROM tests;") res))
+(define tdata (let ((start (current-milliseconds))(res (get-all *db*)))(print (- (current-milliseconds) start))res))
+
+Result ranges from 34ms to 89ms but mostly around 40ms for 623 records on moosefs
+
+Projecting to 15000 records:
+
+ Slow 2 seconds to read all
+ Median 1 second to read all
+
+This seems like it would work with an update period of 2-5 seconds
+
+TODO
+----
+
+1. open-db opens in-memory db and megatest.db, put handles in *memdb* and *db*, *memdb* is < run-id dbh >
+2. Server is part of runtests
+ a. server start cycle - adapt to per run-id
+ i. states; starting, started, stopping, stopped
+ b. turn off write coalesing
+3. Calls to -runtests, -remove-runs etc.
+ a. Might talk to running server if run specific
+ b. Can talk to megatest.db but not a generally good idea
+ c. Can start a runserver
+4. Dashboard is fine except for writes?
+
+======================================================================
+Routines to convert for runs.scm
+
+cdb:remote-run db:register-run
+
+cdb:delete-tests-in-state *runremote*
+cdb:get-test-info-by-id *runremote*
+cdb:remote-run db:delete-old-deleted-test-records
+cdb:remote-run db:delete-run
+cdb:remote-run db:delete-test-records
+cdb:remote-run db:delete-tests-for-run
+cdb:remote-run db:find-and-mark-incomplete
+cdb:remote-run db:get-count-tests-running
+cdb:remote-run db:get-count-tests-running-in-jobgroup
+cdb:remote-run db:get-keys
+cdb:remote-run db:get-run-info
+cdb:remote-run db:get-run-key-val
+cdb:remote-run db:get-run-name-from-id
+cdb:remote-run db:get-steps-for-test
+cdb:remote-run db:get-test-id-cached
+cdb:remote-run db:get-tests-for-runs-mindata
+cdb:remote-run db:lock/unlock-run
+cdb:remote-run db:set-sync
+cdb:remote-run db:set-tests-state-status
+cdb:remote-run db:set-var
+cdb:remote-run db:testmeta-add-record
+cdb:remote-run db:testmeta-get-record
+cdb:remote-run db:testmeta-update-field
+cdb:remote-run db:update-run-event_time
+cdb:remote-run instead
+cdb:remote-run server:start
+cdb:remote-run test:get-matching-previous-test-run-records
+cdb:tests-register-test *runremote*
+(define (runs:shrink-can-run-more-tests-count) ;; the db is a dummy var so we can use cdb:remote-run
+
+======================================================================
[87cbe68f31]
[be405e8e2e]
# FROM andyjpg on #chicken
Index: TODO
==================================================================
--- TODO
+++ TODO
@@ -1,4 +1,12 @@
-1. Confirm that branch transaction-for-sequential-writes content was added to trunk/development
-2. Add a host chooser for ssh to launch-tests
-3. Try making static executable
+TODO
+====
+
+Migration to inmem db plus per run db
+-------------------------------------
+
+. Re-work the dbstruct data structure?
+.. Move main.db to global?
+.. [ run-id.db inmemdb last-mod last-read last-sync inuse ]
+. Re-work all queries to use run-id to dereference server
+. Open main.db directly in calls to -runtests etc. No need to talk remote?
ADDED api.scm
Index: api.scm
==================================================================
--- /dev/null
+++ api.scm
@@ -0,0 +1,129 @@
+;;======================================================================
+;; Copyright 2006-2013, Matthew Welland.
+;;
+;; This program is made available under the GNU GPL version 2.0 or
+;; greater. See the accompanying file COPYING for details.
+;;
+;; This program is distributed WITHOUT ANY WARRANTY; without even the
+;; implied warranty of MERCHANTABILITY or FITNESS FOR A PARTICULAR
+;; PURPOSE.
+;;======================================================================
+
+(declare (unit api))
+(declare (uses rmt))
+(declare (uses db))
+
+;; These are called by the server on recipt of /api calls
+
+(define (api:execute-requests dbstruct cmd params)
+ (case (string->symbol cmd)
+ ;; SERVERS
+ ((start-server) (apply server:kind-run params))
+ ;; ((kill-server)
+ ;; (db:sync-tables (db:tbls *inmemdb*) *inmemdb* *db*) ;; (db:sync-to *inmemdb* *db*)
+ ;; (let ((hostname (car *runremote*))
+ ;; (port (cadr *runremote*))
+ ;; (pid (if (null? params) #f (car params)))
+ ;; (th1 (make-thread (lambda ()(thread-sleep! 3)(debug:print 0 "Server exiting!")(exit 0)) "Server exit thread")))
+ ;; (debug:print 0 "WARNING: Server on " hostname ":" port " going down by user request!")
+ ;; (debug:print-info 1 "current pid=" (current-process-id))
+ ;; (open-run-close tasks:server-deregister tasks:open-db
+ ;; hostname
+ ;; port: port)
+ ;; (set! *server-run* #f)
+ ;; (thread-sleep! 3)
+ ;; (if pid
+ ;; (process-signal pid signal/kill)
+ ;; (thread-start! th1))
+ ;; '(#t "exit process started")))
+
+ ;; KEYS
+ ((get-key-val-pairs) (apply db:get-key-val-pairs dbstruct params))
+ ((get-keys) (db:get-keys dbstruct))
+
+ ;; TESTS
+ ;; json doesn't do vectors, convert to list
+ ((get-test-info-by-id) (apply db:get-test-info-by-id dbstruct params))
+ ((test-get-rundir-from-test-id) (apply db:test-get-rundir-from-test-id dbstruct params))
+ ((test-set-state-status-by-id) (apply db:test-set-state-status-by-id dbstruct params))
+ ((get-count-tests-running) (apply db:get-count-tests-running dbstruct params))
+ ((get-count-tests-running-in-jobgroup) (apply db:get-count-tests-running-in-jobgroup dbstruct params))
+ ((delete-test-records) (apply db:delete-test-records dbstruct params))
+ ((delete-old-deleted-test-records) (apply db:delete-old-deleted-test-records dbstruct params))
+ ((test-set-status-state) (apply db:test-set-status-state dbstruct params))
+ ((get-previous-test-run-record) (apply db:get-previous-test-run-record dbstruct params))
+ ((get-matching-previous-test-run-records)(apply db:get-matching-previous-test-run-records dbstruct params))
+ ((test-get-logfile-info) (apply db:test-get-logfile-info dbstruct params))
+ ((test-get-records-for-index-file (apply db:test-get-records-for-index-file dbstruct params)))
+ ((get-testinfo-state-status) (apply db:get-testinfo-state-status dbstruct params))
+ ((test-get-paths-matching-keynames-target-new) (apply db:test-get-paths-matching-keynames-target-new dbstruct params))
+ ((get-prereqs-not-met) (apply db:get-prereqs-not-met dbstruct params))
+ ((roll-up-pass-fail-counts) (apply db:roll-up-pass-fail-counts dbstruct params))
+ ((update-fail-pass-counts) (apply db:general-call dbstruct 'update-pass-fail-counts params))
+ ((get-count-tests-running-for-run-id) (apply db:get-count-tests-running-for-run-id dbstruct params))
+
+ ;; RUNS
+ ((get-run-info) (apply db:get-run-info dbstruct params))
+ ((register-run) (apply db:register-run dbstruct params))
+ ((set-tests-state-status) (apply db:set-tests-state-status dbstruct params))
+ ((get-tests-for-run) (apply db:get-tests-for-run dbstruct params))
+ ((get-test-id) (apply db:get-test-id dbstruct params))
+ ((get-tests-for-runs-mindata) (apply db:get-tests-for-runs-mindata dbstruct params))
+ ((get-run-name-from-id) (apply db:get-run-name-from-id dbstruct params))
+ ((delete-run) (apply db:delete-run dbstruct params))
+ ((get-runs) (apply db:get-runs dbstruct params))
+ ((get-all-run-ids) (db:get-all-run-ids dbstruct))
+ ((get-prev-run-ids) (apply db:get-prev-run-ids dbstruct params))
+ ((get-run-ids-matching-target) (apply db:get-run-ids-matching-target dbstruct params))
+ ((get-runs-by-patt) (apply db:get-runs-by-patt dbstruct params))
+ ((lock/unlock-run) (apply db:lock/unlock-run dbstruct params))
+ ((update-run-event_time) (apply db:update-run-event_time dbstruct params))
+
+ ;; STEPS
+ ((teststep-set-status!) (apply db:teststep-set-status! dbstruct params))
+
+ ;; TEST DATA
+ ((test-data-rollup) (apply db:test-data-rollup dbstruct params))
+ ((csv->test-data) (apply db:csv->test-data dbstruct params))
+ ((get-steps-data) (apply db:get-steps-data dbstruct params))
+
+ ;; MISC
+ ((login) (apply db:login dbstruct params))
+ ((general-call) (let ((stmtname (car params))
+ (run-id (cadr params))
+ (realparams (cddr params)))
+ (db:with-db dbstruct run-id #t ;; these are all for modifying the db
+ (lambda (db)
+ (db:general-call db stmtname realparams)))))
+ ((sync-inmem->db) (db:sync-touched dbstruct run-id force-sync: #t))
+ ((sdb-qry) (apply sdb:qry params))
+
+ ;; TESTMETA
+ ((testmeta-get-record) (apply db:testmeta-get-record dbstruct params))
+ ((testmeta-add-record) (apply db:testmeta-add-record dbstruct params))
+ ((testmeta-update-field) (apply db:testmeta-update-field dbstruct params))
+ (else
+ (list "ERROR" 0))))
+
+;; http-server send-response
+;; api:process-request
+;; db:*
+;;
+;; NB// Runs on the server as part of the server loop
+;;
+(define (api:process-request dbstruct $) ;; the $ is the request vars proc
+ (let* ((cmd ($ 'cmd))
+ (paramsj ($ 'params))
+ (params (db:string->obj paramsj)) ;; (rmt:json-str->dat paramsj))
+ (res (api:execute-requests dbstruct cmd params)))
+
+ ;; This can be here but needs controls to ensure it doesn't run more than every 4 seconds
+ ;; (rmt:dat->json-str
+ ;; (if (or (string? res)
+ ;; (list? res)
+ ;; (number? res)
+ ;; (boolean? res))
+ ;; res
+ ;; (list "ERROR, not string, list, number or boolean" 1 cmd params res)))))
+ (db:obj->string res)))
+
Index: client.scm
==================================================================
--- client.scm
+++ client.scm
@@ -35,14 +35,10 @@
(if *my-client-signature* *my-client-signature*
(let ((sig (conc (get-host-name) " " (current-process-id))))
(set! *my-client-signature* sig)
*my-client-signature*)))
-;; client:login serverdat
-(define (client:login serverdat)
- (cdb:login serverdat *toppath* (client:get-signature)))
-
;; Not currently used! But, I think it *should* be used!!!
(define (client:logout serverdat)
(let ((ok (and (socket? serverdat)
(cdb:logout serverdat *toppath* (client:get-signature)))))
ok))
@@ -54,38 +50,84 @@
;; 1. We are a test manager and we received *transport-type* and *runremote* via cmdline
;; 2. We are a run tests, list runs or other interactive process and we must figure out
;; *transport-type* and *runremote* from the monitor.db
;;
;; client:setup
-(define (client:setup #!key (numtries 3))
- (if (not *toppath*)
- (if (not (setup-for-run))
- (begin
- (debug:print 0 "ERROR: failed to find megatest.config, exiting")
- (exit))))
- (push-directory *toppath*) ;; This is probably NOT needed
- (debug:print-info 11 "*transport-type* is " *transport-type* ", *runremote* is " *runremote*)
- (let* ((hostinfo (open-run-close tasks:get-best-server tasks:open-db)))
- (debug:print-info 11 "CLIENT SETUP, hostinfo=" hostinfo)
- (set! *transport-type* (if hostinfo
- (string->symbol (tasks:hostinfo-get-transport hostinfo))
- 'fs))
- (debug:print-info 11 "Using transport type of " *transport-type* (if hostinfo (conc " to connect to " hostinfo) ""))
- (case *transport-type*
- ((fs)(if (not *megatest-db*)(set! *megatest-db* (open-db))))
- ((http)
- (http-transport:client-connect (tasks:hostinfo-get-interface hostinfo)
- (tasks:hostinfo-get-port hostinfo)))
- ((zmq)
- (zmq-transport:client-connect (tasks:hostinfo-get-interface hostinfo)
- (tasks:hostinfo-get-port hostinfo)
- (tasks:hostinfo-get-pubport hostinfo)))
- (else ;; default to fs
- (debug:print 0 "ERROR: unrecognised transport type " *transport-type* " attempting to continue with fs")
- (set! *transport-type* 'fs)
- (set! *megatest-db* (open-db))))
- (pop-directory)))
+;;
+;; lookup_server, need to remove *runremote* stuff
+;;
+(define (client:setup run-id #!key (remaining-tries 10) (failed-connects 0))
+ (debug:print-info 0 "client:setup remaining-tries=" remaining-tries)
+ (if (<= remaining-tries 0)
+ (begin
+ (debug:print 0 "ERROR: failed to start or connect to server for run-id " run-id)
+ (exit 1))
+ (let ((host-info (hash-table-ref/default *runremote* run-id #f)))
+ (if host-info
+ (let* ((iface (http-transport:server-dat-get-iface host-info))
+ (port (http-transport:server-dat-get-port host-info))
+ (start-res (http-transport:client-connect iface port))
+ (ping-res (rmt:login-no-auto-client-setup start-res run-id)))
+ (if ping-res ;; sucessful login?
+ (begin
+ (debug:print-info 0 "client:setup, ping is good using host-info=" host-info ", remaining-tries=" remaining-tries)
+ ;; Why add the close-connections here?
+ ;; (http-transport:close-connections run-id)
+ (hash-table-set! *runremote* run-id start-res)
+ start-res) ;; return the server info
+ ;; have host info but no ping. shutdown the current connection and try again
+ (begin ;; login failed
+ (debug:print-info 0 "client:setup, ping is bad for start-res=" start-res " and *runremote*=" host-info)
+ (http-transport:close-connections run-id)
+ (hash-table-delete! *runremote* run-id)
+ (if (< remaining-tries 8)
+ (thread-sleep! 5)
+ (thread-sleep! 1))
+ (client:setup run-id remaining-tries: (- remaining-tries 1)))))
+ ;; YUK: rename server-dat here
+ (let* ((server-dat (open-run-close tasks:get-server tasks:open-db run-id)))
+ (debug:print-info 0 "client:setup server-dat=" server-dat ", remaining-tries=" remaining-tries)
+ (if server-dat
+ (let* ((iface (tasks:hostinfo-get-interface server-dat))
+ (port (tasks:hostinfo-get-port server-dat))
+ (start-res (http-transport:client-connect iface port))
+ (ping-res (rmt:login-no-auto-client-setup start-res run-id)))
+ (if (and start-res
+ ping-res)
+ (begin
+ (hash-table-set! *runremote* run-id start-res)
+ (debug:print-info 0 "connected to " (http-transport:server-dat-make-url start-res))
+ start-res)
+ (begin ;; login failed but have a server record, clean out the record and try again
+ (debug:print-info 0 "client:setup, login failed, will attempt to start server ... start-res=" start-res ", run-id=" run-id ", server-dat=" server-dat)
+ (http-transport:close-connections run-id)
+ (hash-table-delete! *runremote* run-id)
+ (open-run-close tasks:server-force-clean-run-record
+ tasks:open-db
+ run-id
+ (tasks:hostinfo-get-interface server-dat)
+ (tasks:hostinfo-get-port server-dat)
+ " client:setup (server-dat = #t)")
+ (thread-sleep! 2)
+ (server:try-running run-id)
+ (thread-sleep! 10) ;; give server a little time to start up
+ (client:setup run-id remaining-tries: (- remaining-tries 1)))))
+ (begin ;; no server registered
+ (let ((num-available (open-run-close tasks:num-in-available-state tasks:open-db run-id)))
+ (debug:print-info 0 "client:setup, no server registered, remaining-tries=" remaining-tries " num-available=" num-available)
+ (thread-sleep! 2)
+ (if (< num-available 2)
+ (begin
+ ;; (open-run-close tasks:server-clean-out-old-records-for-run-id tasks:open-db run-id " client:setup (server-dat=#f)")
+ (server:try-running run-id)))
+ (thread-sleep! 10) ;; give server a little time to start up
+ (client:setup run-id remaining-tries: (- remaining-tries 1))))))))))
+
+;; keep this as a function to ease future
+(define (client:start run-id server-info)
+ (http-transport:client-connect (tasks:hostinfo-get-interface server-info)
+ (tasks:hostinfo-get-port server-info)))
;; client:signal-handler
(define (client:signal-handler signum)
(handle-exceptions
exn
@@ -102,13 +144,16 @@
(thread-start! th2)
(thread-start! th1)
(thread-join! th2))))
;; client:launch
-(define (client:launch)
+;; Need to set the signal handler somewhere other than here as this
+;; routine will go away.
+;;
+(define (client:launch run-id)
(set-signal-handler! signal/int client:signal-handler)
- (if (client:setup)
- (debug:print-info 2 "connected as client")
- (begin
- (debug:print 0 "ERROR: Failed to connect as client")
- (exit))))
+ (if (client:setup run-id)
+ (debug:print-info 2 "connected as client")
+ (begin
+ (debug:print 0 "ERROR: Failed to connect as client")
+ (exit))))
Index: common.scm
==================================================================
--- common.scm
+++ common.scm
@@ -23,15 +23,22 @@
;; (require-library margs)
;; (include "margs.scm")
(define getenv get-environment-variable)
+(define (safe-setenv key val)
+ (if (and (string? val)(string? key))
+ (handle-exceptions
+ exn
+ (debug:print 0 "ERROR: bad value for setenv, key=" key ", value=" val)
+ (setenv key val))
+ (debug:print 0 "ERROR: bad value for setenv, key=" key ", value=" val)))
(define home (getenv "HOME"))
(define user (getenv "USER"))
-;; global gletches
+;; GLOBAL GLETCHES
(define *db-keys* #f)
(define *configinfo* #f)
(define *configdat* #f)
(define *toppath* #f)
(define *already-seen-runconfig-info* #f)
@@ -38,16 +45,19 @@
(define *waiting-queue* (make-hash-table))
(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
+;; DATABASE
+(define *open-dbs* (vector #f (make-hash-table))) ;; megatestdb run-id-dbs
+
;; SERVER
(define *my-client-signature* #f)
-(define *transport-type* 'fs)
+(define *transport-type* 'http)
(define *megatest-db* #f)
(define *rpc:listener* #f) ;; if set up for server communication this will hold the tcp port
-(define *runremote* #f) ;; if set up for server communication this will hold <host port>
+(define *runremote* (make-hash-table)) ;; if set up for server communication this will hold <host port>
(define *last-db-access* (current-seconds)) ;; update when db is accessed via server
(define *max-cache-size* 0)
(define *logged-in-clients* (make-hash-table))
(define *client-non-blocking-mode* #f)
(define *server-id* #f)
@@ -55,11 +65,13 @@
(define *time-to-exit* #f)
(define *received-response* #f)
(define *default-numtries* 10)
(define *server-run* #t)
(define *db-write-access* #t)
-
+(define *inmemdb* #f)
+(define *run-id* #f)
+(define *server-kind-run* (make-hash-table))
(define *target* (make-hash-table)) ;; cache the target here; target is keyval1/keyval2/.../keyvalN
(define *keys* (make-hash-table)) ;; cache the keys here
(define *keyvals* (make-hash-table))
(define *toptest-paths* (make-hash-table)) ;; cache toptest path settings here
@@ -91,19 +103,46 @@
(set! *test-info* (make-hash-table))
(set! *run-info-cache* (make-hash-table))
(set! *env-vars-by-run-id* (make-hash-table))
(set! *test-id-cache* (make-hash-table)))
+;; Generic string database (normalization of sorts)
+(define sdb:qry #f) ;; (make-sdb:qry)) ;; 'init #f)
+;; Generic path database (normalization of sorts)
+(define *fdb* #f)
+
+;;======================================================================
+;; U S E F U L S T U F F
+;;======================================================================
+
+(define (common:get-megatest-exe)
+ (if (getenv "MT_MEGATEST") (getenv "MT_MEGATEST") "megatest"))
+
;;======================================================================
;; S T A T E S A N D S T A T U S E S
;;======================================================================
(define *common:std-states*
- (list "COMPLETED" "NOT_STARTED" "RUNNING" "REMOTEHOSTSTART" "LAUNCHED" "KILLED" "KILLREQ" "STUCK"))
+ '((0 "COMPLETED")
+ (1 "NOT_STARTED")
+ (2 "RUNNING")
+ (3 "REMOTEHOSTSTART")
+ (4 "LAUNCHED")
+ (5 "KILLED")
+ (6 "KILLREQ")
+ (7 "STUCK")))
(define *common:std-statuses*
- (list "PASS" "WARN" "FAIL" "CHECK" "n/a" "WAIVED" "SKIP" "DELETED" "STUCK/DEAD"))
+ '((0 "PASS")
+ (1 "WARN")
+ (2 "FAIL")
+ (3 "CHECK")
+ (4 "n/a")
+ (5 "WAIVED")
+ (6 "SKIP")
+ (7 "DELETED")
+ (8 "STUCK/DEAD")))
;; These are stopping conditions that prevent a test from being run
(define *common:cant-run-states-sym*
'(COMPLETED KILLED WAIVED UNKNOWN INCOMPLETE))
Index: common_records.scm
==================================================================
--- common_records.scm
+++ common_records.scm
@@ -15,15 +15,15 @@
(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
+ (cond
((> (length debugvals) 1) debugvals)
((> (length debugvals) 0)(car debugvals))
(else 1))))
- ((args:get-arg "-v") 2)
+ ((args:get-arg "-v") 2)
((args:get-arg "-q") 0)
(else 1)))
;; check verbosity, #t is ok
(define (debug:check-verbosity verbosity vstr)
@@ -58,10 +58,11 @@
(if (debug:debug-mode n)
(with-output-to-port (current-error-port)
(lambda ()
(if *logging*
(db:log-event (apply conc params))
+ ;; (apply print "pid:" (current-process-id) " " params)
(apply print params)
)))))
(define (debug:print-info n . params)
(if (debug:debug-mode n)
@@ -68,13 +69,14 @@
(with-output-to-port (current-error-port)
(lambda ()
(let ((res (format#format #f "INFO: (~2d) ~a" n (apply conc params))))
(if *logging*
(db:log-event res)
+ ;; (apply print "pid:" (current-process-id) " " "INFO: (" n ") " params) ;; res)
(apply print "INFO: (" n ") " params) ;; res)
))))))
;; if a value is printable (i.e. string or number) return the value
;; else return an empty string
(define-inline (printable val)
(if (or (number? val)(string? val)) val ""))
Index: configf.scm
==================================================================
--- configf.scm
+++ configf.scm
@@ -204,11 +204,11 @@
(if (null? res)
""
(string-intersperse res " "))))))
(hash-table-set! res curr-section-name
(config:assoc-safe-add alist
- key
+ key
(case allow-system
((return-procs) val-proc)
((return-string) cmd)
(else (val-proc)))))
(loop (configf:read-line inp res allow-system) curr-section-name #f #f))
@@ -217,14 +217,11 @@
(envar (and environ-patt (string-search (regexp environ-patt) curr-section-name)))
(realval (if envar
(config:eval-string-in-environment val)
val)))
(debug:print-info 6 "read-config env setting, envar: " envar " realval: " realval " val: " val " key: " key " curr-section-name: " curr-section-name)
- (if envar
- (begin
- ;; (debug:print-info 4 "read-config key=" key ", val=" val ", realval=" realval)
- (setenv key realval)))
+ (if envar (safe-setenv key realval))
(hash-table-set! res curr-section-name
(config:assoc-safe-add alist key realval))
(loop (configf:read-line inp res allow-system) curr-section-name key #f)))
(configf:key-no-val ( x key val) (let* ((alist (hash-table-ref/default res curr-section-name '())))
(hash-table-set! res curr-section-name
Index: dashboard-tests.scm
==================================================================
--- dashboard-tests.scm
+++ dashboard-tests.scm
@@ -24,11 +24,14 @@
(declare (unit dashboard-tests))
(declare (uses common))
(declare (uses db))
(declare (uses gutils))
+(declare (uses rmt))
(declare (uses ezsteps))
+;; (declare (uses sdb))
+;; (declare (uses filedb))
(include "common_records.scm")
(include "db_records.scm")
(include "run_records.scm")
@@ -139,15 +142,15 @@
;;======================================================================
;; Run info panel
;;======================================================================
-(define (run-info-panel keydat testdat runname)
+(define (run-info-panel db keydat testdat runname)
(let* ((run-id (db:test-get-run_id testdat))
- (rundat (cdb:remote-run db:get-run-info #f run-id))
+ (rundat (db:get-run-info db run-id))
(header (db:get-header rundat))
- (event_time (db:get-value-by-header (db:get-row rundat)
+ (event_time (db:get-value-by-header (db:get-rows rundat)
(db:get-header rundat)
"event_time")))
(iup:frame
#:title "Megatest Run Info" ; #:expand "YES"
(iup:hbox ; #:expand "YES"
@@ -187,15 +190,18 @@
(iup:label "" #:expand "VERTICAL")))
(apply iup:vbox ; #:expand "YES"
(list
;; NOTE: Yes, the host can change!
(store-label "HostName"
- (iup:label (db:test-get-host testdat) #:expand "HORIZONTAL")
+ (iup:label ;; (sdb:qry 'getstr
+ (db:test-get-host testdat) ;; )
+ #:expand "HORIZONTAL")
(lambda (testdat)(db:test-get-host testdat)))
(store-label "Uname"
(iup:label " " #:expand "HORIZONTAL")
- (lambda (testdat)(db:test-get-uname testdat)))
+ (lambda (testdat) ;; (sdb:qry 'getstr
+ (db:test-get-uname testdat))) ;; )
(store-label "DiskFree"
(iup:label (conc (db:test-get-diskfree testdat)) #:expand "HORIZONTAL")
(lambda (testdat)(conc (db:test-get-diskfree testdat))))
(store-label "CPULoad"
(iup:label (conc (db:test-get-cpuload testdat)) #:expand "HORIZONTAL")
@@ -221,22 +227,23 @@
(define *dashboard-comment-share-slot* #f)
;;======================================================================
;; Set fields
;;======================================================================
-(define (set-fields-panel test-id testdat #!key (db #f))
+(define (set-fields-panel dbstruct run-id test-id testdat #!key (db #f))
(let ((newcomment #f)
(newstatus #f)
(newstate #f)
(wtxtbox #f))
(iup:frame
#:title "Set fields"
(iup:vbox
(iup:hbox (iup:label "Comment:")
(let ((txtbox (iup:textbox #:action (lambda (val a b)
+ (rmt:test-set-state-status-by-id run-id test-id #f #f b)
;; IDEA: Just set a variable with the proc to call?
- (open-run-close db:test-set-state-status-by-id db test-id #f #f b)
+ (rmt:test-set-state-status-by-id run-id test-id #f #f b)
(set! newcomment b))
#:value (db:test-get-comment testdat)
#:expand "HORIZONTAL")))
(set! wtxtbox txtbox)
txtbox))
@@ -245,14 +252,14 @@
(iup:label "STATE:" #:size "30x")
(let* ((btns (map (lambda (state)
(let ((btn (iup:button state
#:expand "HORIZONTAL" #:size "50x" #:font "Courier New, -10"
#:action (lambda (x)
- (open-run-close db:test-set-state-status-by-id db test-id state #f #f)
+ (rmt:test-set-state-status-by-id run-id test-id state #f #f)
(db:test-set-state! testdat state)))))
btn))
- *common:std-states*))) ;; (list "COMPLETED" "NOT_STARTED" "RUNNING" "REMOTEHOSTSTART" "LAUNCHED" "KILLED" "KILLREQ"))))
+ (map cadr *common:std-states*)))) ;; (list "COMPLETED" "NOT_STARTED" "RUNNING" "REMOTEHOSTSTART" "LAUNCHED" "KILLED" "KILLREQ"))))
(vector-set! *state-status* 0
(lambda (state color)
(for-each
(lambda (btn)
(let* ((name (iup:attribute btn "TITLE"))
@@ -278,14 +285,14 @@
(iup:attribute-set! wtxtbox "VALUE" c)
(if (not *dashboard-comment-share-slot*)
(set! *dashboard-comment-share-slot* wtxtbox)))
))))
(begin
- (open-run-close db:test-set-state-status-by-id db test-id #f status #f)
+ (rmt:test-set-state-status-by-id run-id test-id #f status #f)
(db:test-set-status! testdat status))))))))
btn))
- *common:std-statuses*))) ;; (list "PASS" "WARN" "FAIL" "CHECK" "n/a" "WAIVED" "SKIP"))))
+ (map cadr *common:std-statuses*)))) ;; (list "PASS" "WARN" "FAIL" "CHECK" "n/a" "WAIVED" "SKIP"))))
(vector-set! *state-status* 1
(lambda (status color)
(for-each
(lambda (btn)
(let* ((name (iup:attribute btn "TITLE"))
@@ -359,50 +366,140 @@
(let ((comment (iup:attribute comnt "VALUE"))
(test-id (db:test-get-id testdat)))
(if (or (not wpatt)
(string-match wregx comment))
(begin
- (open-run-close db:test-set-state-status-by-id #f test-id #f "WAIVED" comment)
+ (rmt:test-set-state-status-by-id run-id test-id #f "WAIVED" comment)
(db:test-set-status! testdat "WAIVED")
(cmtcmd comment)
(iup:destroy! dlog))))))
(iup:button "Cancel"
#:expand "HORIZONTAL"
#:action (lambda (obj)
(iup:destroy! dlog)))))))
dlog))
+
+;; CHECK - WAS THIS ADDED OR REMOVED? MANUAL MERGE WITH API STUFF!!!
+;;
+;; get a pretty table to summarize steps
+;;
+(define (dashboard-tests:process-steps-table steps);; db test-id #!key (work-area #f))
+;; (let ((steps (db:get-steps-for-test db test-id work-area: work-area)))
+ ;; organise the steps for better readability
+ (let ((res (make-hash-table)))
+ (for-each
+ (lambda (step)
+ (debug:print 6 "step=" step)
+ (let ((record (hash-table-ref/default
+ res
+ (tdb:step-get-stepname step)
+ ;; stepname start end status Duration Logfile
+ (vector (tdb:step-get-stepname step) "" "" "" "" ""))))
+ (debug:print 6 "record(before) = " record
+ "\nid: " (tdb:step-get-id step)
+ "\nstepname: " (tdb:step-get-stepname step)
+ "\nstate: " (tdb:step-get-state step)
+ "\nstatus: " (tdb:step-get-status step)
+ "\ntime: " (tdb:step-get-event_time step))
+ (case (string->symbol (tdb:step-get-state step))
+ ((start)(vector-set! record 1 (tdb:step-get-event_time step))
+ (vector-set! record 3 (if (equal? (vector-ref record 3) "")
+ (tdb:step-get-status step)))
+ (if (> (string-length (tdb:step-get-logfile step))
+ 0)
+ (vector-set! record 5 (tdb:step-get-logfile step))))
+ ((end)
+ (vector-set! record 2 (any->number (tdb:step-get-event_time step)))
+ (vector-set! record 3 (tdb:step-get-status step))
+ (vector-set! record 4 (let ((startt (any->number (vector-ref record 1)))
+ (endt (any->number (vector-ref record 2))))
+ (debug:print 4 "record[1]=" (vector-ref record 1)
+ ", startt=" startt ", endt=" endt
+ ", get-status: " (tdb:step-get-status step))
+ (if (and (number? startt)(number? endt))
+ (seconds->hr-min-sec (- endt startt)) "-1")))
+ (if (> (string-length (tdb:step-get-logfile step))
+ 0)
+ (vector-set! record 5 (tdb:step-get-logfile step))))
+ (else
+ (vector-set! record 2 (tdb:step-get-state step))
+ (vector-set! record 3 (tdb:step-get-status step))
+ (vector-set! record 4 (tdb:step-get-event_time step))))
+ (hash-table-set! res (tdb:step-get-stepname step) record)
+ (debug:print 6 "record(after) = " record
+ "\nid: " (tdb:step-get-id step)
+ "\nstepname: " (tdb:step-get-stepname step)
+ "\nstate: " (tdb:step-get-state step)
+ "\nstatus: " (tdb:step-get-status step)
+ "\ntime: " (tdb:step-get-event_time step))))
+ ;; (else (vector-set! record 1 (tdb:step-get-event_time step)))
+ (sort steps (lambda (a b)
+ (cond
+ ((< (tdb:step-get-event_time a)(tdb:step-get-event_time b)) #t)
+ ((eq? (tdb:step-get-event_time a)(tdb:step-get-event_time b))
+ (< (tdb:step-get-id a) (tdb:step-get-id b)))
+ (else #f)))))
+ res))
+
+(define (dashboard-tests:get-compressed-steps dbstruct run-id test-id)
+ (let* ((steps-data (db:get-steps-for-test dbstruct run-id test-id))
+ (comprsteps (dashboard-tests:process-steps-table steps-data))) ;; (open-run-close db:get-steps-table #f test-id work-area: work-area)))
+ (map (lambda (x)
+ ;; take advantage of the \n on time->string
+ (vector
+ (vector-ref x 0)
+ (let ((s (vector-ref x 1)))
+ (if (number? s)(seconds->time-string s) s))
+ (let ((s (vector-ref x 2)))
+ (if (number? s)(seconds->time-string s) s))
+ (vector-ref x 3) ;; status
+ (vector-ref x 4)
+ (vector-ref x 5))) ;; time delta
+ (sort (hash-table-values comprsteps)
+ (lambda (a b)
+ (let ((time-a (vector-ref a 1))
+ (time-b (vector-ref b 1)))
+ (if (and (number? time-a)(number? time-b))
+ (if (< time-a time-b)
+ #t
+ (if (eq? time-a time-b)
+ (string<? (conc (vector-ref a 2))
+ (conc (vector-ref b 2)))
+ #f))
+ (string<? (conc time-a)(conc time-b)))))))))
;;======================================================================
;;
;;======================================================================
-(define (examine-test test-id) ;; run-id run-key origtest)
- (let* ((db-path (conc *toppath* "/megatest.db"))
- (db (open-db))
- (testdat (open-run-close db:get-test-info-by-id db test-id))
+(define (examine-test run-id test-id) ;; run-id run-key origtest)
+ (let* ((db-path (db:dbfile-path run-id)) ;; (conc (configf:lookup *configdat* "setup" "linktree") "/db/" run-id ".db"))
+ (dbstruct (make-dbr:dbstruct path: (configf:lookup *configdat* "setup" "linktree") local: #t))
+ (testdat (db:get-test-info-by-id dbstruct run-id test-id))
(db-mod-time 0) ;; (file-modification-time db-path))
(last-update 0) ;; (current-seconds))
(request-update #t))
(if (not testdat)
(begin
(debug:print 2 "ERROR: No test data found for test " test-id ", exiting")
(exit 1))
- (let* ((run-id (if testdat (db:test-get-run_id testdat) #f))
- (keydat (if testdat (open-run-close db:get-key-val-pairs db run-id) #f))
- (rundat (if testdat (open-run-close db:get-run-info db run-id) #f))
- (runname (if testdat (db:get-value-by-header (db:get-row rundat)
+ (let* (;; (run-id (if testdat (db:test-get-run_id testdat) #f))
+ (keydat (if testdat (db:get-key-val-pairs dbstruct run-id) #f))
+ (rundat (if testdat (db:get-run-info dbstruct run-id) #f))
+ (runname (if testdat (db:get-value-by-header (db:get-rows rundat)
(db:get-header rundat)
"runname") #f))
+ (tdb (tdb:open-test-db-by-test-id-local dbstruct run-id test-id))
;; These next two are intentional bad values to ensure errors if they should not
;; get filled in properly.
(logfile "/this/dir/better/not/exist")
(rundir logfile)
(testdat-path (conc rundir "/testdat.db")) ;; this gets recalculated until found
- (teststeps (if testdat (db:get-compressed-steps test-id work-area: rundir) '()))
+ (teststeps (if testdat (dashboard-tests:get-compressed-steps dbstruct run-id test-id) '()))
(testfullname (if testdat (db:test-get-fullname testdat) "Gathering data ..."))
(testname (if testdat (db:test-get-testname testdat) "n/a"))
(testmeta (if testdat
- (let ((tm (open-run-close db:testmeta-get-record db testname)))
+ (let ((tm (db:testmeta-get-record dbstruct testname)))
(if tm tm (make-db:testmeta)))
(make-db:testmeta)))
(keystring (string-intersperse
(map (lambda (keyval)
@@ -437,44 +534,28 @@
(if (file-exists? testdat-path)
(file-modification-time testdat-path)
(begin
(set! testdat-path (conc rundir "/testdat.db"))
0))))
- (need-update (or (and (> curr-mod-time db-mod-time)
+ (need-update (or (and (>= curr-mod-time db-mod-time)
(> (current-milliseconds)(+ last-update 250))) ;; every half seconds if db touched
(> (current-milliseconds)(+ last-update 10000)) ;; force update even 10 seconds
request-update))
(newtestdat (if need-update
;; NOTE: BUG HIDER, try to eliminate this exception handler
(handle-exceptions
exn
- (debug:print-info 0 "WARNING: test db access issue for test " test-id ": " ((condition-property-accessor 'exn 'message) exn))
- (make-db:test)
- (let* ((newdat (open-run-close db:get-test-info-by-id db test-id ))
- (tstdat (if newdat
- (open-run-close tests:testdat-get-testinfo db test-id #f)
- '())))
- (if (and newdat
- (not (null? tstdat))) ;; (update-time cpuload diskfree run-duration)
- (let* ((rec (car tstdat))
- (cpuload (vector-ref rec 1))
- (diskfree (vector-ref rec 2))
- (run-dur (vector-ref rec 3)))
- (db:test-set-run_duration! newdat run-dur)
- (db:test-set-diskfree! newdat diskfree)
- (db:test-set-cpuload! newdat cpuload)))
- ;; (debug:print 0 "newdat=" newdat)
- newdat)
- )
- #f)))
- ;; (debug:print 0 "newtestdat=" newtestdat)
+ (debug:print-info 0 "test db access issue: " ((condition-property-accessor 'exn 'message) exn))
+ (db:get-test-info-by-id dbstruct run-id test-id )))))
+ ;; (debug:print-info 0 "need-update= " need-update " curr-mod-time = " curr-mod-time)
(cond
((and need-update newtestdat)
(set! testdat newtestdat)
- (set! teststeps (db:get-compressed-steps test-id work-area: rundir))
+ (set! teststeps (dashboard-tests:get-compressed-steps dbstruct run-id test-id))
(set! logfile (conc (db:test-get-rundir testdat) "/" (db:test-get-final_logf testdat)))
- (set! rundir (db:test-get-rundir testdat))
+ (set! rundir ;; (filedb:get-path *fdb*
+ (db:test-get-rundir testdat)) ;; )
(set! testfullname (db:test-get-fullname testdat))
;; (debug:print 0 "INFO: teststeps=" (intersperse teststeps "\n "))
;; I don't see why this was implemented this way. Please comment it ...
;; (if (eq? curr-mod-time db-mod-time) ;; do only once if same
@@ -583,11 +664,11 @@
(iup:dialog #:close_cb (lambda (a)(exit)) ; #:expand "YES"
#:title testfullname
(iup:vbox ; #:expand "YES"
;; The run and test info
(iup:hbox ; #:expand "YES"
- (run-info-panel keydat testdat runname)
+ (run-info-panel dbstruct keydat testdat runname)
(test-info-panel testdat store-label widgets)
(test-meta-panel testmeta store-meta))
(host-info-panel testdat store-label)
;; The controls
(iup:frame #:title "Actions"
@@ -601,11 +682,11 @@
(iup:button "Kill All Jobs" #:action kill-jobs #:size "80x")
(iup:button "Close" #:action (lambda (x)(exit)) #:size "80x"))
(apply
iup:hbox
(list command-text-box command-launch-button))))
- (set-fields-panel test-id testdat)
+ (set-fields-panel dbstruct run-id test-id testdat)
(let ((tabs
(iup:tabs
;; Replace here with matrix
(let ((steps-matrix (iup:matrix
#:font "Courier New, -8"
@@ -709,11 +790,11 @@
(db:test-data-get-tol x)
(db:test-data-get-status x)
(db:test-data-get-units x)
(db:test-data-get-type x)
(db:test-data-get-comment x)))
- (open-run-close db:read-test-data db test-id "%")))
+ (tdb:open-run-close-db-by-test-id-local dbstruct run-id test-id #f tdb:read-test-data test-id "%")))
"\n")))
(if (not (equal? currval newval))
(iup:attribute-set! test-data "VALUE" newval ))))) ;; "TITLE" newval)))))
test-data))
;;(dashboard:run-controls)
Index: dashboard.scm
==================================================================
--- dashboard.scm
+++ dashboard.scm
@@ -39,21 +39,22 @@
(declare (uses mt))
(include "common_records.scm")
(include "db_records.scm")
(include "run_records.scm")
+(include "megatest-fossil-hash.scm")
(define help (conc
"Megatest Dashboard, documentation at http://www.kiatoa.com/fossils/megatest
version " megatest-version "
- license GPL, Copyright (C) Matt Welland 2013
+ license GPL, Copyright (C) Matt Welland 2012-2014
Usage: dashboard [options]
- -h : this help
- -server host:port : connect to host:port instead of db access
- -test testid : control test identified by testid
- -guimonitor : control panel for runs
+ -h : this help
+ -server host:port : connect to host:port instead of db access
+ -test run-id,test-id : control test identified by testid
+ -guimonitor : control panel for runs
Misc
-rows N : set number of rows
"))
@@ -63,10 +64,11 @@
(list "-rows"
"-run"
"-test"
"-debug"
"-host"
+ "-transport"
)
(list "-h"
"-use-server"
"-guimonitor"
"-main"
@@ -84,30 +86,22 @@
(if (not (setup-for-run))
(begin
(print "Failed to find megatest.config, exiting")
(exit 1)))
-(define *db* #f) ;; (open-db))
-
-(if (args:get-arg "-host")
- (begin
- (set! *runremote* (string-split (args:get-arg "-host" ":")))
- (client:launch))
- (if (not (args:get-arg "-use-server"))
- (set! *transport-type* 'fs) ;; force fs access
- (client:launch)))
+(define *dbdir* (conc (configf:lookup *configdat* "setup" "linktree") "/.db"))
+(define *dbstruct-local* (make-dbr:dbstruct path: *dbdir*
+ local: #t))
+(define *db-file-path* (db:dbfile-path 0))
;; HACK ALERT: this is a hack, please fix.
-(define *read-only* (not (file-read-access? (conc *toppath* "/megatest.db"))))
-;; (client:setup *db*)
+(define *read-only* (not (file-read-access? *db-file-path*)))
(define toplevel #f)
(define dlg #f)
(define max-test-num 0)
-;; (define *keys* (open-run-close db:get-keys #f))
-(define *keys* (cdb:remote-run db:get-keys #f))
-;; (define *keys* (db:get-keys *db*))
+(define *keys* (db:get-keys *dbstruct-local*))
(define *dbkeys* (append *keys* (list "runname")))
(define *header* #f)
(define *allruns* '())
@@ -116,12 +110,12 @@
(define *buttondat* (make-hash-table)) ;; <run-id color text test run-key>
(define *alltestnamelst* '())
(define *searchpatts* (make-hash-table))
(define *num-runs* 8)
-(define *tot-run-count* (cdb:remote-run db:get-num-runs #f "%"))
-;; (define *tot-run-count* (db:get-num-runs *db* "%"))
+(define *tot-run-count* (db:get-num-runs *dbstruct-local* "%"))
+;; (define *tot-run-count* (db:get-num-runs *dbstruct-local* "%"))
;; Update management
;;
(define *last-update* (current-seconds))
(define *last-db-update-time* 0)
@@ -137,12 +131,10 @@
(define *examine-test-dat* (make-hash-table))
(define *exit-started* #f)
(define *status-ignore-hash* (make-hash-table))
(define *state-ignore-hash* (make-hash-table))
-(define *db-file-path* (conc *toppath* "/megatest.db"))
-
(define *tests-sort-options* (vector (vector "Sort +a" 'testname "ASC")
(vector "Sort -a" 'testname "DESC")
(vector "Sort +t" 'event_time "ASC")
(vector "Sort -t" 'event_time "DESC")
(vector "Sort +s" 'statestatus "ASC")
@@ -203,11 +195,11 @@
(null? (filter (lambda (x)(> x 3)) delta))))
;; keypatts: ( (KEY1 "abc%def")(KEY2 "%") )
(define (update-rundat runnamepatt numruns testnamepatt keypatts)
(let* ((referenced-run-ids '())
- (allruns (cdb:remote-run db:get-runs #f runnamepatt numruns ;; (+ numruns 1) ;; (/ numruns 2))
+ (allruns (db:get-runs *dbstruct-local* runnamepatt numruns ;; (+ numruns 1) ;; (/ numruns 2))
*start-run-offset* keypatts))
(header (db:get-header allruns))
(runs (db:get-rows allruns))
(result '())
(maxtests 0)
@@ -222,18 +214,19 @@
;;
;; trim runs to only those that are changing often here
;;
(for-each (lambda (run)
(let* ((run-id (db:get-value-by-header run header "id"))
- (tests (mt:get-tests-for-run run-id testnamepatt states statuses
- not-in: *hide-not-hide*
- sort-by: sort-by
- sort-order: sort-order
- qryvals: 'shortlist))
+ (tests (db:get-tests-for-run *dbstruct-local* run-id testnamepatt states statuses
+ #f #f
+ *hide-not-hide*
+ sort-by
+ sort-order
+ 'shortlist))
;; NOTE: bubble-up also sets the global *all-item-test-names*
;; (tests (bubble-up tmptests priority: bubble-type))
- (key-vals (cdb:remote-run db:get-key-vals #f run-id)))
+ (key-vals (db:get-key-vals *dbstruct-local* run-id)))
;; NOTE: 11/01/2013 This routine is *NOT* getting called excessively.
;; (debug:print 0 "Getting data for run " run-id " with key-vals=" key-vals)
;; Not sure this is needed?
(set! referenced-run-ids (cons run-id referenced-run-ids))
(if (> (length tests) maxtests)
@@ -556,11 +549,11 @@
(iup:attribute-set! lb "VALUE" newval)
newval))))))
(define (dashboard:update-target-selector key-lbs #!key (action-proc #f))
(let* ((runconf-targs (common:get-runconfig-targets))
- (db-target-dat (open-run-close db:get-targets #f))
+ (db-target-dat (db:get-targets *dbstruct-local*))
(header (vector-ref db-target-dat 0))
(db-targets (vector-ref db-target-dat 1))
(all-targets (append db-targets
(map (lambda (x)
(list->vector
@@ -821,11 +814,11 @@
(iup:attribute-set! tb "VALUE" val)
(dboard:data-set-run-name! *data* val)
(dashboard:update-run-command))))
(refresh-runs-list (lambda ()
(let* ((target (dboard:data-get-target-string *data*))
- (runs-for-targ (mt:get-runs-by-patt *keys* "%" target))
+ (runs-for-targ (db:get-runs-by-patt *dbstruct-local* *keys* "%" target #f #f))
(runs-header (vector-ref runs-for-targ 0))
(runs-dat (vector-ref runs-for-targ 1))
(run-names (cons default-run-name
(map (lambda (x)
(db:get-value-by-header x runs-header "runname"))
@@ -870,19 +863,19 @@
;; Text box for STATES
(iup:frame
#:title "States"
(dashboard:text-list-toggle-box
;; Move these definitions to common and find the other useages and replace!
- *common:std-states* ;; '("COMPLETED" "RUNNING" "STUCK" "INCOMPLETE" "LAUNCHED" "REMOTEHOSTSTART" "KILLED")
+ (map cadr *common:std-states*) ;; '("COMPLETED" "RUNNING" "STUCK" "INCOMPLETE" "LAUNCHED" "REMOTEHOSTSTART" "KILLED")
(lambda (all)
(dboard:data-set-states! *data* all)
(dashboard:update-run-command))))
;; Text box for STATES
(iup:frame
#:title "Statuses"
(dashboard:text-list-toggle-box
- *common:std-statuses* ;; '("PASS" "FAIL" "n/a" "CHECK" "WAIVED" "SKIP" "DELETED" "STUCK/DEAD")
+ (map cadr *common:std-statuses*) ;; '("PASS" "FAIL" "n/a" "CHECK" "WAIVED" "SKIP" "DELETED" "STUCK/DEAD")
(lambda (all)
(dboard:data-set-statuses! *data* all)
(dashboard:update-run-command))))))))
(iup:frame
@@ -981,21 +974,25 @@
;;======================================================================
;; S U M M A R Y
;;======================================================================
;;
;; General info about the run(s) and megatest area
-(define (dashboard:summary)
+(define (dashboard:summary db)
(let ((rawconfig (read-config (conc *toppath* "/megatest.config") #f 'return-string)))
(iup:vbox
(iup:split
- ;; #:value 500
+ #:value 500
(iup:frame
#:title "General Info"
- (iup:hbox
- (dcommon:keys-matrix rawconfig)
- (dcommon:general-info)
- ))
+ (iup:vbox
+ (iup:hbox
+ (iup:label "Area Path")
+ (iup:textbox #:value *toppath* #:expand "HORIZONTAL"))
+ (iup:hbox
+ (dcommon:keys-matrix rawconfig)
+ (dcommon:general-info)
+ )))
(iup:frame
#:title "Server"
(dcommon:servers-table)))
(iup:frame
#:title "Megatest config settings"
@@ -1006,11 +1003,11 @@
;; (iup:frame
;; #:title "Disks Areas"
(dcommon:section-matrix rawconfig "disks" "Disk area" "Path"))))
(iup:frame
#:title "Run statistics"
- (dcommon:run-stats)))))
+ (dcommon:run-stats db)))))
;;======================================================================
;; R U N
;;======================================================================
;;
@@ -1022,11 +1019,11 @@
#f))
(define dashboard:update-run-summary-tab #f)
;; (define (tests window-id)
-(define (dashboard:one-run)
+(define (dashboard:one-run db)
(let* ((tb (iup:treebox
#:value 0
#:name "Runs"
#:expand "YES"
#:addexpanded "NO"
@@ -1042,19 +1039,21 @@
;; (print "path: " (tree:node->path obj id) " run-id: " run-id)
))))
(run-matrix (iup:matrix
#:expand "YES"))
(updater (lambda ()
- (let* ((runs-dat (mt:get-runs-by-patt *keys* "%" #f))
+ (let* ((runs-dat (db:get-runs-by-patt db *keys* "%" #f #f #f))
(runs-header (vector-ref runs-dat 0)) ;; 0 is header, 1 is list of records
(run-id (dboard:data-get-curr-run-id *data*))
- (tests-dat (let ((tdat (mt:get-tests-for-run run-id
+ (tests-dat (let ((tdat (db:get-tests-for-run db run-id
(hash-table-ref/default *searchpatts* "test-name" "%/%")
(hash-table-keys *state-ignore-hash*) ;; '()
(hash-table-keys *status-ignore-hash*) ;; '()
- not-in: *hide-not-hide*
- qryvals: "id,testname,item_path,state,status"))) ;; get 'em all
+ #f #f
+ *hide-not-hide*
+ #f #f
+ "id,testname,item_path,state,status"))) ;; get 'em all
(sort tdat (lambda (a b)
(let* ((aval (vector-ref a 2))
(bval (vector-ref b 2))
(anum (string->number aval))
(bnum (string->number bval)))
@@ -1167,11 +1166,11 @@
;;======================================================================
;; R U N S
;;======================================================================
-(define (make-dashboard-buttons nruns ntests keynames)
+(define (make-dashboard-buttons db nruns ntests keynames)
(let* ((nkeys (length keynames))
(runsvec (make-vector nruns))
(header (make-vector nruns))
(lftcol (make-vector ntests))
(keycol (make-vector ntests))
@@ -1212,11 +1211,11 @@
(iup:attribute-set! obj "TITLE" (if *hide-not-hide* "HideTests" "NotHide"))
(mark-for-update)))))
(set! *hide-not-hide-button* hideit)
hideit))
(iup:hbox
- (iup:button "Quit" #:action (lambda (obj)(if *db* (sqlite3:finalize! *db*))(exit)))
+ (iup:button "Quit" #:action (lambda (obj)(if *dbstruct-local* (db:close-all *dbstruct-local*))(exit)))
(iup:button "Refresh" #:action (lambda (obj)
(mark-for-update)))
(iup:button "Collapse" #:action (lambda (obj)
(let ((myname (iup:attribute obj "TITLE")))
(if (equal? myname "Collapse")
@@ -1241,21 +1240,21 @@
(mark-for-update)
(if (eq? val 1)
(hash-table-set! *status-ignore-hash* status #t)
(hash-table-delete! *status-ignore-hash* status))
(set-bg-on-filter))))
- *common:std-statuses*)) ;; '("PASS" "FAIL" "WARN" "CHECK" "WAIVED" "STUCK/DEAD" "n/a" "SKIP")))
+ (map cadr *common:std-statuses*))) ;; '("PASS" "FAIL" "WARN" "CHECK" "WAIVED" "STUCK/DEAD" "n/a" "SKIP")))
(apply
iup:hbox
(map (lambda (state)
(iup:toggle state #:action (lambda (obj val)
(mark-for-update)
(if (eq? val 1)
(hash-table-set! *state-ignore-hash* state #t)
(hash-table-delete! *state-ignore-hash* state))
(set-bg-on-filter))))
- *common:std-states*)) ;; '("RUNNING" "COMPLETED" "INCOMPLETE" "LAUNCHED" "NOT_STARTED" "KILLED" "DELETED")))
+ (map cadr *common:std-states*))) ;; '("RUNNING" "COMPLETED" "INCOMPLETE" "LAUNCHED" "NOT_STARTED" "KILLED" "DELETED")))
(iup:valuator #:valuechanged_cb (lambda (obj)
(let ((val (inexact->exact (round (/ (string->number (iup:attribute obj "VALUE")) 10))))
(oldmax (string->number (iup:attribute obj "MAX")))
(maxruns *tot-run-count*))
(set! *start-run-offset* val)
@@ -1354,11 +1353,12 @@
#:fontsize "10"
#:action (lambda (x)
(let* ((toolpath (car (argv)))
(buttndat (hash-table-ref *buttondat* button-key))
(test-id (db:test-get-id (vector-ref buttndat 3)))
- (cmd (conc toolpath " -test " test-id "&")))
+ (run-id (db:test-get-run_id (vector-ref buttndat 3)))
+ (cmd (conc toolpath " -test " run-id "," test-id "&")))
;(print "Launching " cmd)
(system cmd))))))
(hash-table-set! *buttondat* button-key (vector 0 "100 100 100" button-key #f #f))
(vector-set! testvec testnum butn)
(loop runnum (+ testnum 1) testvec (cons butn res))))))
@@ -1378,13 +1378,13 @@
controls))
(tabs (iup:tabs
#:tabchangepos-cb (lambda (obj curr prev)
(set! *please-update-buttons* #t)
(set! *current-tab-number* curr))
- (dashboard:summary)
+ (dashboard:summary db)
runs-view
- (dashboard:one-run)
+ (dashboard:one-run db)
(dashboard:run-controls)
)))
;; (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")
@@ -1408,34 +1408,39 @@
(iup:attribute-set! *tim* "TIME" 300)
(iup:attribute-set! *tim* "RUN" "YES")
;; Move this stuff to db.scm? I'm not sure that is the right thing to do...
;;
-(define *last-db-update-time* (file-modification-time (conc *toppath* "/megatest.db")))
+(define *last-db-update-time* (file-modification-time *db-file-path*)) ;; (conc *toppath* "/db/main.db")))
(define *last-recalc-ended-time* 0)
(define (dashboard:been-changed)
- (> (file-modification-time (conc *toppath* "/megatest.db")) *last-db-update-time*))
+ (> (file-modification-time *db-file-path* *last-db-update-time*)))
(define (dashboard:set-db-update-time)
- (set! *last-db-update-time* (file-modification-time (conc *toppath* "/megatest.db"))))
+ (set! *last-db-update-time* (file-modification-time *db-file-path*)))
(define (dashboard:recalc modtime please-update-buttons last-db-update-time)
(or please-update-buttons
(and (> (current-milliseconds)(+ *last-recalc-ended-time* 150))
(> modtime last-db-update-time)
(> (current-seconds)(+ last-db-update-time 1)))))
-(define *monitor-db-path* (conc *toppath* "/monitor.db"))
+(define *monitor-db-path* (conc *dbdir* "/monitor.db"))
(define *last-monitor-update-time* 0)
;; Force creation of the db in case it isn't already there.
(let ((db (tasks:open-db)))
(sqlite3:finalize! db))
+(define (dashboard:get-youngest-run-db-mod-time)
+ (apply max (map (lambda (filen)
+ (file-modification-time filen))
+ (glob (conc *dbdir* "/*.db")))))
+
(define (dashboard:run-update x)
- (let* ((modtime (file-modification-time *db-file-path*))
+ (let* ((modtime (dashboard:get-youngest-run-db-mod-time)) ;; (file-modification-time *db-file-path*))
(monitor-modtime (file-modification-time *monitor-db-path*))
(run-update-time (current-seconds))
(recalc (dashboard:recalc modtime *please-update-buttons* *last-db-update-time*)))
(if (and (eq? *current-tab-number* 0)
(> monitor-modtime *last-monitor-update-time*))
@@ -1483,27 +1488,30 @@
(let ((runid (string->number (args:get-arg "-run"))))
(if runid
(begin
(lambda (x)
(on-exit (lambda ()
- (if *db* (sqlite3:finalize! *db*))))
- (cdb:remote-run examine-run *db* runid)))
+ (if *dbstruct-local* (db:close-all *dbstruct-local*))))
+ (examine-run *dbstruct-local* runid)))
(begin
(print "ERROR: runid is not a number " (args:get-arg "-run"))
(exit 1)))))
- ((args:get-arg "-test")
- (let ((testid (string->number (args:get-arg "-test"))))
- (if (and (number? testid)
- (>= testid 0))
- (examine-test testid)
+ ((args:get-arg "-test") ;; run-id,test-id
+ (let* ((dat (map string->number (string-split (args:get-arg "-test") ",")))
+ (run-id (car dat))
+ (test-id (cadr dat)))
+ (if (and (number? run-id)
+ (number? test-id)
+ (>= test-id 0))
+ (examine-test run-id test-id)
(begin
- (debug:print 3 "INFO: tried to open test with invalid test-id. " (args:get-arg "-test"))
+ (debug:print 3 "INFO: tried to open test with invalid run-id,test-id. " (args:get-arg "-test"))
(exit 1)))))
((args:get-arg "-guimonitor")
- (gui-monitor *db*))
+ (gui-monitor *dbstruct-local*))
(else
- (set! uidat (make-dashboard-buttons *num-runs* *num-tests* *dbkeys*))
+ (set! uidat (make-dashboard-buttons *dbstruct-local* *num-runs* *num-tests* *dbkeys*))
(iup:callback-set! *tim*
"ACTION_CB"
(lambda (x)
(let ((update-is-running #f))
(mutex-lock! *update-mutex*)
@@ -1518,5 +1526,6 @@
(set! *update-is-running* #f)
(mutex-unlock! *update-mutex*))))
1))))
(iup:main-loop)
+(db:close-all *dbstruct-local*)
Index: db.scm
==================================================================
--- db.scm
+++ db.scm
@@ -11,97 +11,456 @@
;;======================================================================
;; Database access
;;======================================================================
-(require-extension (srfi 18) extras tcp) ;; rpc)
-;; (import (prefix rpc rpc:))
-
-(use sqlite3 srfi-1 posix regex regex-case srfi-69 csv-xml s11n md5 message-digest base64)
+(require-extension (srfi 18) extras tcp)
+(use sqlite3 srfi-1 posix regex regex-case srfi-69 csv-xml s11n md5 message-digest base64 format)
(import (prefix sqlite3 sqlite3:))
(import (prefix base64 base64:))
-;; Note, try to remove this dependency
-;; (use zmq)
-
(declare (unit db))
(declare (uses common))
(declare (uses keys))
(declare (uses ods))
-(declare (uses fs-transport))
(declare (uses client))
(declare (uses mt))
(include "common_records.scm")
(include "db_records.scm")
(include "key_records.scm")
(include "run_records.scm")
-;; timestamp type (val1 val2 ...)
-;; type: meta-info, step
-(define *incoming-writes* '())
-(define *completed-writes* (make-hash-table))
-(define *incoming-last-time* (current-seconds))
-(define *incoming-mutex* (make-mutex))
-(define *completed-mutex* (make-mutex))
-(define *cache-on* #f)
-
-(define (db:set-sync db)
- (let* ((syncval (config-lookup *configdat* "setup" "synchronous"))
- (val (cond ;; 0 | OFF | 1 | NORMAL | 2 | FULL;
- ((not syncval) #f)
- ((string->number syncval)
- (let ((val (string->number syncval)))
- (if (member val '(0 1 2)) val #f)))
- ((string-match (regexp "yes" #t) syncval) 1)
- ((string-match (regexp "no" #t) syncval) 0)
- ((string-match (regexp "(off|normal|full)" #t) syncval) syncval)
- (else
- (debug:print 0 "ERROR: synchronous must be 0,1,2,OFF,NORMAL or FULL, you provided: " syncval)
- #f))))
- (if val
- (begin
- (debug:print-info 9 "db:set-sync, setting pragma synchronous to " val)
- (sqlite3:execute db (conc "PRAGMA synchronous = '" val "';"))))))
-
-(define (open-db) ;; (conc *toppath* "/megatest.db") (car *configinfo*)))
- (if (not *toppath*)
- (if (not (setup-for-run))
- (begin
- (debug:print 0 "ERROR: Attempted to open db when not in megatest area. Exiting.")
- (exit))))
- (let* ((dbpath (conc *toppath* "/megatest.db")) ;; fname)
- (dbexists (file-exists? dbpath))
+(define *rundb-mutex* (make-mutex)) ;; prevent problems opening/closing rundb's
+(define *number-of-writes* 0)
+(define *number-non-write-queries* 0)
+
+;; Get/open a database
+;; if run-id => get run specific db
+;; if #f => get main db
+;; 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 (sqlite3:database? dbstruct) ;; pass sqlite3 databases on through
+ dbstruct
+ (begin
+ (mutex-lock! *rundb-mutex*)
+ (let ((db (if run-id
+ (db:open-rundb dbstruct run-id)
+ (db:open-main dbstruct))))
+ ;; db prunning would go here
+ (mutex-unlock! *rundb-mutex*)
+ db))))
+
+;; mod-read:
+;; 'mod modified data
+;; 'read read data
+;;
+(define (db:done-with dbstruct run-id mod-read)
+ (if (not (sqlite3:database? dbstruct))
+ (begin
+ (mutex-lock! *rundb-mutex*)
+ (if (eq? mod-read 'mod)
+ (dbr:dbstruct-set-mtime! dbstruct (current-milliseconds))
+ (dbr:dbstruct-set-rtime! dbstruct (current-milliseconds)))
+ (dbr:dbstruct-set-inuse! dbstruct #f)
+ (mutex-unlock! *rundb-mutex*))))
+
+;; (db:with-db dbstruct run-id sqlite3:exec "select blah from 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* ((db (db:get-db dbstruct run-id))
+ )
+ ;; (proc2 (lambda ()
+ (let ((res (apply proc db params)))
+ (db:done-with dbstruct run-id r/w)
+ res)))
+;; (handle-exceptions
+;; exn
+;; (begin
+;; (thread-sleep! 10)
+;; (proc2))
+;; (proc2))))
+
+;;======================================================================
+;; 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)))
+;; (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 => zeroth db with name=main.db
+;;
+(define (db:dbfile-path run-id)
+ (let* (;; (toppath (dbr:dbstruct-get-path dbstruct))
+ (link-tree-path (configf:lookup *configdat* "setup" "linktree"))
+ (fname (if (eq? run-id 0) "main.db" (conc run-id ".db")))
+ (dbdir (conc link-tree-path "/.db/")))
+ (handle-exceptions
+ exn
+ (begin
+ (debug:print 0 "ERROR: Couldn't create path to " dbdir)
+ (exit 1))
+ (if (not (directory? dbdir))(create-directory dbdir #t)))
+ (conc dbdir fname)))
+
+;; This routine creates the db. It is only called if the db is not already opened
+;;
+(define (db:open-rundb dbstruct run-id) ;; (conc *toppath* "/megatest.db") (car *configinfo*)))
+ (let* ((local (dbr:dbstruct-get-local dbstruct))
+ (rdb (if local
+ (dbr:dbstruct-get-localdb dbstruct run-id)
+ (dbr:dbstruct-get-inmem dbstruct)))) ;; (dbr:dbstruct-get-runrec dbstruct run-id 'inmem)))
+ (if rdb
+ rdb
+ (let* ((dbpath (db:dbfile-path run-id)) ;; (conc toppath "/db/" run-id ".db"))
+ (dbexists (file-exists? dbpath))
+ (inmem (if local #f (db:open-inmem-db)))
+ (refdb (if local #f (db:open-inmem-db)))
+ (db (sqlite3:open-database dbpath))
+ (write-access (file-write-access? dbpath))
+ (handler (make-busy-timeout 136000)))
+ (if (and dbexists (not write-access))
+ (set! *db-write-access* #f)) ;; only unset so other db's also can use this control
+ (if write-access
+ (begin
+ (if (not dbexists)
+ (begin
+ (db:initialize-run-id-db db)
+ ;; (sdb:initialize db)
+ )) ;; add strings db to rundb, not in use yet
+ (sqlite3:set-busy-handler! db handler)
+ (sqlite3:execute db "PRAGMA synchronous = 1;"))) ;; was 0 but 0 is a gamble
+ (dbr:dbstruct-set-rundb! dbstruct db)
+ (dbr:dbstruct-set-inuse! dbstruct #t)
+ (if local
+ (begin
+ (dbr:dbstruct-set-localdb! dbstruct run-id db) ;; (dbr:dbstruct-set-inmem! dbstruct db) ;; direct access ...
+ db)
+ (begin
+ (dbr:dbstruct-set-inmem! dbstruct inmem)
+ (db:sync-tables db:sync-tests-only db inmem)
+ (dbr:dbstruct-set-refdb! dbstruct refdb)
+ (db:sync-tables db:sync-tests-only db refdb)
+ inmem))))))
+
+;; This routine creates the db. It is only called if the db is not already ls opened
+;;
+(define (db:open-main dbstruct) ;; (conc *toppath* "/megatest.db") (car *configinfo*)))
+ (let ((mdb (dbr:dbstruct-get-main dbstruct)))
+ (if mdb
+ mdb
+ (let* (;; (toppath (dbr:dbstruct-get-path dbstruct))
+ ;; (link-tree-path (configf:lookup *configdat* "setup" "linktree"))
+ (dbpath (db:dbfile-path 0)) ;; (let ((dbdir (conc *toppath* "/db"))) ;; use this opportunity to create our db dir
+ ;; (if (not (directory-exists? dbdir))
+ ;; (create-direcory dbdir))
+ ;; (conc *toppath* "/db/main.db")))
+ (dbexists (file-exists? dbpath))
+ (db (sqlite3:open-database dbpath))
+ (write-access (file-write-access? dbpath))
+ (handler (make-busy-timeout 136000)))
+ (if (and dbexists (not write-access))
+ (set! *db-write-access* #f))
+ (if write-access
+ (begin
+ (sqlite3:set-busy-handler! db handler)
+ (sqlite3:execute db "PRAGMA synchronous = 0;")))
+ (if (not dbexists)
+ (db:initialize-main-db db))
+ (dbr:dbstruct-set-main! dbstruct db)
+ db))))
+
+;; Make the dbstruct, setup up auxillary db's and call for main db at least once
+;;
+(define (db:setup run-id #!key (local #f))
+ (let* ((dbdir (conc (configf:lookup *configdat* "setup" "linktree") "/.db"))
+ (dbstruct (make-dbr:dbstruct path: dbdir local: local)))
+ (db:get-db dbstruct #f) ;; force one call to main
+ dbstruct))
+
+;; Open the classic megatest.db file in toppath
+;;
+(define (db:open-megatest-db)
+ (let* ((dbpath (conc *toppath* "/megatest.db"))
+ (dbexists (file-exists? dbpath))
+ (db (sqlite3:open-database dbpath))
(write-access (file-write-access? dbpath))
- (db (sqlite3:open-database dbpath)) ;; (never-give-up-open-db dbpath))
- (handler (make-busy-timeout (if (args:get-arg "-override-timeout")
- (string->number (args:get-arg "-override-timeout"))
- 136000)))) ;; 136000))) ;; 136000 = 2.2 minutes
- (if (and dbexists
- (not write-access))
- (set! *db-write-access* write-access)) ;; only unset so other db's also can use this control
- (debug:print-info 11 "open-db, dbpath=" dbpath " argv=" (argv))
- (if write-access (sqlite3:set-busy-handler! db handler))
+ (handler (make-busy-timeout 136000)))
+ (if (and dbexists (not write-access))
+ (set! *db-write-access* #f))
+ (if write-access
+ (begin
+ (sqlite3:set-busy-handler! db handler)
+ (sqlite3:execute db "PRAGMA synchronous = 0;")))
(if (not dbexists)
- (db:initialize db))
- ;; Moving db:set-sync to a call in run.scm - it is a persistent value and only needs to be set once
- ;; (db:set-sync db)
+ (begin
+ (db:initialize-main-db db)
+ (db:initialize-run-id-db db)))
+ db))
+
+;; sync all touched runs to disk
+;;
+(define (db:sync-touched dbstruct #!key (force-sync #f))
+ (let ((tot-synced 0))
+ (for-each
+ (lambda (runvec)
+ (let ((mtime (vector-ref runvec (dbr:dbstruct-field-name->num 'mtime)))
+ (stime (vector-ref runvec (dbr:dbstruct-field-name->num 'stime)))
+ (rundb (vector-ref runvec (dbr:dbstruct-field-name->num 'rundb)))
+ (inmem (vector-ref runvec (dbr:dbstruct-field-name->num 'inmem)))
+ (refdb (vector-ref runvec (dbr:dbstruct-field-name->num 'refdb))))
+ (if (or (> mtime stime) force-sync)
+ (let ((num-synced (db:sync-tables db:sync-tests-only inmem refdb rundb)))
+ (set! tot-synced (+ tot-synced num-synced))
+ (vector-set! runvec (dbr:dbstruct-field-name->num 'stime) (current-milliseconds))))))
+ (hash-table-values (vector-ref dbstruct 1)))
+ tot-synced))
+
+;; sync run to disk if touched
+;;
+(define (db:sync-touched dbstruct #!key (force-sync #f))
+ (let ((mtime (dbr:dbstruct-get-mtime dbstruct))
+ (stime (dbr:dbstruct-get-stime dbstruct))
+ (rundb (dbr:dbstruct-get-rundb dbstruct))
+ (inmem (dbr:dbstruct-get-inmem dbstruct))
+ (refdb (dbr:dbstruct-get-refdb dbstruct)))
+ (if (or (not (number? mtime))
+ (not (number? stime))
+ (> mtime stime)
+ force-sync)
+ (let ((num-synced (db:sync-tables db:sync-tests-only inmem refdb rundb)))
+ (dbr:dbstruct-set-stime! dbstruct (current-milliseconds))
+ num-synced)
+ 0)))
+
+;; close all opened run-id dbs
+(define (db:close-all dbstruct)
+ ;; finalize main.db
+ (db:sync-touched dbstruct force-sync: #t)
+ (sqlite3:finalize! (db:get-db dbstruct #f))
+ (let* ((local (dbr:dbstruct-get-local dbstruct))
+ (rundb (dbr:dbstruct-get-rundb dbstruct)))
+ (if local
+ (for-each
+ (lambda (db)
+ (if (sqlite3:database? db)
+ (sqlite3:finalize! db)))
+ (hash-table-values (dbr:dbstruct-get-locdbs dbstruct)))
+ (if (sqlite3:database? rundb)
+ (sqlite3:finalize! rundb)
+ (debug:print 0 "WARNING: attempting to close databases but got " rundb " instead of a database")))))
+
+(define (db:open-inmem-db)
+ (let* ((db (sqlite3:open-database ":memory:"))
+ (handler (make-busy-timeout 3600)))
+ (db:initialize-run-id-db db)
+ (sqlite3:set-busy-handler! db handler)
db))
+
+;; 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))
+ (list "test_steps"
+ '("id" #f)
+ '("test_id" #f)
+ '("stepname" #f)
+ '("state" #f)
+ '("status" #f)
+ '("event_time" #f)
+ '("comment" #f)
+ '("logfile" #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))))
+
+;; needs db to get keys, this is for syncing all tables
+;;
+(define (db:sync-main-list db)
+ (let ((keys (db:get-keys db)))
+ (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"))))
+ (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)))))
+
+;; tbls is ( ("tablename" ( "field1" [#f|proc1] ) ( "field2" [#f|proc2] ) .... ) )
+(define (db:sync-tables tbls fromdb todb . slave-dbs)
+ (cond
+ ((not fromdb) (debug:print 0 "ERROR: db:sync-tables called with fromdb missing") -1)
+ ((not todb) (debug:print 0 "ERROR: db:sync-tables called with todb missing") -2)
+ ((not (sqlite3:database? fromdb))
+ (debug:print 0 "ERROR: db:sync-tables called with fromdb not a database " fromdb) -3)
+ ((not (sqlite3:database? todb))
+ (debug:print 0 "ERROR: db:sync-tables called with todb not a database " todb) -4)
+ (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))
+ (num-fields (length fields))
+ (field->num (make-hash-table))
+ (num->field (apply vector (map car fields)))
+ (full-sel (conc "SELECT " (string-intersperse (map car fields) ",")
+ " FROM " tablename ";"))
+ (full-ins (conc "INSERT OR REPLACE INTO " tablename " ( " (string-intersperse (map car fields) ",") " ) "
+ " VALUES ( " (string-intersperse (make-list num-fields "?") ",") " );"))
+ (fromdat '())
+ (todat (make-hash-table))
+ (count 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)))
+ fromdb
+ full-sel)
+
+ (debug:print 0 "INFO: found " (length fromdat) " records to sync")
+
+ ;; read the target table
+ (sqlite3:for-each-row
+ (lambda (a . b)
+ (hash-table-set! todat a (apply vector a b)))
+ todb
+ full-sel)
+
+ ;; first pass implementation, just insert all changed rows
+ (for-each
+ (lambda (targdb)
+ (let ((stmth (sqlite3:prepare targdb full-ins)))
+ (sqlite3:with-transaction
+ targdb
+ (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)))
+ (sqlite3:finalize! stmth)))
+ (append (list todb) slave-dbs))))
+ tbls)
+ (let ((runtime (- (current-milliseconds) start-time)))
+ (debug:print 0 "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)
+ (debug:print 0 (format #f " ~10a ~5a" tblname count)))))
+ (sort (hash-table->alist numrecs)(lambda (a b)(> (cdr a)(cdr b))))))
+ tot-count))))
;; keeping it around for debugging purposes only
(define (open-run-close-no-exception-handling proc idb . params)
(debug:print-info 11 "open-run-close-no-exception-handling START given a db=" (if idb "yes " "no ") ", params=" params)
(if (or *db-write-access*
(not (member proc *db:all-write-procs*)))
- (let* ((db (cond
- ((sqlite3:database? idb) idb)
- ((not idb) (open-db))
- ((procedure? idb) (idb))
- (else (open-db))))
+ (let* ((db (cond
+ ((sqlite3:database? idb) idb)
+ ((not idb) (debug:print 0 "ERROR: cannot open-run-close with #f anymore"))
+ ((procedure? idb) (idb))
+ (else (debug:print 0 "ERROR: cannot open-run-close with #f anymore"))))
(res #f))
(set! res (apply proc db params))
- (if (not idb)(sqlite3:finalize! db))
+ (if (not idb)(sqlite3:finalize! dbstruct))
(debug:print-info 11 "open-run-close-no-exception-handling END" )
res)
#f))
(define (open-run-close-exception-handling proc idb . params)
@@ -114,37 +473,17 @@
(thread-sleep! (random 120))
(debug:print-info 0 "trying db call one more time....")
(apply open-run-close-no-exception-handling proc idb params))
(apply open-run-close-no-exception-handling proc idb params)))
-;; (define open-run-close open-run-close-exception-handling)
-(define open-run-close open-run-close-no-exception-handling)
-
-(define *global-delta* 0)
-(define *last-global-delta-printed* 0)
-
-(define (open-run-close-measure proc idb . params)
- (debug:print-info 11 "open-run-close-measure START, idb=" idb ", params=" params)
- (let* ((start-ms (current-milliseconds))
- (db (if idb idb (open-db)))
- (throttle (string->number (config-lookup *configdat* "setup" "throttle"))))
- ;; (db:set-sync db)
- (set! res (apply proc db params))
- (if (not idb)(sqlite3:finalize! db))
- ;; scale by 10, average with current value.
- (set! *global-delta* (/ (+ *global-delta* (* (- (current-milliseconds) start-ms)
- (if throttle throttle 0.01)))
- 2))
- (if (> (abs (- *last-global-delta-printed* *global-delta*)) 0.08) ;; don't print all the time, only if it changes a bit
- (begin
- (debug:print-info 1 "launch throttle factor=" *global-delta*)
- (set! *last-global-delta-printed* *global-delta*)))
- (debug:print-info 11 "open-run-close-measure END" )
- res))
-
-(define (db:initialize db)
- (debug:print-info 11 "db:initialize START")
+;; (define open-run-close
+(define open-run-close ;; (if (debug:debug-mode 2)
+ ;; open-run-close-no-exception-handling
+ open-run-close-exception-handling)
+;;)
+
+(define (db:initialize-main-db db)
(let* ((configdat (car *configinfo*)) ;; tut tut, global warning...
(keys (keys:config-get-fields configdat))
(havekeys (> (length keys) 0))
(keystr (keys->keystr keys))
(fieldstr (keys->key/field keys)))
@@ -152,75 +491,31 @@
(let ((keyn key))
(if (member (string-downcase keyn)
(list "runname" "state" "status" "owner" "event_time" "comment" "fail_count"
"pass_count"))
(begin
- (print "ERROR: your key cannot be named " keyn " as this conflicts with the same named field in the runs table")
- (system (conc "rm -f " dbpath))
+ (print "ERROR: your key cannot be named " keyn " as this conflicts with the same named field in the runs table, you must remove your megatest.db and <linktree>/.db before trying again.")
(exit 1)))))
keys)
- ;; (sqlite3:execute db "PRAGMA synchronous = OFF;")
- (db:set-sync db)
(sqlite3:execute db "CREATE TABLE IF NOT EXISTS keys (id INTEGER PRIMARY KEY, fieldname TEXT, fieldtype TEXT, CONSTRAINT keyconstraint UNIQUE (fieldname));")
(for-each (lambda (key)
(sqlite3:execute db "INSERT INTO keys (fieldname,fieldtype) VALUES (?,?);" key "TEXT"))
keys)
(sqlite3:execute db (conc
- "CREATE TABLE IF NOT EXISTS runs (id INTEGER PRIMARY KEY, "
- fieldstr (if havekeys "," "")
- "runname TEXT,"
- "state TEXT DEFAULT '',"
- "status TEXT DEFAULT '',"
- "owner TEXT DEFAULT '',"
- "event_time TIMESTAMP,"
- "comment TEXT DEFAULT '',"
- "fail_count INTEGER DEFAULT 0,"
- "pass_count INTEGER DEFAULT 0,"
- "CONSTRAINT runsconstraint UNIQUE (runname" (if havekeys "," "") keystr "));"))
- (sqlite3:execute db (conc "CREATE INDEX runs_index ON runs (runname" (if havekeys "," "") keystr ");"))
- (sqlite3:execute db
- "CREATE TABLE IF NOT EXISTS tests
- (id INTEGER PRIMARY KEY,
- run_id INTEGER,
- testname TEXT,
- host TEXT DEFAULT 'n/a',
- cpuload REAL DEFAULT -1,
- diskfree INTEGER DEFAULT -1,
- uname TEXT DEFAULT 'n/a',
- rundir TEXT DEFAULT 'n/a',
- shortdir TEXT DEFAULT '',
- item_path TEXT DEFAULT '',
- state TEXT DEFAULT 'NOT_STARTED',
- status TEXT DEFAULT 'FAIL',
- attemptnum INTEGER DEFAULT 0,
- final_logf TEXT DEFAULT 'logs/final.log',
- logdat BLOB,
- run_duration INTEGER DEFAULT 0,
- comment TEXT DEFAULT '',
- event_time TIMESTAMP,
- fail_count INTEGER DEFAULT 0,
- pass_count INTEGER DEFAULT 0,
- archived INTEGER DEFAULT 0, -- 0=no, 1=in progress, 2=yes
- CONSTRAINT testsconstraint UNIQUE (run_id, testname, item_path)
- );")
- (sqlite3:execute db "CREATE INDEX tests_index ON tests (run_id, testname, item_path);")
- (sqlite3:execute db "CREATE VIEW runs_tests AS SELECT * FROM runs INNER JOIN tests ON runs.id=tests.run_id;")
- (sqlite3:execute db "CREATE TABLE IF NOT EXISTS test_steps
- (id INTEGER PRIMARY KEY,
- test_id INTEGER,
- stepname TEXT,
- state TEXT DEFAULT 'NOT_STARTED',
- status TEXT DEFAULT 'n/a',
- event_time TIMESTAMP,
- comment TEXT DEFAULT '',
- logfile TEXT DEFAULT '',
- CONSTRAINT test_steps_constraint UNIQUE (test_id,stepname,state));")
- (sqlite3:execute db "CREATE TABLE IF NOT EXISTS extradat (id INTEGER PRIMARY KEY, run_id INTEGER, key TEXT, val TEXT);")
- (sqlite3:execute db "CREATE TABLE IF NOT EXISTS metadat (id INTEGER PRIMARY KEY, var TEXT, val TEXT,
- CONSTRAINT metadat_constraint UNIQUE (var));")
- (sqlite3:execute db "CREATE TABLE IF NOT EXISTS access_log (id INTEGER PRIMARY KEY, user TEXT, accessed TIMESTAMP, args TEXT);")
- (sqlite3:execute db "CREATE TABLE IF NOT EXISTS test_meta (id INTEGER PRIMARY KEY,
+ "CREATE TABLE IF NOT EXISTS runs (id INTEGER PRIMARY KEY, \n "
+ fieldstr (if havekeys "," "") "
+ runname TEXT DEFAULT 'norun',
+ state TEXT DEFAULT '',
+ status TEXT DEFAULT '',
+ owner TEXT DEFAULT '',
+ event_time TIMESTAMP DEFAULT (strftime('%s','now')),
+ comment TEXT DEFAULT '',
+ fail_count INTEGER DEFAULT 0,
+ pass_count INTEGER DEFAULT 0,
+ CONSTRAINT runsconstraint UNIQUE (runname" (if havekeys "," "") keystr "));"))
+ (sqlite3:execute db "CREATE TABLE IF NOT EXISTS test_meta (
+ id INTEGER PRIMARY KEY,
testname TEXT DEFAULT '',
author TEXT DEFAULT '',
owner TEXT DEFAULT '',
description TEXT DEFAULT '',
reviewed TIMESTAMP,
@@ -228,10 +523,69 @@
avg_runtime REAL,
avg_disk REAL,
tags TEXT DEFAULT '',
jobgroup TEXT DEFAULT 'default',
CONSTRAINT test_meta_constraint UNIQUE (testname));")
+ (sqlite3:execute db (conc "CREATE INDEX runs_index ON runs (runname" (if havekeys "," "") keystr ");"))
+ ;; (sqlite3:execute db "CREATE VIEW runs_tests AS SELECT * FROM runs INNER JOIN tests ON runs.id=tests.run_id;")
+ (sqlite3:execute db "CREATE TABLE IF NOT EXISTS extradat (id INTEGER PRIMARY KEY, run_id INTEGER, key TEXT, val TEXT);")
+ (sqlite3:execute db "CREATE TABLE IF NOT EXISTS metadat (id INTEGER PRIMARY KEY, var TEXT, val TEXT,
+ CONSTRAINT metadat_constraint UNIQUE (var));")
+ (sqlite3:execute db "CREATE TABLE IF NOT EXISTS access_log (id INTEGER PRIMARY KEY, user TEXT, accessed TIMESTAMP, args TEXT);")
+ ;; Must do this *after* running patch db !! No more.
+ ;; cannot use db:set-var since it will deadlock, hardwire the code here
+ (sqlite3:execute db "INSERT OR REPLACE INTO metadat (var,val) VALUES (?,?);" "MEGATEST_VERSION" megatest-version)
+ (debug:print-info 11 "db:initialize END")))
+
+;;======================================================================
+;; R U N S P E C I F I C D B
+;;======================================================================
+
+(define (db:initialize-run-id-db db)
+ (sqlite3:execute db "CREATE TABLE IF NOT EXISTS tests
+ (id INTEGER PRIMARY KEY,
+ run_id INTEGER DEFAULT -1,
+ testname TEXT DEFAULT 'noname',
+ host TEXT DEFAULT 'n/a',
+ cpuload REAL DEFAULT -1,
+ diskfree INTEGER DEFAULT -1,
+ uname TEXT DEFAULT 'n/a',
+ rundir TEXT DEFAULT '/tmp/badname',
+ shortdir TEXT DEFAULT '/tmp/badname',
+ item_path TEXT DEFAULT '',
+ state TEXT DEFAULT 'NOT_STARTED',
+ status TEXT DEFAULT 'FAIL',
+ attemptnum INTEGER DEFAULT 0,
+ final_logf TEXT DEFAULT 'logs/final.log',
+ logdat TEXT DEFAULT '',
+ run_duration INTEGER DEFAULT 0,
+ comment TEXT DEFAULT '',
+ event_time TIMESTAMP DEFAULT (strftime('%s','now')),
+ fail_count INTEGER DEFAULT 0,
+ pass_count INTEGER DEFAULT 0,
+ archived INTEGER DEFAULT 0, -- 0=no, 1=in progress, 2=yes
+ CONSTRAINT testsconstraint UNIQUE (run_id, testname, item_path));")
+ (sqlite3:execute db "CREATE INDEX tests_index ON tests (run_id, testname, item_path);")
+ (sqlite3:execute db "CREATE TABLE IF NOT EXISTS test_steps
+ (id INTEGER PRIMARY KEY,
+ test_id INTEGER,
+ stepname TEXT,
+ state TEXT DEFAULT 'NOT_STARTED',
+ status TEXT DEFAULT 'n/a',
+ event_time TIMESTAMP,
+ comment TEXT DEFAULT '',
+ logfile TEXT DEFAULT '',
+ CONSTRAINT test_steps_constraint UNIQUE (test_id,stepname,state));")
+;; (sqlite3:execute db "CREATE TABLE IF NOT EXISTS test_data
+;; (id INTEGER PRIMARY KEY,
+;; reviewed TIMESTAMP DEFAULT (strftime('%s','now')),
+;; iterated TEXT DEFAULT '',
+;; avg_runtime REAL DEFAULT -1,
+;; avg_disk REAL DEFAULT -1,
+;; tags TEXT DEFAULT '',
+;; jobgroup TEXT DEFAULT 'default',
+;; CONSTRAINT test_meta_constraint UNIQUE (testname));")
(sqlite3:execute db "CREATE TABLE IF NOT EXISTS test_data (id INTEGER PRIMARY KEY,
test_id INTEGER,
category TEXT DEFAULT '',
variable TEXT,
value REAL,
@@ -240,123 +594,28 @@
units TEXT,
comment TEXT DEFAULT '',
status TEXT DEFAULT 'n/a',
type TEXT DEFAULT '',
CONSTRAINT test_data_constraint UNIQUE (test_id,category,variable));")
- ;; Must do this *after* running patch db !! No more.
- (db:set-var db "MEGATEST_VERSION" megatest-version)
- (debug:print-info 11 "db:initialize END")
- ))
-
-;;======================================================================
-;; T E S T S P E C I F I C D B
-;;======================================================================
-
-;; Create the sqlite db for the individual test(s)
-(define (open-test-db work-area)
- (debug:print-info 11 "open-test-db " work-area)
- (if (and work-area
- (directory? work-area)
- (file-read-access? work-area))
- (let* ((dbpath (conc work-area "/testdat.db"))
- (tdb-writeable (file-write-access? dbpath))
- (dbexists (file-exists? dbpath))
- (handler (make-busy-timeout (if (args:get-arg "-override-timeout")
- (string->number (args:get-arg "-override-timeout"))
- 136000))))
- (handle-exceptions
- exn
- (begin
- (debug:print 2 "ERROR: problem accessing test db " work-area ", you probably should clean and re-run this test"
- ((condition-property-accessor 'exn 'message) exn))
- (set! db (sqlite3:open-database ":memory:"))) ;; open an in-memory db to allow readonly access
- (set! db (sqlite3:open-database dbpath)))
- (if *db-write-access* (sqlite3:set-busy-handler! db handler))
- (if (not dbexists)
- (begin
- (sqlite3:execute db "PRAGMA synchronous = FULL;")
- (debug:print-info 11 "Initialized test database " dbpath)
- (db:testdb-initialize db)))
- ;; (sqlite3:execute db "PRAGMA synchronous = 0;")
- (debug:print-info 11 "open-test-db END (sucessful)" work-area)
- ;; now let's test that everything is correct
- (handle-exceptions
- exn
- (begin
- (debug:print 0 "ERROR: problem accessing test db " work-area ", you probably should clean and re-run this test"
- ((condition-property-accessor 'exn 'message) exn))
- #f)
- ;; Is there a cheaper single line operation that will check for existance of a table
- ;; and raise an exception ?
- (sqlite3:execute db "SELECT id FROM test_data LIMIT 1;"))
- db)
- (begin
- (debug:print-info 11 "open-test-db END (unsucessful)" work-area)
- #f)))
-
-;; find and open the testdat.db file for an existing test
-(define (db:open-test-db-by-test-id db test-id #!key (work-area #f))
- (let* ((test-path (if work-area
- work-area
- (cdb:remote-run db:test-get-rundir-from-test-id db test-id))))
- (debug:print 3 "TEST PATH: " test-path)
- (open-test-db test-path)))
-
-(define (db:testdb-initialize db)
- (debug:print 11 "db:testdb-initialize START")
- (for-each
- (lambda (sqlcmd)
- (sqlite3:execute db sqlcmd))
- (list "CREATE TABLE IF NOT EXISTS test_rundat (
- id INTEGER PRIMARY KEY,
- update_time TIMESTAMP,
- cpuload INTEGER DEFAULT -1,
- diskfree INTEGER DEFAULT -1,
- diskusage INTGER DEFAULT -1,
- run_duration INTEGER DEFAULT 0);"
- "CREATE TABLE IF NOT EXISTS test_data (
- id INTEGER PRIMARY KEY,
- test_id INTEGER,
- category TEXT DEFAULT '',
- variable TEXT,
- value REAL,
- expected REAL,
- tol REAL,
- units TEXT,
- comment TEXT DEFAULT '',
- status TEXT DEFAULT 'n/a',
- type TEXT DEFAULT '',
- CONSTRAINT test_data_constraint UNIQUE (test_id,category,variable));"
- "CREATE TABLE IF NOT EXISTS test_steps (
- id INTEGER PRIMARY KEY,
- test_id INTEGER,
- stepname TEXT,
- state TEXT DEFAULT 'NOT_STARTED',
- status TEXT DEFAULT 'n/a',
- event_time TIMESTAMP,
- comment TEXT DEFAULT '',
- logfile TEXT DEFAULT '',
- CONSTRAINT test_steps_constraint UNIQUE (test_id,stepname,state));"
- ;; test_meta can be used for handing commands to the test
- ;; e.g. KILLREQ
- ;; the ackstate is set to 1 once the command has been completed
- "CREATE TABLE IF NOT EXISTS test_meta (
- id INTEGER PRIMARY KEY,
- var TEXT,
- val TEXT,
- ackstate INTEGER DEFAULT 0,
- CONSTRAINT metadat_constraint UNIQUE (var));"))
- (debug:print 11 "db:testdb-initialize END"))
+ (sqlite3:execute db "CREATE TABLE IF NOT EXISTS test_rundat (
+ id INTEGER PRIMARY KEY,
+ test_id INTEGER,
+ update_time TIMESTAMP,
+ cpuload INTEGER DEFAULT -1,
+ diskfree INTEGER DEFAULT -1,
+ diskusage INTGER DEFAULT -1,
+ run_duration INTEGER DEFAULT 0);")
+ db)
;;======================================================================
;; L O G G I N G D B
;;======================================================================
(define (open-logging-db) ;; (conc *toppath* "/megatest.db") (car *configinfo*)))
(let* ((dbpath (conc (if *toppath* (conc *toppath* "/") "") "logging.db")) ;; fname)
(dbexists (file-exists? dbpath))
- (db (sqlite3:open-database dbpath)) ;; (never-give-up-open-db dbpath))
+ (db (sqlite3:open-database dbpath))
(handler (make-busy-timeout (if (args:get-arg "-override-timeout")
(string->number (args:get-arg "-override-timeout"))
136000)))) ;; 136000)))
(sqlite3:set-busy-handler! db handler)
(if (not dbexists)
@@ -365,13 +624,10 @@
(sqlite3:execute db (conc "PRAGMA synchronous = 0;"))))
db))
(define (db:log-local-event . loglst)
(let ((logline (apply conc loglst)))
- ;; (pwd (current-directory))
- ;; (cmdline (string-intersperse (argv) " "))
- ;; (pid (current-process-id)))
(db:log-event logline)))
(define (db:log-event logline)
(let ((db (open-logging-db)))
(sqlite3:execute db "INSERT INTO log (logline,pwd,cmdline,pid) VALUES (?,?,?,?);"
@@ -381,93 +637,12 @@
(current-process-id))
(sqlite3:finalize! db)
logline))
;;======================================================================
-;; TODO:
-;; put deltas into an assoc list with version numbers
-;; apply all from last to current
+;; D B U T I L S
;;======================================================================
-(define (patch-db db)
- (handle-exceptions
- exn
- (begin
- (print "Exception: " exn)
- (print "ERROR: Possible out of date schema, attempting to add table metadata...")
- (sqlite3:execute db "CREATE TABLE IF NOT EXISTS metadat (id INTEGER, var TEXT, val TEXT,
- CONSTRAINT metadat_constraint UNIQUE (var));")
- (if (not (db:get-var db "MEGATEST_VERSION"))
- (db:set-var db "MEGATEST_VERSION" 1.17)))
- (let ((mver (db:get-var db "MEGATEST_VERSION"))
- (test-meta-def "CREATE TABLE IF NOT EXISTS test_meta (id INTEGER PRIMARY KEY,
- testname TEXT DEFAULT '',
- author TEXT DEFAULT '',
- owner TEXT DEFAULT '',
- description TEXT DEFAULT '',
- reviewed TIMESTAMP,
- iterated TEXT DEFAULT '',
- avg_runtime REAL,
- avg_disk REAL,
- tags TEXT DEFAULT '',
- CONSTRAINT test_meta_constraint UNIQUE (testname));"))
- (print "Current schema version: " mver " current megatest version: " megatest-version)
- (cond
- ((not mver)
- (print "Adding megatest-version to metadata") ;; Need to recreate the table
- (sqlite3:execute db "DROP TABLE IF EXISTS metadat;")
- (sqlite3:execute db "CREATE TABLE IF NOT EXISTS metadat (id INTEGER, var TEXT, val TEXT,
- CONSTRAINT metadat_constraint UNIQUE (var));")
- (db:set-var db "MEGATEST_VERSION" 1.17)
- (patch-db))
- ((< mver 1.21)
- (sqlite3:execute db "DROP TABLE IF EXISTS metadat;")
- (sqlite3:execute db "CREATE TABLE IF NOT EXISTS metadat (id INTEGER, var TEXT, val TEXT,
- CONSTRAINT metadat_constraint UNIQUE (var));")
- (db:set-var db "MEGATEST_VERSION" 1.21) ;; set before, just in case the changes are already applied
- (sqlite3:execute db test-meta-def)
- ;(for-each
- ; (lambda (stmt)
- ; (sqlite3:execute db stmt))
- ; (list
- ; "ALTER TABLE tests ADD COLUMN first_err TEXT;"
- ; "ALTER TABLE tests ADD COLUMN first_warn TEXT;"
- ; ))
- (patch-db))
- ((< mver 1.24)
- (db:set-var db "MEGATEST_VERSION" 1.24)
- (sqlite3:execute db "DROP TABLE IF EXISTS test_data;")
- (sqlite3:execute db "DROP TABLE IF EXISTS test_meta;")
- (sqlite3:execute db test-meta-def)
- (sqlite3:execute db "CREATE TABLE IF NOT EXISTS test_data (id INTEGER PRIMARY KEY,
- test_id INTEGER,
- category TEXT DEFAULT '',
- variable TEXT,
- value REAL,
- expected REAL,
- tol REAL,
- units TEXT,
- comment TEXT DEFAULT '',
- status TEXT DEFAULT 'n/a',
- CONSTRAINT test_data UNIQUE (test_id,category,variable));")
- (print "WARNING: Table test_data and test_meta were recreated. Please do megatest -update-meta")
- (patch-db))
- ((< mver 1.27)
- (db:set-var db "MEGATEST_VERSION" 1.27)
- (sqlite3:execute db "ALTER TABLE test_data ADD COLUMN type TEXT DEFAULT '';")
- (patch-db))
- ((< mver 1.29)
- (db:set-var db "MEGATEST_VERSION" 1.29)
- (sqlite3:execute db "ALTER TABLE test_steps ADD COLUMN logfile TEXT DEFAULT '';")
- (sqlite3:execute db "ALTER TABLE tests ADD COLUMN shortdir TEXT DEFAULT '';"))
- ((< mver 1.36)
- (db:set-var db "MEGATEST_VERSION" 1.36)
- (sqlite3:execute db "ALTER TABLE test_meta ADD COLUMN jobgroup TEXT DEFAULT 'default';"))
- ((< mver 1.37)
- (db:set-var db "MEGATEST_VERSION" 1.37)
- (sqlite3:execute db "ALTER TABLE tests ADD COLUMN archived INTEGER DEFAULT 0;"))
- ((< mver megatest-version)
- (db:set-var db "MEGATEST_VERSION" megatest-version))))))
;;======================================================================
;; M A I N T E N A N C E
;;======================================================================
@@ -482,11 +657,11 @@
(deadtime-str (configf:lookup *configdat* "setup" "deadtime"))
(deadtime (if (and deadtime-str
(string->number deadtime-str))
(string->number deadtime-str)
7200)) ;; two hours
- (run-ids (db:get-run-ids db))) ;; iterate over runs to divy up the calls
+ (run-ids (db:get-all-run-ids db))) ;; iterate over runs to divy up the calls
(if (number? ovr-deadtime)(set! deadtime ovr-deadtime))
(for-each
(lambda (run-id)
;; in RUNNING or REMOTEHOSTSTART for more than 10 minutes
@@ -535,12 +710,16 @@
;; 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 db)
- (let ((count-stmt (sqlite3:prepare db "SELECT (SELECT count(id) FROM tests)+(SELECT count(id) FROM runs);"))
+(define (db:clean-up dbstruct)
+
+ (debug:print 0 "ERROR: db clean up not ported yet")
+
+ (let* ((db (db:get-db dbstruct #f))
+ (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'
@@ -568,25 +747,28 @@
(sqlite3:finalize! count-stmt)
(db:find-and-mark-incomplete db)
(sqlite3:execute db "VACUUM;")))
;;======================================================================
-;; meta get and set vars
+;; M E T A G E T A N D S E T V A R S
;;======================================================================
;; returns number if string->number is successful, string otherwise
;; also updates *global-delta*
-(define (db:get-var db var)
- (debug:print-info 11 "db:get-var START " var)
+;;
+;; Operates on megatestdb
+;;
+(define (db:get-var dbstruct var)
(let* ((start-ms (current-milliseconds))
(throttle (let ((t (config-lookup *configdat* "setup" "throttle")))
(if t (string->number t) t)))
(res #f))
(sqlite3:for-each-row
(lambda (val)
(set! res val))
- db "SELECT val FROM metadat WHERE var=?;" var)
+ (db:get-db dbstruct #f)
+ "SELECT val FROM metadat WHERE var=?;" var)
;; convert to number if can
(if (string? res)
(let ((valnum (string->number res)))
(if valnum (set! res valnum))))
;; scale by 10, average with current value.
@@ -595,72 +777,73 @@
2))
(if (> (abs (- *last-global-delta-printed* *global-delta*)) 0.08) ;; don't print all the time, only if it changes a bit
(begin
(debug:print-info 4 "launch throttle factor=" *global-delta*)
(set! *last-global-delta-printed* *global-delta*)))
- (debug:print-info 11 "db:get-var END " var " val=" res)
res))
-(define (db:set-var db var val)
- (debug:print-info 11 "db:set-var START " var " " val)
- (sqlite3:execute db "INSERT OR REPLACE INTO metadat (var,val) VALUES (?,?);" var val)
- (debug:print-info 11 "db:set-var END " var " " val))
-
-(define (db:del-var db var)
- (debug:print-info 11 "db:del-var START " var)
- (sqlite3:execute db "DELETE FROM metadat WHERE var=?;" var)
- (debug:print-info 11 "db:del-var END " var))
+(define (db:set-var dbstruct var val)
+ (sqlite3:execute (db:get-db dbstruct #f) "INSERT OR REPLACE INTO metadat (var,val) VALUES (?,?);" var val))
+
+(define (db:del-var dbstruct var)
+ (sqlite3:execute (db:get-db dbstruct #f) "DELETE FROM metadat WHERE var=?;" var))
;; 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
;; why get the keys from the db? why not get from the *configdat*
;; using keys:config-get-fields?
-(define (db:get-keys db)
+(define (db:get-keys dbstruct)
(if *db-keys* *db-keys*
(let ((res '()))
- (sqlite3:for-each-row
- (lambda (key)
- (set! res (cons key res)))
- db
- "SELECT fieldname FROM keys ORDER BY id DESC;")
+ (db:with-db dbstruct #f #f
+ (lambda (db)
+ (sqlite3:for-each-row
+ (lambda (key)
+ (set! res (cons key res)))
+ (db:get-db dbstruct #f)
+ "SELECT fieldname FROM keys ORDER BY id DESC;")))
(set! *db-keys* res)
res)))
-;;
+;; look up values in a header/data structure
(define (db:get-value-by-header row header field)
- (debug:print-info 4 "db:get-value-by-header row: " row " header: " header " field: " field)
(if (null? header) #f
(let loop ((hed (car header))
(tal (cdr header))
(n 0))
(if (equal? hed field)
(vector-ref row n)
(if (null? tal) #f (loop (car tal)(cdr tal)(+ n 1)))))))
+;; Accessors for the header/data structure
+;; get rows and header from
+(define (db:get-header vec)(vector-ref vec 0))
+(define (db:get-rows vec)(vector-ref vec 1))
+
;;======================================================================
;; R U N S
;;======================================================================
-(define (db:get-run-name-from-id db run-id)
+(define (db:get-run-name-from-id dbstruct run-id)
(let ((res #f))
(sqlite3:for-each-row
(lambda (runname)
(set! res runname))
- db
+ (db:get-db dbstruct #f)
"SELECT runname FROM runs WHERE id=?;"
run-id)
res))
-(define (db:get-run-key-val db run-id key)
+(define (db:get-run-key-val dbstruct run-id key)
(let ((res #f))
(sqlite3:for-each-row
(lambda (val)
(set! res val))
- db
+ (db:get-db dbstruct #f)
(conc "SELECT " key " FROM runs WHERE id=?;")
run-id)
res))
;; keys list to key1,key2,key3 ...
@@ -682,14 +865,16 @@
'("")
patts))
comparator)))
-;; register a test run with the db
-(define (db:register-run db keyvals runname state status user)
- (debug:print 3 "runs:register-run runname: " runname " state: " state " status: " status " user: " user)
- (let* ((keys (map car keyvals))
+;; register a test run with the db, this accesses the main.db and does NOT
+;; use server api
+;;
+(define (db:register-run dbstruct keyvals runname state status user)
+ (let* ((db (db:get-db dbstruct #f))
+ (keys (map car keyvals))
(keystr (keys->keystr keys))
(comma (if (> (length keys) 0) "," ""))
(andstr (if (> (length keys) 0) " AND " ""))
(valslots (keys->valslots keys)) ;; ?,?,? ...
(allvals (append (list runname state status user) (map cadr keyvals)))
@@ -713,114 +898,183 @@
res)
(begin
(debug:print 0 "ERROR: Called without all necessary keys")
#f))))
-
;; replace header and keystr with a call to runs:get-std-run-fields
;;
;; keypatts: ( (KEY1 "abc%def")(KEY2 "%") )
;; runpatts: patt1,patt2 ...
;;
-(define (db:get-runs db runpatt count offset keypatts)
+(define (db:get-runs dbstruct runpatt count offset keypatts)
(let* ((res '())
- (keys (db:get-keys db))
+ (keys (db:get-keys dbstruct))
(runpattstr (db:patt->like "runname" runpatt))
(remfields (list "id" "runname" "state" "status" "owner" "event_time"))
(header (append keys remfields))
(keystr (conc (keys->keystr keys) ","
- (string-intersperse remfields ",")))
+ (string-intersperse remfields ",")))
(qrystr (conc "SELECT " keystr " FROM runs WHERE (" runpattstr ") " ;; runname LIKE ? "
- ;; Generate: " AND x LIKE 'keypatt' ..."
- (if (null? keypatts) ""
- (conc " AND "
+ ;; Generate: " AND x LIKE 'keypatt' ..."
+ (if (null? keypatts) ""
+ (conc " AND "
(string-join
(map (lambda (keypatt)
(let ((key (car keypatt))
(patt (cadr keypatt)))
(db:patt->like key patt)))
keypatts)
" AND ")))
- " AND state != 'deleted' ORDER BY event_time DESC "
- (if (number? count)
- (conc " LIMIT " count)
- "")
- (if (number? offset)
- (conc " OFFSET " offset)
- ""))))
+ " AND state != 'deleted' ORDER BY event_time DESC "
+ (if (number? count)
+ (conc " LIMIT " count)
+ "")
+ (if (number? offset)
+ (conc " OFFSET " offset)
+ ""))))
(debug:print-info 11 "db:get-runs START qrystr: " qrystr " keypatts: " keypatts " offset: " offset " limit: " count)
- (sqlite3:for-each-row
- (lambda (a . x)
- (set! res (cons (apply vector a x) res)))
- db
- qrystr
- )
+ (db:with-db dbstruct #f #f
+ (lambda (db)
+ (sqlite3:for-each-row
+ (lambda (a . x)
+ (set! res (cons (apply vector a x) res)))
+ db
+ qrystr
+ )))
(debug:print-info 11 "db:get-runs END qrystr: " qrystr " keypatts: " keypatts " offset: " offset " limit: " count)
(vector header res)))
+;; db:get-runs-by-patt
+;; get runs by list of criteria
+;; register a test run with the db
+;;
+;; Use: (db:get-value-by-header (db:get-header runinfo)(db:get-rows runinfo))
+;; to extract info from the structure returned
+;;
+;; NOTE: THIS IS COMPLETELY UNFINISHED. IT GOES WITH rmt:get-get-paths-matching-keynames
+;;
+(define (db:get-run-ids-matching dbstruct keynames target res)
+;; (define (db:get-runs-by-patt dbstruct keys runnamepatt targpatt offset limit) ;; test-name)
+ (let* ((tmp (runs:get-std-run-fields keys '("id" "runname" "state" "status" "owner" "event_time")))
+ (keystr (car tmp))
+ (header (cadr tmp))
+ (res '())
+ (key-patt "")
+ (runwildtype (if (substring-index "%" runnamepatt) "like" "glob"))
+ (qry-str #f)
+ (keyvals (if targpatt (keys:target->keyval keys targpatt) '())))
+ (for-each (lambda (keyval)
+ (let* ((key (car keyval))
+ (patt (cadr keyval))
+ (fulkey (conc ":" key))
+ (wildtype (if (substring-index "%" patt) "like" "glob")))
+ (if patt
+ (set! key-patt (conc key-patt " AND " key " " wildtype " '" patt "'"))
+ (begin
+ (debug:print 0 "ERROR: searching for runs with no pattern set for " fulkey)
+ (exit 6)))))
+ keyvals)
+ (set! qry-str (conc "SELECT " keystr " FROM runs WHERE state != 'deleted' AND runname " runwildtype " ? " key-patt " ORDER BY event_time "
+ (if limit (conc " LIMIT " limit) "")
+ (if offset (conc " OFFSET " offset) "")
+ ";"))
+ (debug:print-info 4 "runs:get-runs-by-patt qry=" qry-str " " runnamepatt)
+ (db:with-db dbstruct #f #f ;; reads db, does not write to it.
+ (lambda (db)
+ (sqlite3:for-each-row
+ (lambda (a . r)
+ (set! res (cons (list->vector (cons a r)) res)))
+ (db:get-db dbstruct #f)
+ qry-str
+ runnamepatt)))
+ (vector header res)))
+
;; Get all targets from the db
;;
-(define (db:get-targets db)
+(define (db:get-targets dbstruct)
(let* ((res '())
- (keys (db:get-keys db))
+ (keys (db:get-keys dbstruct))
(header keys) ;; (map key:get-fieldname keys))
(keystr (keys->keystr keys))
- (qrystr (conc "SELECT " keystr " FROM runs;"))
+ (qrystr (conc "SELECT " keystr " FROM runs WHERE state != 'deleted';"))
(seen (make-hash-table)))
(sqlite3:for-each-row
(lambda (a . x)
(let ((targ (cons a x)))
(if (not (hash-table-ref/default seen targ #f))
(begin
(hash-table-set! seen targ #t)
(set! res (cons (apply vector targ) res))))))
- db
+ (db:get-db dbstruct #f)
qrystr)
(debug:print-info 11 "db:get-targets END qrystr: " qrystr )
(vector header res)))
;; just get count of runs
-(define (db:get-num-runs db runpatt)
+(define (db:get-num-runs dbstruct runpatt)
(let ((numruns 0))
(debug:print-info 11 "db:get-num-runs START " runpatt)
(sqlite3:for-each-row
(lambda (count)
(set! numruns count))
- db
+ (db:get-db dbstruct #f)
"SELECT COUNT(id) FROM runs WHERE runname LIKE ? AND state != 'deleted';" runpatt)
(debug:print-info 11 "db:get-num-runs END " runpatt)
numruns))
+
+(define (db:get-all-run-ids dbstruct)
+ (let ((run-ids '()))
+ (sqlite3:for-each-row
+ (lambda (run-id)
+ (set! run-ids (cons run-id run-ids)))
+ (db:get-db dbstruct #f)
+ "SELECT id FROM runs WHERE state != 'deleted';")
+ (reverse run-ids)))
;; get some basic run stats
;;
;; ( (runname (( state count ) ... ))
;; ( ...
-(define (db:get-run-stats db)
+(define (db:get-run-stats dbstruct)
(let ((totals (make-hash-table))
- (res '()))
+ (res '())
+ (runs-info '()))
+ ;; First get all the runname/run-ids
(sqlite3:for-each-row
- (lambda (runname state count)
- (let* ((stateparts (string-split state "|"))
- (newstate (conc (car stateparts) "\n" (cadr stateparts))))
- (hash-table-set! totals newstate (+ (hash-table-ref/default totals newstate 0) count))
- (set! res (cons (list runname newstate count) res))))
- db
- "SELECT runname,t.state||'|'||t.status AS s,count(t.id) FROM runs AS r INNER JOIN tests AS t ON r.id=t.run_id GROUP BY s,runname ORDER BY r.event_time,s DESC;" )
+ (lambda (run-id runname)
+ (set! runs-info (cons (list run-id runname) runs-info)))
+ (db:get-db dbstruct #f)
+ "SELECT id,runname FROM runs WHERE state != 'deleted';")
+ ;; for each run get stats data
+ (for-each
+ (lambda (run-info)
+ (let ((run-id (car run-info))
+ (run-name (cadr run-info)))
+ (sqlite3:for-each-row
+ (lambda (state count)
+ (if (string? state)
+ (let* ((stateparts (string-split state "|"))
+ (newstate (conc (car stateparts) "\n" (cadr stateparts))))
+ (hash-table-set! totals newstate (+ (hash-table-ref/default totals newstate 0) count))
+ (set! res (cons (list run-name newstate count) res)))))
+ (db:get-db dbstruct run-id)
+ "SELECT state||'|'||status AS s,count(id) FROM tests AS t ORDER BY s DESC;" )
;; (set! res (reverse res))
(for-each (lambda (state)
(set! res (cons (list "Totals" state (hash-table-ref totals state)) res)))
- (sort (hash-table-keys totals) string>=))
+ (sort (hash-table-keys totals) string>=))))
+ runs-info)
res))
;; db:get-runs-by-patt
;; get runs by list of criteria
;; register a test run with the db
;;
-;; Use: (db-get-value-by-header (db:get-header runinfo)(db:get-row runinfo))
+;; Use: (db:get-value-by-header (db:get-header runinfo)(db:get-rows runinfo))
;; to extract info from the structure returned
;;
-(define (db:get-runs-by-patt db keys runnamepatt targpatt offset limit) ;; test-name)
+(define (db:get-runs-by-patt dbstruct keys runnamepatt targpatt offset limit) ;; test-name)
(let* ((tmp (runs:get-std-run-fields keys '("id" "runname" "state" "status" "owner" "event_time")))
(keystr (car tmp))
(header (cadr tmp))
(res '())
(key-patt "")
@@ -836,76 +1090,70 @@
(set! key-patt (conc key-patt " AND " key " " wildtype " '" patt "'"))
(begin
(debug:print 0 "ERROR: searching for runs with no pattern set for " fulkey)
(exit 6)))))
keyvals)
- (set! qry-str (conc "SELECT " keystr " FROM runs WHERE state != 'deleted' AND runname " runwildtype " ? " key-patt " ORDER BY event_time"
+ (set! qry-str (conc "SELECT " keystr " FROM runs WHERE state != 'deleted' AND runname " runwildtype " ? " key-patt " ORDER BY event_time "
(if limit (conc " LIMIT " limit) "")
(if offset (conc " OFFSET " offset) "")
";"))
(debug:print-info 4 "runs:get-runs-by-patt qry=" qry-str " " runnamepatt)
- (sqlite3:for-each-row
- (lambda (a . r)
- (set! res (cons (list->vector (cons a r)) res)))
- db
- qry-str
- runnamepatt)
+ (db:with-db dbstruct #f #f ;; reads db, does not write to it.
+ (lambda (db)
+ (sqlite3:for-each-row
+ (lambda (a . r)
+ (set! res (cons (list->vector (cons a r)) res)))
+ (db:get-db dbstruct #f)
+ qry-str
+ runnamepatt)))
(vector header res)))
-;; use (get-value-by-header (db:get-header runinfo)(db:get-row runinfo))
-(define (db:get-run-info db run-id)
+;; use (get-value-by-header (db:get-header runinfo)(db:get-rows runinfo))
+(define (db:get-run-info dbstruct run-id)
;;(if (hash-table-ref/default *run-info-cache* run-id #f)
;; (hash-table-ref *run-info-cache* run-id)
- (let* ((res #f)
- (keys (db:get-keys db))
+ (let* ((res (vector #f #f #f #f))
+ (keys (db:get-keys dbstruct))
(remfields (list "id" "runname" "state" "status" "owner" "event_time"))
(header (append keys remfields))
(keystr (conc (keys->keystr keys) ","
(string-intersperse remfields ","))))
(debug:print-info 11 "db:get-run-info run-id: " run-id " header: " header " keystr: " keystr)
(sqlite3:for-each-row
(lambda (a . x)
(set! res (apply vector a x)))
- db
+ (db:get-db dbstruct #f)
(conc "SELECT " keystr " FROM runs WHERE id=? AND state != 'deleted';")
run-id)
(debug:print-info 11 "db:get-run-info run-id: " run-id " header: " header " keystr: " keystr)
(let ((finalres (vector header res)))
;; (hash-table-set! *run-info-cache* run-id finalres)
finalres)))
-(define (db:set-comment-for-run db run-id comment)
- (debug:print-info 11 "db:set-comment-for-run START run-id: " run-id " comment: " comment)
- (sqlite3:execute db "UPDATE runs SET comment=? WHERE id=?;" comment run-id)
- (debug:print-info 11 "db:set-comment-for-run END run-id: " run-id " comment: " comment))
+(define (db:set-comment-for-run dbstruct run-id comment)
+ (sqlite3:execute (db:get-db dbstruct #f) "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 db run-id)
- (common:clear-caches) ;; don't trust caches after doing any deletion
+(define (db:delete-run dbstruct run-id)
;; First set any related tests to DELETED
- (let ((stmt1 (sqlite3:prepare db "UPDATE tests SET state='DELETED',comment='' WHERE run_id=?;"))
- (stmt2 (sqlite3:prepare db "UPDATE runs SET state='deleted',comment='' WHERE id=?;")))
- (sqlite3:with-transaction
- db (lambda ()
- (sqlite3:execute stmt1 run-id)
- (sqlite3:execute stmt2 run-id)))
- (sqlite3:finalize! stmt1)
- (sqlite3:finalize! stmt2)))
-;; (sqlite3:execute db "DELETE FROM runs WHERE id=?;" run-id))
-
-(define (db:update-run-event_time db run-id)
- (debug:print-info 11 "db:update-run-event_time START run-id: " run-id)
- (sqlite3:execute db "UPDATE runs SET event_time=strftime('%s','now') WHERE id=?;" run-id)
- (debug:print-info 11 "db:update-run-event_time END run-id: " run-id))
-
-(define (db:lock/unlock-run db run-id lock unlock user)
+ (let ((db (db:get-db dbstruct run-id)))
+ (sqlite3:execute db "UPDATE tests SET state='DELETED',comment='';")
+ (sqlite3:execute db "DELETE FROM test_steps;")
+ (sqlite3:execute db "DELETE FROM test_data;")
+ (sqlite3:execute (db:get-db dbstruct #f) "UPDATE runs SET state='deleted',comment='' WHERE id=?;" run-id)))
+
+(define (db:update-run-event_time dbstruct run-id)
+ (sqlite3:execute (db:get-db dbstruct #f) "UPDATE runs SET event_time=strftime('%s','now') WHERE id=?;" run-id))
+
+(define (db:lock/unlock-run dbstruct run-id lock unlock user)
(let ((newlockval (if lock "locked"
(if unlock
"unlocked"
"locked")))) ;; semi-failsafe
- (sqlite3:execute db "UPDATE runs SET state=? WHERE id=?;" newlockval run-id)
- (sqlite3:execute db "INSERT INTO access_log (user,accessed,args) VALUES(?,strftime('%s','now'),?);"
+ (sqlite3:execute (db:get-db dbstruct #f) "UPDATE runs SET state=? WHERE id=?;" newlockval run-id)
+ (sqlite3:execute (db:get-db dbstruct #f) "INSERT INTO access_log (user,accessed,args) VALUES(?,strftime('%s','now'),?);"
user (conc newlockval " " run-id))
(debug:print-info 1 "" newlockval " run number " run-id)))
(define (db:set-run-status db run-id status #!key (msg #f))
(if msg
@@ -920,144 +1168,146 @@
db
"SELECT status FROM runs WHERE id=?;"
run-id)
res))
-(define (db:get-run-ids db)
- (let ((res '()))
- (sqlite3:for-each-row
- (lambda (id)
- (set! res (cons id res)))
- db
- "SELECT id FROM runs;")))
-
;;======================================================================
;; K E Y S
;;======================================================================
;; get key val pairs for a given run-id
;; ( (FIELDNAME1 keyval1) (FIELDNAME2 keyval2) ... )
-(define (db:get-key-val-pairs db run-id)
- (let* ((keys (db:get-keys db))
+(define (db:get-key-val-pairs dbstruct run-id)
+ (let* ((keys (db:get-keys dbstruct))
(res '()))
- (debug:print-info 11 "db:get-key-val-pairs START keys: " keys " run-id: " run-id)
(for-each
(lambda (key)
(let ((qry (conc "SELECT " key " FROM runs WHERE id=?;")))
;; (debug:print 0 "qry: " qry)
(sqlite3:for-each-row
(lambda (key-val)
(set! res (cons (list key key-val) res)))
- db qry run-id)))
+ (db:get-db dbstruct #f) qry run-id)))
keys)
- (debug:print-info 11 "db:get-key-val-pairs END keys: " keys " run-id: " run-id)
(reverse res)))
;; get key vals for a given run-id
-(define (db:get-key-vals db run-id)
- (let ((mykeyvals (hash-table-ref/default *keyvals* run-id #f)))
- (if mykeyvals
- mykeyvals
- (let* ((keys (db:get-keys db))
- (res '()))
- (debug:print-info 11 "db:get-key-vals START keys: " keys " run-id: " run-id)
- (for-each
- (lambda (key)
- (let ((qry (conc "SELECT " key " FROM runs WHERE id=?;")))
- ;; (debug:print 0 "qry: " qry)
- (sqlite3:for-each-row
- (lambda (key-val)
- (set! res (cons key-val res)))
- db qry run-id)))
- keys)
- (debug:print-info 11 "db:get-key-vals END keys: " keys " run-id: " run-id)
- (let ((final-res (reverse res)))
- (hash-table-set! *keyvals* run-id final-res)
- final-res)))))
+(define (db:get-key-vals dbstruct run-id)
+ (let* ((keys (db:get-keys dbstruct))
+ (res '()))
+ (for-each
+ (lambda (key)
+ (let ((qry (conc "SELECT " key " FROM runs WHERE id=?;")))
+ (sqlite3:for-each-row
+ (lambda (key-val)
+ (set! res (cons key-val res)))
+ (db:get-db dbstruct #f) qry run-id)))
+ keys)
+ (let ((final-res (reverse res)))
+ (hash-table-set! *keyvals* run-id final-res)
+ final-res)))
;; The target is keyval1/keyval2..., cached in *target* as it is used often
-(define (db:get-target db run-id)
- (let ((mytarg (hash-table-ref/default *target* run-id #f)))
- (if mytarg
- mytarg
- (let* ((keyvals (db:get-key-vals db run-id))
- (thekey (string-intersperse (map (lambda (x)(if x x "-na-")) keyvals) "/")))
- (hash-table-set! *target* run-id thekey)
- thekey))))
+(define (db:get-target dbstruct run-id)
+ (let* ((keyvals (db:get-key-vals dbstruct run-id))
+ (thekey (string-intersperse (map (lambda (x)(if x x "-na-")) keyvals) "/")))
+ thekey))
+
+;; Get run-ids for runs with same target but different runnames and NOT run-id
+;;
+(define (db:get-prev-run-ids dbstruct run-id)
+ (let* ((keyvals (rmt:get-key-val-pairs run-id))
+ (kvalues (map cadr keyvals))
+ (keys (rmt:get-keys))
+ (qrystr (string-intersperse (map (lambda (x)(conc x "=?")) keys) " AND ")))
+ (let ((prev-run-ids '()))
+ (db:with-db dbstruct #f #f ;; #f means work with the zeroth db - i.e. the runs db
+ (lambda (db)
+ (apply sqlite3:for-each-row
+ (lambda (id)
+ (set! prev-run-ids (cons id prev-run-ids)))
+ db
+ (conc "SELECT id FROM runs WHERE " qrystr " AND state != 'deleted' AND id != ?;") (append kvalues (list run-id)))))
+ prev-run-ids)))
;;======================================================================
;; T E S T S
;;======================================================================
;; states and statuses are lists, turn them into ("PASS","FAIL"...) and use NOT IN
;; i.e. these lists define what to NOT show.
;; states and statuses are required to be lists, empty is ok
;; not-in #t = above behaviour, #f = must match
-(define (db:get-tests-for-run db run-id testpatt states statuses offset limit not-in sort-by sort-order
- #!key
- (qryvals #f))
- (let* ((qryvalstr (case qryvals
- ((shortlist) "id,run_id,testname,item_path,state,status")
- ((#f) "id,run_id,testname,state,status,event_time,host,cpuload,diskfree,uname,rundir,item_path,run_duration,final_logf,comment")
- (else qryvals)))
- (res '())
- ;; if states or statuses are null then assume match all when not-in is false
- (states-qry (if (null? states)
- #f
- (conc " state "
- (if not-in
- " NOT IN ('"
- " IN ('")
- (string-intersperse states "','")
- "')")))
- (statuses-qry (if (null? statuses)
- #f
- (conc " status "
- (if not-in
- " NOT IN ('"
- " IN ('")
- (string-intersperse statuses "','")
- "')")))
- (states-statuses-qry
- (cond
- ((and states-qry statuses-qry)
- (conc " AND ( " states-qry " AND " statuses-qry " ) "))
- (states-qry
- (conc " AND " states-qry))
- (statuses-qry
- (conc " AND " statuses-qry))
- (else "")))
- (tests-match-qry (tests:match->sqlqry testpatt))
- (qry (conc "SELECT " qryvalstr
- " FROM tests WHERE run_id=? AND state != 'DELETED' "
- states-statuses-qry
- (if tests-match-qry (conc " AND (" tests-match-qry ") ") "")
- (case sort-by
- ((rundir) " ORDER BY length(rundir) ")
- ((testname) (conc " ORDER BY testname " (if sort-order (conc sort-order ",") "") " item_path "))
- ((statestatus) (conc " ORDER BY state " (if sort-order (conc sort-order ",") "") " status "))
- ((event_time) " ORDER BY event_time ")
- (else (if (string? sort-by)
- (conc " ORDER BY " sort-by)
- "")))
- (if sort-order sort-order "")
- (if limit (conc " LIMIT " limit) "")
- (if offset (conc " OFFSET " offset) "")
- ";"
- )))
- (debug:print-info 8 "db:get-tests-for-run qry=" qry)
- (sqlite3:for-each-row
- (lambda (a . b) ;; id run-id testname state status event-time host cpuload diskfree uname rundir item-path run-duration final-logf comment)
- (set! res (cons (apply vector a b) res))) ;; id run-id testname state status event-time host cpuload diskfree uname rundir item-path run-duration final-logf comment) res)))
- db
- qry
- run-id
- )
- (case qryvals
- ((shortlist)(map db:test-short-record->norm res))
- ((#f) res)
- (else res))))
+(define (db:get-tests-for-run dbstruct run-id testpatt states statuses offset limit not-in sort-by sort-order qryvals)
+ (if (not (number? run-id))
+ (begin
+ (debug:print 0 "ERROR: call to db:get-tests-for-run with bad run-id=" run-id)
+ (print-call-chain)
+ '())
+ (let* ((qryvalstr (case qryvals
+ ((shortlist) "id,run_id,testname,item_path,state,status")
+ ((#f) db:test-record-qry-selector) ;; "id,run_id,testname,state,status,event_time,host,cpuload,diskfree,uname,rundir,item_path,run_duration,final_logf,comment")
+ (else qryvals)))
+ (res '())
+ ;; if states or statuses are null then assume match all when not-in is false
+ (states-qry (if (null? states)
+ #f
+ (conc " state "
+ (if not-in
+ " NOT IN ('"
+ " IN ('")
+ (string-intersperse states "','")
+ "')")))
+ (statuses-qry (if (null? statuses)
+ #f
+ (conc " status "
+ (if not-in
+ " NOT IN ('"
+ " IN ('")
+ (string-intersperse statuses "','")
+ "')")))
+ (states-statuses-qry
+ (cond
+ ((and states-qry statuses-qry)
+ (conc " AND ( " states-qry " AND " statuses-qry " ) "))
+ (states-qry
+ (conc " AND " states-qry))
+ (statuses-qry
+ (conc " AND " statuses-qry))
+ (else "")))
+ (tests-match-qry (tests:match->sqlqry testpatt))
+ (qry (conc "SELECT " qryvalstr
+ " FROM tests WHERE run_id=? AND state != 'DELETED' "
+ states-statuses-qry
+ (if tests-match-qry (conc " AND (" tests-match-qry ") ") "")
+ (case sort-by
+ ((rundir) " ORDER BY length(rundir) ")
+ ((testname) (conc " ORDER BY testname " (if sort-order (conc sort-order ",") "") " item_path "))
+ ((statestatus) (conc " ORDER BY state " (if sort-order (conc sort-order ",") "") " status "))
+ ((event_time) " ORDER BY event_time ")
+ (else (if (string? sort-by)
+ (conc " ORDER BY " sort-by " ")
+ " ")))
+ (if sort-order sort-order " ")
+ (if limit (conc " LIMIT " limit) " ")
+ (if offset (conc " OFFSET " offset) " ")
+ ";"
+ )))
+ (debug:print-info 8 "db:get-tests-for-run run-id=" run-id ", qry=" qry)
+ (db:with-db dbstruct run-id #f
+ (lambda (db)
+ (sqlite3:for-each-row
+ (lambda (a . b) ;; id run-id testname state status event-time host cpuload diskfree uname rundir item-path run-duration final-logf comment)
+ (set! res (cons (apply vector a b) res))) ;; id run-id testname state status event-time host cpuload diskfree uname rundir item-path run-duration final-logf comment) res)))
+ db
+ qry
+ run-id
+ )))
+ (case qryvals
+ ((shortlist)(map db:test-short-record->norm res))
+ ((#f) res)
+ (else res)))))
(define (db:test-short-record->norm inrec)
;; "id,run_id,testname,item_path,state,status"
;; "id,run_id,testname,state,status,event_time,host,cpuload,diskfree,uname,rundir,item_path,run_duration,final_logf,comment
(vector (vector-ref inrec 0) ;; id
@@ -1068,507 +1318,446 @@
-1 "" -1 -1 "" "-"
(vector-ref inrec 3) ;; item-path
-1 "-" "-"))
-(define (db:get-tests-for-run-state-status db run-id testpatt)
- (let ((res '())
- (tests-match-qry (tests:match->sqlqry testpatt)))
- (sqlite3:for-each-row
- (lambda (id testname item-path state status)
- ;; id,run_id,testname,state,status,event_time,host,cpuload,diskfree,uname,rundir,item_path,run_duration,final_logf,comment
- (set! res (cons (vector id run-id testname state status -1 "" -1 -1 "" "-" item-path -1 "-" "-") res)))
- db
- (conc "SELECT id,testname,item_path,state,status FROM tests WHERE run_id=? "
- (if tests-match-qry (conc " AND (" tests-match-qry ") ") ""))
- run-id)
+(define (db:get-tests-for-run-state-status dbstruct run-id testpatt)
+ (let* ((res '())
+ (tests-match-qry (tests:match->sqlqry testpatt))
+ (qry (conc "SELECT id,testname,item_path,state,status FROM tests WHERE run_id=? "
+ (if tests-match-qry (conc " AND (" tests-match-qry ") ") ""))))
+ (debug:print-info 8 "db:get-tests-for-run qry=" qry)
+ (db:with-db dbstruct run-id #f
+ (lambda (db)
+ (sqlite3:for-each-row
+ (lambda (id testname item-path state status)
+ ;; id,run_id,testname,state,status,event_time,host,cpuload,diskfree,uname,rundir,item_path,run_duration,final_logf,comment
+ (set! res (cons (vector id run-id testname state status -1 "" -1 -1 "" "-" item-path -1 "-" "-") res)))
+ db
+ qry
+ run-id)))
res))
-(define (db:get-testinfo-state-status db test-id)
+(define (db:get-testinfo-state-status dbstruct run-id test-id)
(let ((res #f))
- (sqlite3:for-each-row
- (lambda (run-id testname item-path state status)
- ;; id,run_id,testname,state,status,event_time,host,cpuload,diskfree,uname,rundir,item_path,run_duration,final_logf,comment
- (set! res (vector test-id run-id testname state status -1 "" -1 -1 "" "-" item-path -1 "-" "-")))
- db
- "SELECT run_id,testname,item_path,state,status FROM tests WHERE id=?;"
- test-id)
+ (db:with-db dbstruct run-id #f
+ (lambda (db)
+ (sqlite3:for-each-row
+ (lambda (run-id testname item-path state status)
+ ;; id,run_id,testname,state,status,event_time,host,cpuload,diskfree,uname,rundir,item_path,run_duration,final_logf,comment
+ (set! res (vector test-id run-id testname state status -1 "" -1 -1 "" "-" item-path -1 "-" "-")))
+ db
+ "SELECT run_id,testname,item_path,state,status FROM tests WHERE id=?;"
+ test-id)))
res))
;; get a useful subset of the tests data (used in dashboard
;; use db:mintests-get-{id ,run_id,testname ...}
-(define (db:get-tests-for-runs-mindata db run-ids testpatt states status not-in)
- (db:get-tests-for-runs db run-ids testpatt states status not-in: not-in qryvals: "id,run_id,testname,state,status,event_time,item_path"))
-
-
-;; NB // This is get tests for "runs" (note the plural!!)
-;;
-;; states and statuses are lists, turn them into ("PASS","FAIL"...) and use NOT IN
-;; i.e. these lists define what to NOT show.
-;; states and statuses are required to be lists, empty is ok
-;; not-in #t = above behaviour, #f = must match
-;; run-ids is a list of run-ids or a single number or #f for all runs
-(define (db:get-tests-for-runs db run-ids testpatt states statuses
- #!key (not-in #t)
- (sort-by #f)
- (qryvals "id,run_id,testname,state,status,event_time,host,cpuload,diskfree,uname,rundir,item_path,run_duration,final_logf,comment")) ;; 'rundir 'event_time
- (let* ((res '())
- ;; if states or statuses are null then assume match all when not-in is false
- (states-qry (if (null? states)
- #f
- (conc " state "
- (if not-in "NOT" "")
- " IN ('"
- (string-intersperse states "','")
- "')")))
- (statuses-qry (if (null? statuses)
- #f
- (conc " status "
- (if not-in "NOT" "")
- " IN ('"
- (string-intersperse statuses "','")
- "')")))
- (tests-match-qry (tests:match->sqlqry testpatt))
- (qry (conc "SELECT " qryvals
- " FROM tests WHERE state != 'DELETED' "
- (if run-ids
- (if (list? run-ids)
- (conc "AND run_id IN (" (string-intersperse (map conc run-ids) ",") ") ")
- (conc "AND run_id=" run-ids " "))
- " ") ;; #f => run-ids don't filter on run-ids
- (if states-qry (conc " AND " states-qry) "")
- (if statuses-qry (conc " AND " statuses-qry) "")
- (if tests-match-qry (conc " AND (" tests-match-qry ") ") "")
- (case sort-by
- ((rundir) " ORDER BY length(rundir) DESC;")
- ((event_time) " ORDER BY event_time ASC;")
- (else ";"))
- )))
- (debug:print-info 8 "db:get-tests-for-runs qry=" qry)
- (sqlite3:for-each-row
- (lambda (a . b) ;; id run-id testname state status event-time host cpuload diskfree uname rundir item-path run-duration final-logf comment)
- (set! res (cons (apply vector a b) res))) ;; id run-id testname state status event-time host cpuload diskfree uname rundir item-path run-duration final-logf comment) res)))
- db
- qry
- )
+(define (db:get-tests-for-runs-mindata dbstruct run-ids testpatt states statuses not-in)
+ (db:get-tests-for-runs dbstruct run-ids testpatt states statuses not-in: not-in qryvals: "id,run_id,testname,state,status,event_time,item_path"))
+
+(define (db:get-tests-for-runs dbstruct run-ids testpatt states statuses #!key (not-in #f)(qryvals #f))
+ (let ((res '()))
+ (for-each
+ (lambda (run-id)
+ (set! res (append
+ res
+ (db:get-tests-for-run dbstruct run-id testpatt states statuses #f #f not-in #f #f qryvals))))
+ (if run-ids
+ run-ids
+ (db:get-all-run-ids dbstruct)))
res))
-;; this one is a bit broken BUG FIXME
-(define (db:delete-test-step-records db test-id #!key (work-area #f))
- ;; Breaking it into two queries for better file access interleaving
- (let* ((tdb (db:open-test-db-by-test-id db test-id work-area: work-area)))
- ;; test db's can go away - must check every time
- (if (sqlite3:database? tdb)
- (begin
- (sqlite3:execute tdb "DELETE FROM test_steps;")
- (sqlite3:execute tdb "DELETE FROM test_data;")
- (sqlite3:finalize! tdb)))))
-
-;;
-(define (db:delete-test-records db tdb test-id #!key (force #f))
- (common:clear-caches)
- (if tdb
- (begin
- (sqlite3:execute tdb "DELETE FROM test_steps;")
- (sqlite3:execute tdb "DELETE FROM test_data;")))
- ;; (sqlite3:execute db "DELETE FROM tests WHERE id=?;" test-id))
- (if db
- (begin
- (sqlite3:execute db "DELETE FROM test_steps WHERE test_id=?;" test-id)
- (sqlite3:execute db "DELETE FROM test_data WHERE test_id=?;" test-id)
- (if force
- (sqlite3:execute db "DELETE FROM tests WHERE id=?;" test-id)
- (sqlite3:execute db "UPDATE tests SET state='DELETED',status='n/a',comment='' WHERE id=?;" test-id)))))
-
-(define (db:delete-tests-for-run db run-id)
- (common:clear-caches)
- (sqlite3:execute db "DELETE FROM tests WHERE run_id=?;" run-id))
-
-(define (db:delete-old-deleted-test-records db)
- (common:clear-caches)
- (let ((targtime (- (current-seconds)(* 30 24 60 60)))) ;; one month in the past
- (sqlite3:execute db "DELETE FROM tests WHERE state='DELETED' AND event_time<?;" targtime)))
+;; 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)
+ (let ((db (db:get-db dbstruct run-id)))
+ (db:general-call db 'delete-test-step-records (list test-id))
+ (db:general-call db 'delete-test-data-records (list test-id))
+ (sqlite3:execute db "UPDATE tests SET state='DELETED',status='n/a',comment='' WHERE id=?;" test-id)))
+
+(define (db:delete-tests-for-run dbdbstruct run-id)
+ (let ((db (db:get-db dbstruct run-id)))
+ (sqlite3:execute db "DELETE FROM tests WHERE run_id=?;" run-id)))
+
+(define (db:delete-old-deleted-test-records dbstruct)
+ (let ((run-ids (db:get-all-run-ids dbstruct))
+ (targtime (- (current-seconds)(* 30 24 60 60)))) ;; one month in the past
+ (for-each
+ (lambda (run-id)
+ (sqlite3:execute (db:get-db dbstruct run-id) "DELETE FROM tests WHERE state='DELETED' AND event_time<?;" targtime))
+ run-ids)))
;; set tests with state currstate and status currstatus to newstate and newstatus
;; use currstate = #f and or currstatus = #f to apply to any state or status respectively
;; WARNING: SQL injection risk. NB// See new but not yet used "faster" version below
;;
-(define (db:set-tests-state-status db run-id testnames currstate currstatus newstate newstatus)
+(define (db:set-tests-state-status dbstruct run-id testnames currstate currstatus newstate newstatus)
(for-each (lambda (testname)
(let ((qry (conc "UPDATE tests SET state=?,status=? WHERE "
(if currstate (conc "state='" currstate "' AND ") "")
(if currstatus (conc "status='" currstatus "' AND ") "")
" run_id=? AND testname=? AND NOT (item_path='' AND testname in (SELECT DISTINCT testname FROM tests WHERE testname=? AND item_path != ''));")))
;;(debug:print 0 "QRY: " qry)
- (sqlite3:execute db qry run-id newstate newstatus testname testname)))
+ (sqlite3:execute (db:get-db dbstruct run-id) qry run-id newstate newstatus testname testname)))
testnames))
-
-(define (cdb:set-tests-state-status-faster serverdat run-id testnames currstate currstatus newstate newstatus)
- ;; Convert #f to wildcard %
- (if (null? testnames)
- #t
- (let ((currstate (if currstate currstate "%"))
- (currstatus (if currstatus currstatus "%")))
- (let loop ((hed (car testnames))
- (tal (cdr testnames))
- (thr '()))
- (let ((th1 (if newstate (create-thread (cbd:client-call serverdat 'update-test-state #t *default-numtries* newstate currstate run-id testname testname)) #f))
- (th2 (if newstatus (create-thread (cbd:client-call serverdat 'update-test-status #t *default-numtries* newstatus currstatus run-id testname testname)) #f)))
- (thread-start! th1)
- (thread-start! th2)
- (if (null? tal)
- (loop (car tal)(cdr tal)(cons th1 (cons th2 thr)))
- (for-each
- (lambda (th)
- (if th (thread-join! th)))
- thr)))))))
-
-(define (cdb:delete-tests-in-state serverdat run-id state)
- (common:clear-caches)
- (cdb:client-call serverdat 'delete-tests-in-state #t *default-numtries* run-id state))
-
-(define (cdb:tests-update-cpuload-diskfree serverdat test-id cpuload diskfree)
- (cdb:client-call serverdat 'update-cpuload-diskfree #t *default-numtries* cpuload diskfree test-id))
-
-(define (cdb:tests-update-run-duration serverdat test-id minutes)
- (cdb:client-call serverdat 'update-run-duration #t *default-numtries* minutes test-id))
-
-(define (cdb:tests-update-uname-host serverdat test-id uname hostname)
- (cdb:client-call serverdat 'update-uname-host #t *default-numtries* uname hostname test-id))
-
;; speed up for common cases with a little logic
;; NB// Ultimately this will be deprecated in deference to mt:test-set-state-status-by-id
;;
-(define (db:test-set-state-status-by-id db test-id newstate newstatus newcomment)
- (cond
- ((and newstate newstatus newcomment)
- (sqlite3:execute db "UPDATE tests SET state=?,status=?,comment=? WHERE id=?;" newstate newstatus newcomment test-id))
- ((and newstate newstatus)
- (sqlite3:execute db "UPDATE tests SET state=?,status=? WHERE id=?;" newstate newstatus test-id))
- (else
- (if newstate (sqlite3:execute db "UPDATE tests SET state=? WHERE id=?;" newstate test-id))
- (if newstatus (sqlite3:execute db "UPDATE tests SET status=? WHERE id=?;" newstatus test-id))
- (if newcomment (sqlite3:execute db "UPDATE tests SET comment=? WHERE id=?;" newcomment test-id))))
- (mt:process-triggers test-id newstate newstatus))
+(define (db:test-set-state-status-by-id dbstruct run-id test-id newstate newstatus newcomment)
+ (let ((db (db:get-db dbstruct run-id)))
+ (cond
+ ((and newstate newstatus newcomment)
+ (sqlite3:execute db "UPDATE tests SET state=?,status=?,comment=? WHERE id=?;" newstate newstatus newcomment ;; (sdb:qry 'getid newcomment)
+ test-id))
+ ((and newstate newstatus)
+ (sqlite3:execute db "UPDATE tests SET state=?,status=? WHERE id=?;" newstate newstatus test-id))
+ (else
+ (if newstate (sqlite3:execute db "UPDATE tests SET state=? WHERE id=?;" newstate test-id))
+ (if newstatus (sqlite3:execute db "UPDATE tests SET status=? WHERE id=?;" newstatus test-id))
+ (if newcomment (sqlite3:execute db "UPDATE tests SET comment=? WHERE id=?;" newcomment ;; (sdb:qry 'getid newcomment)
+ test-id))))
+ (mt:process-triggers run-id test-id newstate newstatus)))
;; Never used, but should be?
(define (db:test-set-state-status-by-run-id-testname db run-id test-name item-path status state)
(sqlite3:execute db "UPDATE tests SET state=?,status=?,event_time=strftime('%s','now') WHERE run_id=? AND testname=? AND item_path=?;"
state status run-id test-name item-path))
-(define (db:get-count-tests-running db)
- (let ((res 0))
- (sqlite3:for-each-row
- (lambda (count)
- (set! res count))
- db
- "SELECT count(id) FROM tests WHERE state in ('RUNNING','LAUNCHED','REMOTEHOSTSTART') AND run_id NOT IN (SELECT id FROM runs WHERE state='deleted');")
- res))
-
-(define (db:get-count-tests-running-for-run-id db run-id)
- (let ((res 0))
- (sqlite3:for-each-row
- (lambda (count)
- (set! res count))
- db
- "SELECT count(id) FROM tests WHERE state in ('RUNNING','LAUNCHED','REMOTEHOSTSTART') AND run_id=?;" run-id)
- res))
-
-(define (db:get-running-stats db)
- (let ((res '()))
- (sqlite3:for-each-row
- (lambda (state count)
- (set! res (cons (list state count) res)))
- db
- "SELECT state,count(id) FROM tests GROUP BY state ORDER BY id DESC;")
- res))
-
-(define (db:get-count-tests-running-in-jobgroup db jobgroup)
- (if (not jobgroup)
- 0 ;;
- (let ((res 0))
- (sqlite3:for-each-row
- (lambda (count)
- (set! res count))
- db
- "SELECT count(id) FROM tests WHERE state in ('RUNNING','LAUNCHED','REMOTEHOSTSTART')
- AND testname in (SELECT testname FROM test_meta WHERE jobgroup=?);"
- jobgroup)
- res)))
-
-;; done with run when:
-;; 0 tests in LAUNCHED, NOT_STARTED, REMOTEHOSTSTART, RUNNING
-(define (db:estimated-tests-remaining db run-id)
- (let ((res 0))
- (sqlite3:for-each-row
- (lambda (count)
- (set! res count))
- db ;; NB// KILLREQ means the jobs is still probably running
- "SELECT count(id) FROM tests WHERE state in ('LAUNCHED','NOT_STARTED','REMOTEHOSTSTART','RUNNING','KILLREQ') AND run_id=?;" run-id)
- res))
-
-;; map run-id, testname item-path to test-id
-(define (db:get-test-id-cached db run-id testname item-path)
- (let* ((test-key (conc run-id "-" testname "-" item-path))
- (res (hash-table-ref/default *test-ids* test-key #f)))
- (if res
- res
- (begin
- (sqlite3:for-each-row
- (lambda (id) ;; run-id testname state status event-time host cpuload diskfree uname rundir item-path run_duration final_logf comment )
- (set! res id)) ;; (vector id run-id testname state status event-time host cpuload diskfree uname rundir item-path run_duration final_logf comment )))
- db
- "SELECT id FROM tests WHERE run_id=? AND testname=? AND item_path=?;"
- run-id testname item-path)
- (hash-table-set! *test-ids* test-key res)
- res))))
-
-;; map run-id, testname item-path to test-id
-(define (db:get-test-id-not-cached db run-id testname item-path)
- (let* ((res #f))
- (sqlite3:for-each-row
- (lambda (id) ;; run-id testname state status event-time host cpuload diskfree uname rundir item-path run_duration final_logf comment )
- (set! res id)) ;; (vector id run-id testname state status event-time host cpuload diskfree uname rundir item-path run_duration final_logf comment )))
- db
- "SELECT id FROM tests WHERE run_id=? AND testname=? AND item_path=?;"
- run-id testname item-path)
- res))
-
-(define db:get-test-id db:get-test-id-not-cached)
-
-;; given a test-info record, patch in the latest data from the testdat.db file
-;; found in the test run directory
-;;
-;; NOT USED
-;;
-(define (db:patch-tdb-data-into-test-info db test-id res #!key (work-area #f))
- (let ((tdb (db:open-test-db-by-test-id db test-id work-area: work-area)))
- ;; get state and status from megatest.db in real time
- ;; other fields that perhaps should be updated:
- ;; fail_count
- ;; pass_count
- ;; final_logf
- (sqlite3:for-each-row
- (lambda (state status final_logf)
- (db:test-set-state! res state)
- (db:test-set-status! res status)
- (db:test-set-final_logf! res final_logf))
- db
- "SELECT state,status,final_logf FROM tests WHERE id=?;"
- test-id)
- (if tdb
- (begin
- (sqlite3:for-each-row
- (lambda (update_time cpuload disk_free run_duration)
- (db:test-set-cpuload! res cpuload)
- (db:test-set-diskfree! res disk_free)
- (db:test-set-run_duration! res run_duration))
- tdb
- "SELECT update_time,cpuload,diskfree,run_duration FROM test_rundat ORDER BY id DESC LIMIT 1;")
- (sqlite3:finalize! tdb))
- ;; if the test db is not found what to do?
- ;; 1. set state to DELETED
- ;; 2. set status to n/a
- (begin
- (db:test-set-state! res "NOT_STARTED")
- (db:test-set-status! res "n/a")))))
-
-(define *last-test-cache-delete* (current-seconds))
-
-(define (db:clean-all-caches)
- (set! *test-info* (make-hash-table))
- (set! *test-id-cache* (make-hash-table)))
-
-;; Use db:test-get* to access
-;;
-;; Get test data using test_id
-(define (db:get-test-info-by-id db test-id)
- (if (not test-id)
- (begin
- (debug:print-info 4 "db:get-test-info-by-id called with test-id=" test-id)
- #f)
- (let ((res #f))
- (sqlite3:for-each-row
- (lambda (id run-id testname state status event-time host cpuload diskfree uname rundir item-path run_duration final_logf comment)
- ;; 0 1 2 3 4 5 6 7 8 9 10 11 12 13 14
- (set! res (vector id run-id testname state status event-time host cpuload diskfree uname rundir item-path run_duration final_logf comment)))
- db
- "SELECT id,run_id,testname,state,status,event_time,host,cpuload,diskfree,uname,rundir,item_path,run_duration,final_logf,comment FROM tests WHERE id=?;"
- test-id)
- res)))
-
-;; Use db:test-get* to access
-;;
-;; Get test data using test_ids
-(define (db:get-test-info-by-ids db test-ids)
- (if (null? test-ids)
- (begin
- (debug:print-info 4 "db:get-test-info-by-ids called with test-ids=" test-ids)
- '())
- (let ((res '()))
- (sqlite3:for-each-row
- (lambda (id run-id testname state status event-time host cpuload diskfree uname rundir item-path run_duration final_logf comment)
- ;; 0 1 2 3 4 5 6 7 8 9 10 11 12 13 14
- (set! res (cons (vector id run-id testname state status event-time host cpuload diskfree uname rundir item-path run_duration final_logf comment)
- res)))
- db
- (conc "SELECT id,run_id,testname,state,status,event_time,host,cpuload,diskfree,uname,rundir,item_path,run_duration,final_logf,comment FROM tests WHERE id in ("
- (string-intersperse (map conc test-ids) ",") ");"))
- res)))
-
-(define (db:get-test-info db run-id testname item-path)
- (db:get-test-info-by-id db (db:get-test-id db run-id testname item-path)))
-
-(define (db:test-set-comment db test-id comment)
- (sqlite3:execute
- db
- "UPDATE tests SET comment=? WHERE id=?;"
- comment test-id))
-
-(define (cdb:test-set-rundir! serverdat run-id test-name item-path rundir)
- (cdb:client-call serverdat 'test-set-rundir #t *default-numtries* rundir run-id test-name item-path))
-
-(define (cdb:test-set-rundir-by-test-id serverdat test-id rundir)
- (cdb:client-call serverdat 'test-set-rundir-by-test-id #t *default-numtries* rundir test-id))
-
-(define (db:test-get-rundir-from-test-id db test-id)
- (let ((res #f)) ;; (hash-table-ref/default *test-paths* test-id #f)))
- ;; (if res
- ;; res
- ;; (begin
- (sqlite3:for-each-row
- (lambda (tpath)
- (set! res tpath))
- db
- "SELECT rundir FROM tests WHERE id=?;"
- test-id)
- ;; (hash-table-set! *test-paths* test-id res)
- res)) ;; ))
-
-(define (cdb:test-set-log! serverdat test-id logf)
- (if (string? logf)(cdb:client-call serverdat 'test-set-log #f *default-numtries* logf test-id)))
+;; NEW BEHAVIOR: Count tests running in only one run!
+;;
+(define (db:get-count-tests-running dbstruct run-id)
+ (let ((res 0))
+ (sqlite3:for-each-row
+ (lambda (count)
+ (set! res count))
+ (db:get-db dbstruct run-id)
+ "SELECT count(id) FROM tests WHERE state in ('RUNNING','LAUNCHED','REMOTEHOSTSTART') AND run_id=?;"
+ run-id) ;; NOT IN (SELECT id FROM runs WHERE state='deleted');")
+ res))
+
+;; NEW BEHAVIOR: Look only at single run with run-id
+;;
+;; (define (db:get-running-stats dbstruct run-id)
+(define (db:get-count-tests-running-for-run-id dbstruct run-id)
+ (let ((res 0))
+ (sqlite3:for-each-row
+ (lambda (count)
+ (set! res count))
+ (db:get-db dbstruct run-id)
+ "SELECT count(id) FROM tests WHERE state in ('RUNNING','LAUNCHED','REMOTEHOSTSTART') AND run_id=?;" run-id)
+ res))
+
+(define (db:get-count-tests-running-in-jobgroup dbstruct run-id jobgroup)
+ (if (not jobgroup)
+ 0 ;;
+ (let ((res 0)
+ (testnames '()))
+ ;; get the testnames
+ (sqlite3:for-each-row
+ (lambda (testname)
+ (set! testnames (cons testname testnames)))
+ (db:get-db dbstruct #f)
+ "SELECT testname FROM test_meta WHERE jobgroup=?"
+ jobgroup)
+ ;; get the jobcount NB// EXTEND THIS TO OPPERATE OVER ALL RUNS?
+ (if (not (null? testnames))
+ (sqlite3:for-each-row
+ (lambda (count)
+ (set! res count))
+ (db:get-db dbstruct run-id)
+ (conc "SELECT count(id) FROM tests WHERE state in ('RUNNING','LAUNCHED','REMOTEHOSTSTART') AND testname in ('"
+ (string-intersperse testnames "','")
+ "');")))
+ res)))
+
+;; done with run when:
+;; 0 tests in LAUNCHED, NOT_STARTED, REMOTEHOSTSTART, RUNNING
+(define (db:estimated-tests-remaining dbstruct run-id)
+ (let ((res 0))
+ (sqlite3:for-each-row
+ (lambda (count)
+ (set! res count))
+ (db:get-db dbstruct run-id) ;; NB// KILLREQ means the jobs is still probably running
+ "SELECT count(id) FROM tests WHERE state in ('LAUNCHED','NOT_STARTED','REMOTEHOSTSTART','RUNNING','KILLREQ');")
+ res))
+
+;; map run-id, testname item-path to test-id
+(define (db:get-test-id dbstruct run-id testname item-path)
+ (let* ((db (db:get-db dbstruct run-id))
+ (res #f))
+ (sqlite3:for-each-row
+ (lambda (id) ;; run-id testname state status event-time host cpuload diskfree uname rundir item-path run_duration final_logf comment )
+ (set! res id)) ;; (vector id run-id testname state status event-time host cpuload diskfree uname rundir item-path run_duration final_logf comment )))
+ (db:get-db dbstruct run-id)
+ "SELECT id FROM tests WHERE testname=? AND item_path=?;"
+ testname item-path)
+ res))
+
+(define db:test-record-fields '("id" "run_id" "testname" "state" "status" "event_time"
+ "host" "cpuload" "diskfree" "uname" "rundir" "item_path"
+ "run_duration" "final_logf" "comment" "shortdir"))
+
+(define db:test-record-qry-selector (string-intersperse db:test-record-fields ","))
+
+;; NOTE: Use db:test-get* to access records
+;; NOTE: This needs rundir decoding? Decide, decode here or where used? For the moment decode where used.
+(define (db:get-all-tests-info-by-run-id dbstruct run-id)
+ (let ((db (db:get-db dbstruct run-id))
+ (res '()))
+ (sqlite3:for-each-row
+ (lambda (id run-id testname state status event-time host cpuload diskfree uname rundir item-path run-duration final-logf comment shortdir)
+ ;; 0 1 2 3 4 5 6 7 8 9 10 11 12 13 14
+ (set! res (cons (vector id run-id testname state status event-time host cpuload diskfree uname rundir item-path run-duration final-logf comment shortdir)
+ res)))
+ (db:get-db dbstruct run-id)
+ (conc "SELECT " db:test-record-qry-selector " FROM tests WHERE state != 'DELETED' AND run_id=?;")
+ run-id)
+ res))
+
+(define (db:replace-test-records dbstruct run-id testrecs)
+ (db:with-db dbstruct run-id #t
+ (lambda (db)
+ (let* ((qmarks (string-intersperse (make-list (length db:test-record-fields) "?") ","))
+ (qrystr (conc "INSERT OR REPLACE INTO tests (" db:test-record-qry-selector ") VALUES (" qmarks ");"))
+ (qry (sqlite3:prepare db qrystr)))
+ ;; (debug:print 8 "INFO: replace-test-records, qrystr=" qrystr)
+ (for-each
+ (lambda (rec)
+ (debug:print 0 "INFO: Inserting values: " (string-intersperse (map conc (vector->list rec)) ", "))
+ (apply sqlite3:execute qry (vector->list rec)))
+ testrecs)
+ (sqlite3:finalize! qry)))))
+
+
+;; Get test data using test_id
+(define (db:get-test-info-by-id dbstruct run-id test-id)
+ (let ((db (db:get-db dbstruct run-id))
+ (res #f))
+ (sqlite3:for-each-row
+ (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)
+ ;; 0 1 2 3 4 5 6 7 8 9 10 11 12 13 14
+ (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)))
+ (db:get-db dbstruct run-id)
+ (conc "SELECT " db:test-record-qry-selector " FROM tests WHERE id=?;")
+ test-id)
+ res))
+
+;; Use db:test-get* to access
+;; Get test data using test_ids. NB// Only works within a single run!!
+;;
+(define (db:get-test-info-by-ids dbstruct run-id test-ids)
+ (let ((db (db:get-db dbstruct run-id))
+ (res '()))
+ (sqlite3:for-each-row
+ (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)
+ ;; 0 1 2 3 4 5 6 7 8 9 10 11 12 13 14
+ (set! res (cons (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)
+ res)))
+ (db:get-db dbstruct run-id)
+ (conc "SELECT " db:test-record-qry-selector " FROM tests WHERE id in ("
+ (string-intersperse (map conc test-ids) ",") ");"))
+ res))
+
+(define (db:get-test-info dbstruct run-id testname item-path)
+ (let ((db (db:get-db dbstruct run-id))
+ (res #f))
+ (sqlite3:for-each-row
+ (lambda (a . b)
+ (set! res (apply vector a b)))
+ (db:get-db dbstruct run-id)
+ (conc "SELECT " db:test-record-qry-selector " FROM tests WHERE testname=? AND item_path=?;")
+ test-name item-path)
+ res))
+
+(define (db:test-get-rundir-from-test-id dbstruct run-id test-id)
+ (let ((db (db:get-db dbstruct run-id))
+ (res #f))
+ (sqlite3:for-each-row
+ (lambda (tpath)
+ (set! res tpath))
+ (db:get-db dbstruct run-id)
+ "SELECT rundir FROM tests WHERE id=?;"
+ test-id)
+ res))
+
+;;======================================================================
+;; S T E P S
+;;======================================================================
+
+(define (db:teststep-set-status! dbstruct run-id test-id teststep-name state-in status-in comment logfile)
+ (let ((db (db:get-db dbstruct run-id)))
+ (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)
+ ;; (sdb:qry 'getid
+ (if comment comment "") ;; )
+ ;; (sdb:qry 'getid
+ (if logfile logfile "")))) ;; )
+
+;; db-get-test-steps-for-run
+(define (db:get-steps-for-test dbstruct run-id test-id)
+ (let* ((db (db:get-db dbstruct run-id))
+ (res '()))
+ (sqlite3:for-each-row
+ (lambda (id test-id stepname state status event-time logfile)
+ (set! res (cons (vector id test-id stepname state status event-time (if (string? logfile) logfile "")) res)))
+ db
+ "SELECT id,test_id,stepname,state,status,event_time,logfile FROM test_steps WHERE status != 'DELETED' AND test_id=? ORDER BY id ASC;" ;; event_time DESC,id ASC;
+ test-id)
+ (reverse res)))
+
+(define (db:get-steps-data dbstruct run-id test-id)
+ (let ((db (db:get-db dbstruct run-id))
+ (res '()))
+ (sqlite3:for-each-row
+ (lambda (id test-id stepname state status event-time logfile)
+ (set! res (cons (vector id test-id stepname state status event-time (if (string? logfile) logfile "")) res)))
+ db
+ "SELECT id,test_id,stepname,state,status,event_time,logfile FROM test_steps WHERE status != 'DELETED' AND test_id=? ORDER BY id ASC;" ;; event_time DESC,id ASC;
+ test-id)
+ (reverse res)))
+
+;;======================================================================
+;; T E S T D A T A
+;;======================================================================
+
+;; WARNING: Do NOT call this for the parent test on an iterated test
+;; Roll up test_data pass/fail results
+;; look at the test_data status field,
+;; if all are pass (any case) and the test status is PASS or NULL or '' then set test status to PASS.
+;; if one or more are fail (any case) then set test status to PASS, non "pass" or "fail" are ignored
+(define (db:test-data-rollup dbstruct run-id test-id status)
+ (let ((db (db:get-db dbstruct run-id))
+ (fail-count 0)
+ (pass-count 0))
+ (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 db '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 db 'test_data-pf-rollup (list test-id test-id test-id test-id))))
+
+(define (db:csv->test-data dbstruct run-id test-id csvdata)
+ (debug:print 4 "test-id " test-id ", csvdata: " csvdata)
+ (let ((db (db:get-db dbstruct run-id))
+ (csvlist (csv->list (make-csv-reader
+ (open-input-string csvdata)
+ '((strip-leading-whitespace? #t)
+ (strip-trailing-whitespace? #t)) )))) ;; (csv->list csvdata)))
+ (for-each
+ (lambda (csvrow)
+ (let* ((padded-row (take (append csvrow (list #f #f #f #f #f #f #f #f #f)) 9))
+ (category (list-ref padded-row 0))
+ (variable (list-ref padded-row 1))
+ (value (any->number-if-possible (list-ref padded-row 2)))
+ (expected (any->number-if-possible (list-ref padded-row 3)))
+ (tol (any->number-if-possible (list-ref padded-row 4))) ;; >, <, >=, <=, or a number
+ (units (list-ref padded-row 5))
+ (comment (list-ref padded-row 6))
+ (status (let ((s (list-ref padded-row 7)))
+ (if (and (string? s)(or (string-match (regexp "^\\s*$") s)
+ (string-match (regexp "^n/a$") s)))
+ #f
+ s))) ;; if specified on the input then use, else calculate
+ (type (list-ref padded-row 8)))
+ ;; look up expected,tol,units from previous best fit test if they are all either #f or ''
+ (debug:print 4 "BEFORE: category: " category " variable: " variable " value: " value
+ ", expected: " expected " tol: " tol " units: " units " status: " status " comment: " comment " type: " type)
+
+ (if (and (or (not expected)(equal? expected ""))
+ (or (not tol) (equal? expected ""))
+ (or (not units) (equal? expected "")))
+ (let-values (((new-expected new-tol new-units)(tdb:get-prev-tol-for-test tdb test-id category variable)))
+ (set! expected new-expected)
+ (set! tol new-tol)
+ (set! units new-units)))
+
+ (debug:print 4 "AFTER: category: " category " variable: " variable " value: " value
+ ", expected: " expected " tol: " tol " units: " units " status: " status " comment: " comment)
+ ;; calculate status if NOT specified
+ (if (and (not status)(number? expected)(number? value)) ;; need expected and value to be numbers
+ (if (number? tol) ;; if tol is a number then we do the standard comparison
+ (let* ((max-val (+ expected tol))
+ (min-val (- expected tol))
+ (result (and (>= value min-val)(<= value max-val))))
+ (debug:print 4 "max-val: " max-val " min-val: " min-val " result: " result)
+ (set! status (if result "pass" "fail")))
+ (set! status ;; NB// need to assess each one (i.e. not return operator since need to act if not valid op.
+ (case (string->symbol tol) ;; tol should be >, <, >=, <=
+ ((>) (if (> value expected) "pass" "fail"))
+ ((<) (if (< value expected) "pass" "fail"))
+ ((>=) (if (>= value expected) "pass" "fail"))
+ ((<=) (if (<= value expected) "pass" "fail"))
+ (else (conc "ERROR: bad tol comparator " tol))))))
+ (debug:print 4 "AFTER2: category: " category " variable: " variable " value: " value
+ ", expected: " expected " tol: " tol " units: " units " status: " status " comment: " comment)
+ (sqlite3:execute db "INSERT OR REPLACE INTO test_data (test_id,category,variable,value,expected,tol,units,comment,status,type) VALUES (?,?,?,?,?,?,?,?,?,?);"
+ test-id category variable value expected tol units (if comment comment "") status type)))
+ csvlist)))
;;======================================================================
;; Misc. test related queries
;;======================================================================
-;; MUST BE CALLED local!
-(define (db:test-get-paths-matching db keynames target fnamepatt #!key (res '()))
- ;; BUG: Move the values derived from args to parameters and push to megatest.scm
- (let* ((testpatt (if (args:get-arg "-testpatt")(args:get-arg "-testpatt") "%"))
- (statepatt (if (args:get-arg ":state") (args:get-arg ":state") "%"))
- (statuspatt (if (args:get-arg ":status") (args:get-arg ":status") "%"))
- (runname (if (args:get-arg ":runname") (args:get-arg ":runname") "%"))
- (paths-from-db (cdb:remote-run db:test-get-paths-matching-keynames-target-new db keynames target res
- testpatt: testpatt
- statepatt: statepatt
- statuspatt: statuspatt
- runname: runname)))
- (if fnamepatt
- (apply append
- (map (lambda (p)
- (if (directory-exists? p)
- (glob (conc p "/" fnamepatt))
- '()))
- paths-from-db))
- paths-from-db)))
-
-(define (db:test-get-paths-matching-keynames-target db keynames target res
- #!key
- (testpatt "%")
- (statepatt "%")
- (statuspatt "%")
- (runname "%"))
- (let* ((keystr (string-intersperse
- (map (lambda (key val)
- (conc "r." key " like '" val "'"))
- keynames
- (string-split target "/"))
- " AND "))
- (testqry (tests:match->sqlqry testpatt))
- (qrystr (conc "SELECT t.rundir FROM tests AS t INNER JOIN runs AS r ON t.run_id=r.id WHERE "
- keystr " AND r.runname LIKE '" runname "' AND " testqry
- " AND t.state LIKE '" statepatt "' AND t.status LIKE '" statuspatt
- "' ORDER BY t.event_time ASC;")))
- (sqlite3:for-each-row
- (lambda (p)
- (set! res (cons p res)))
- db
- qrystr)
- res))
-
-(define (db:test-get-paths-matching-keynames-target-new db keynames target res
- #!key
- (testpatt "%")
- (statepatt "%")
- (statuspatt "%")
- (runname "%"))
+(define (db:get-run-ids-matching-target dbstruct keynames target res runname testpatt statepatt statuspatt)
(let* ((row-ids '())
(keystr (string-intersperse
(map (lambda (key val)
(conc key " like '" val "'"))
keynames
(string-split target "/"))
" AND "))
- (testqry (tests:match->sqlqry testpatt))
- (runsqry (sqlite3:prepare db (conc "SELECT id FROM runs WHERE " keystr " AND runname LIKE '" runname "';")))
- (tstsqry (sqlite3:prepare db (conc "SELECT rundir FROM tests WHERE run_id=? AND " testqry " AND state LIKE '" statepatt "' AND status LIKE '" statuspatt "' ORDER BY event_time ASC;"))))
+ ;; (testqry (tests:match->sqlqry testpatt))
+ (runsqry (sqlite3:prepare (db:get-db dbstruct #f)(conc "SELECT id FROM runs WHERE " keystr " AND runname LIKE '" runname "';"))))
+ ;; (debug:print 8 "db:test-get-paths-matching-keynames-target-new\n runsqry=" runsqry "\n tstsqry=" testqry)
(sqlite3:for-each-row
(lambda (rid)
(set! row-ids (cons rid row-ids)))
runsqry)
- (for-each (lambda (rid)
- (sqlite3:for-each-row
- (lambda (p)
- (set! res (cons p res)))
- tstsqry rid))
- row-ids)
- (sqlite3:finalize! tstsqry)
(sqlite3:finalize! runsqry)
- res))
-
-;; look through tests from matching runs for a file
-(define (db:test-get-first-path-matching db keynames target fname)
- ;; [refpaths] is the section where references to other megatest databases are stored
- (let ((mt-paths (configf:get-section "refpaths"))
- (res (db:test-get-paths-matching db keynames target fname)))
- (let loop ((pathdat (if (null? paths) #f (car mt-paths)))
- (tal (if (null? paths) '()(cdr mt-paths))))
- (if (not (null? res))
- (car res) ;; return first found
- (if path
- (let* ((db (open-db path: (cadr pathdat)))
- (newres (db:test-get-paths-matching db keynames target fname)))
- (debug:print-info 4 "Trying " (car pathdat) " at " (cadr pathdat))
- (sqlite3:finalize! db)
- (if (not (null? newres))
- (car newres)
- (if (null? tal)
- #f
- (loop (car tal)(cdr tal))))))))))
+ row-ids))
+
+(define (db:test-get-paths-matching-keynames-target-new dbstruct run-id keynames target res testpatt statepatt statuspatt runname)
+ (let* ((testqry (tests:match->sqlqry testpatt))
+ (tstsqry (conc "SELECT rundir FROM tests WHERE " testqry " AND state LIKE '" statepatt "' AND status LIKE '" statuspatt "' ORDER BY event_time ASC;")))
+ (sqlite3:for-each-row
+ (lambda (p)
+ (set! res (cons p res)))
+ (db:get-db dbstruct run-id)
+ tstsqry)
+ res))
;;======================================================================
;; QUEUE UP META, TEST STATUS AND STEPS REMOTE ACCESS
;;======================================================================
;; NOTE: Can remove the regex and base64 encoding for zmq
(define (db:obj->string obj)
(case *transport-type*
- ((fs) obj)
- ((http)
+ ;; ((fs) obj)
+ ((http fs)
(string-substitute
(regexp "=") "_"
(base64:base64-encode (with-output-to-string (lambda ()(serialize obj))))
#t))
((zmq)(with-output-to-string (lambda ()(serialize obj))))
(else obj)))
(define (db:string->obj msg)
(case *transport-type*
- ((fs) msg)
- ((http)
+ ;; ((fs) msg)
+ ((http fs)
(if (string? msg)
(with-input-from-string
(base64:base64-decode
(string-substitute
(regexp "_") "=" msg #t))
@@ -1575,244 +1764,116 @@
(lambda ()(deserialize)))
(vector #f #f #f))) ;; crude reply for when things go awry
((zmq)(with-input-from-string msg (lambda ()(deserialize))))
(else msg)))
-(define (cdb:use-non-blocking-mode proc)
- (set! *client-non-blocking-mode* #t)
- (let ((res (proc)))
- (set! *client-non-blocking-mode* #f)
- res))
-
-;; params = 'target cached remparams
-;;
-;; make-vector-record cdb packet client-sig qtype immediate query-sig params qtime
-;;
-;; cdb:client-call is the unified interface to all the transports. It dispatches the
-;; query to a server routine (e.g. server:client-send-recieve) that
-;; transports the data to the server where it is passed to db:process-queue-item
-;; which either returns the data to the calling server routine or
-;; directly calls the returning procedure (e.g. zmq).
-;;
-(define (cdb:client-call serverdat qtype immediate numretries . params)
- (debug:print-info 11 "cdb:client-call serverdat=" serverdat ", qtype=" qtype ", immediate=" immediate ", numretries=" numretries ", params=" params)
- (case *transport-type*
- ((fs)
- (let ((packet (vector "na" qtype immediate "na" params 0)))
- (fs:process-queue-item packet)))
- ((http)
- (let* ((client-sig (client:get-signature))
- (query-sig (message-digest-string (md5-primitive) (conc qtype immediate params)))
- (zdat (db:obj->string (vector client-sig qtype immediate query-sig params (current-seconds))))) ;; (with-output-to-string (lambda ()(serialize params))))
- (debug:print-info 11 "zdat=" zdat)
- (let* ((res #f)
- (rawdat (http-transport:client-send-receive serverdat zdat))
- (tmp #f))
- (debug:print-info 11 "Sent " zdat ", received " rawdat)
- (if rawdat
- (begin
- (set! tmp (db:string->obj rawdat))
- (vector-ref tmp 2))
- (begin
- (debug:print 0 "ERROR: Communication with the server failed. Exiting if possible")
- (exit 1))))))
- ((zmq)
- (handle-exceptions
- exn
- (begin
- (debug:print-info 0 "cdb:client-call timeout or error. Trying again in 5 seconds")
- (thread-sleep! 5)
- (if (> numretries 0)(apply cdb:client-call serverdat qtype immediate (- numretries 1) params)))
- (let* ((push-socket (vector-ref serverdat 0))
- (sub-socket (vector-ref serverdat 1))
- (client-sig (client:get-signature))
- (query-sig (message-digest-string (md5-primitive) (conc qtype immediate params)))
- (zdat (db:obj->string (vector client-sig qtype immediate query-sig params (current-seconds)))) ;; (with-output-to-string (lambda ()(serialize params))))
- (res #f)
- (send-receive (lambda ()
- (debug:print-info 11 "sending message")
- (send-message push-socket zdat)
- (debug:print-info 11 "message sent")
- (let loop ()
- ;; get the sender info
- ;; this should match (client:get-signature)
- ;; we will need to process "all" messages here some day
- (receive-message* sub-socket)
- ;; now get the actual message
- (let ((myres (db:string->obj (receive-message* sub-socket))))
- (if (equal? query-sig (vector-ref myres 1))
- (set! res (vector-ref myres 2))
- (loop)))))))
- ;; (timeout (lambda ()
- ;; (let loop ((n numretries))
- ;; (thread-sleep! 15)
- ;; (if (not res)
- ;; (if (> numretries 0)
- ;; (begin
- ;; (debug:print 2 "WARNING: no reply to query " params ", trying resend")
- ;; (debug:print-info 11 "re-sending message")
- ;; (send-message push-socket zdat)
- ;; (debug:print-info 11 "message re-sent")
- ;; (loop (- n 1)))
- ;; ;; (apply cdb:client-call *runremote* qtype immediate (- numretries 1) params))
- ;; (begin
- ;; (debug:print 0 "ERROR: cdb:client-call timed out " params ", exiting.")
- ;; (exit 5))))))))
- (debug:print-info 11 "Starting threads")
- (let ((th1 (make-thread send-receive "send receive"))
- ;; (th2 (make-thread timeout "timeout"))
- )
- (thread-start! th1)
- ;; (thread-start! th2)
- (thread-join! th1)
- (debug:print-info 11 "cdb:client-call returning res=" res)
- res))))))
-
-(define (cdb:set-verbosity serverdat val)
- (cdb:client-call serverdat 'set-verbosity #f *default-numtries* val))
-
-(define (cdb:login serverdat keyval signature)
- (cdb:client-call serverdat 'login #t *default-numtries* keyval megatest-version signature))
-
-(define (cdb:logout serverdat keyval signature)
- (cdb:client-call serverdat 'logout #t *default-numtries* keyval signature))
-
-(define (cdb:num-clients serverdat)
- (cdb:client-call serverdat 'numclients #t *default-numtries*))
-
-;; I think this would be more efficient if executed on client side FIXME???
-(define (cdb:test-set-status-state serverdat test-id status state msg)
+(define (db:test-set-status-state dbstruct run-id test-id status state msg)
+ (let ((db (db:get-db dbstruct run-id)))
(if (member state '("LAUNCHED" "REMOTEHOSTSTART"))
- (cdb:client-call serverdat 'set-test-start-time #t *default-numtries* test-id))
+ (db:general-call db 'set-test-start-time (list test-id)))
(if msg
- (cdb:client-call serverdat 'state-status-msg #t *default-numtries* state status msg test-id)
- (cdb:client-call serverdat 'state-status #t *default-numtries* state status test-id))) ;; run-id test-name item-path minutes cpuload diskfree tmpfree)
-
-(define (cdb:test-rollup-test_data-pass-fail serverdat test-id)
- (cdb:client-call serverdat 'test_data-pf-rollup #t *default-numtries* test-id test-id test-id test-id))
-
-(define (cdb:pass-fail-counts serverdat test-id fail-count pass-count)
- (cdb:client-call serverdat 'pass-fail-counts #t *default-numtries* fail-count pass-count test-id))
-
-(define (cdb:tests-register-test serverdat run-id test-name item-path)
- (cdb:client-call serverdat 'register-test #t *default-numtries* run-id test-name item-path))
-
-;; more transactioned calls, these for roll-up-pass-fail stuff
-(define (cdb:update-pass-fail-counts serverdat run-id test-name)
- (cdb:client-call serverdat 'update-fail-pass-counts #t *default-numtries* run-id test-name run-id test-name run-id test-name))
-
-(define (cdb:top-test-set-running serverdat run-id test-name)
- (cdb:client-call serverdat 'top-test-set-running #t *default-numtries* run-id test-name))
-
-(define (cdb:top-test-set-per-pf-counts serverdat run-id test-name)
- (cdb:client-call serverdat 'top-test-set-per-pf-counts #t *default-numtries* run-id test-name run-id test-name run-id test-name))
-
-;;=
-
-(define (cdb:flush-queue serverdat)
- (cdb:client-call serverdat 'flush #f *default-numtries*))
-
-(define (cdb:kill-server serverdat pid)
- (cdb:client-call serverdat 'killserver #t *default-numtries* pid))
-
-(define (cdb:roll-up-pass-fail-counts serverdat run-id test-name item-path status)
- (cdb:client-call serverdat 'immediate #f *default-numtries* open-run-close db:roll-up-pass-fail-counts #f run-id test-name item-path status))
-
-(define (cdb:get-test-info serverdat run-id test-name item-path)
- (cdb:client-call serverdat 'immediate #f *default-numtries* open-run-close db:get-test-info #f run-id test-name item-path))
-
-(define (cdb:get-test-info-by-id serverdat test-id)
- (let ((test-dat (cdb:client-call serverdat 'immediate #f *default-numtries* open-run-close db:get-test-info-by-id #f test-id)))
- (hash-table-set! *test-info* test-id (vector (current-seconds) test-dat)) ;; cached for use where up-to-date info is not needed
- test-dat))
-
-;; db should be db open proc or #f
-(define (cdb:remote-run proc db . params)
- (if (or *db-write-access*
- (not (member proc *db:all-write-procs*)))
- (handle-exceptions
- exn
- (begin
- (debug:print 0 "Problem with call to cdb:remote-run, database may be locked and read-only, waiting and trying again ...")
- (thread-sleep! 10)
- (apply cdb:remote-run proc db params))
- (apply cdb:client-call *runremote* 'immediate #f *default-numtries* open-run-close proc #f params))
- (begin
- (debug:print 0 "ERROR: Attempt to access read-only database")
- #f)))
-
-(define (db:test-get-logfile-info db run-id test-name)
+ (db:general-call db 'state-status-msg (list state status msg test-id))
+ (db:general-call db 'state-status (list state status test-id)))))
+
+(define (db:roll-up-pass-fail-counts dbstruct run-id test-name item-path status)
+ (if (and (not (equal? item-path ""))
+ (member status '("PASS" "WARN" "FAIL" "WAIVED" "RUNNING" "CHECK" "SKIP")))
+ (let ((db (db:get-db dbstruct run-id)))
+ (db:general-call db 'update-pass-fail-counts (list test-name test-name test-name))
+ (if (equal? status "RUNNING")
+ (db:general-call db 'top-test-set-running (list test-name))
+ (db:general-call db 'top-test-set-per-pf-counts (list test-name test-name test-name)))
+ #f)
+ #f))
+
+(define (db:tests-register-test dbstruct run-id test-name item-path)
+ (sqlite3:execute (db:get-db dbstruct run-id) 'register-test run-id test-name item-path))
+
+(define (db:test-get-logfile-info dbstruct run-id test-name)
(let ((res #f))
(sqlite3:for-each-row
(lambda (path final_logf)
+ ;; (let ((path (sdb:qry 'getstr path-id))
+ ;; (final_logf (sdb:qry 'getstr final_logf-id)))
(set! logf final_logf)
(set! res (list path final_logf))
(if (directory? path)
(debug:print 2 "Found path: " path)
- (debug:print 2 "No such path: " path)))
- db
- "SELECT rundir,final_logf FROM tests WHERE run_id=? AND testname=? AND item_path='';"
- run-id test-name)
+ (debug:print 2 "No such path: " path))) ;; )
+ (db:get-db dbstruct run-id)
+ "SELECT rundir,final_logf FROM tests WHERE testname=? AND item_path='';"
+ test-name)
res))
;;======================================================================
;; A G R E G A T E D T R A N S A C T I O N D B W R I T E S
;;======================================================================
(define db:queries
- (list '(register-test "INSERT OR IGNORE INTO tests (run_id,testname,event_time,item_path,state,status) VALUES (?,?,strftime('%s','now'),?,'NOT_STARTED','n/a');")
+ (list '(update-run-duration "UPDATE tests SET run_duration=? WHERE id=?;")
+
+ ;; TESTS
+ '(register-test "INSERT OR IGNORE INTO tests (run_id,testname,event_time,item_path,state,status) VALUES (?,?,strftime('%s','now'),?,'NOT_STARTED','n/a');")
;; Test state and status
'(set-test-state "UPDATE tests SET state=? WHERE id=?;")
'(set-test-status "UPDATE tests SET state=? WHERE id=?;")
- '(state-status "UPDATE tests SET state=?,status=? WHERE id=?;")
- '(state-status-msg "UPDATE tests SET state=?,status=?,comment=? WHERE id=?;")
+ '(state-status "UPDATE tests SET state=?,status=? WHERE id=?;") ;; DONE
+ '(state-status-msg "UPDATE tests SET state=?,status=?,comment=? WHERE id=?;") ;; DONE
;; Test comment
'(set-test-comment "UPDATE tests SET comment=? WHERE id=?;")
- '(set-test-start-time "UPDATE tests SET event_time=strftime('%s','now') WHERE id=?;")
- '(pass-fail-counts "UPDATE tests SET fail_count=?,pass_count=? WHERE id=?;")
+ '(set-test-start-time "UPDATE tests SET event_time=strftime('%s','now') WHERE id=?;") ;; DONE
+ '(pass-fail-counts "UPDATE tests SET pass_count=?,fail_count=? WHERE id=?;")
;; test_data-pf-rollup is used to set a tests PASS/FAIL based on the pass/fail info from the steps
'(test_data-pf-rollup "UPDATE tests
SET status=CASE WHEN (SELECT fail_count FROM tests WHERE id=?) > 0
THEN 'FAIL'
WHEN (SELECT pass_count FROM tests WHERE id=?) > 0 AND
(SELECT status FROM tests WHERE id=?) NOT IN ('WARN','FAIL')
THEN 'PASS'
ELSE status
- END WHERE id=?;")
- '(test-set-log "UPDATE tests SET final_logf=? WHERE id=?;")
- '(test-set-rundir-by-test-id "UPDATE tests SET rundir=? WHERE id=?")
- '(test-set-rundir "UPDATE tests SET rundir=? WHERE run_id=? AND testname=? AND item_path=?;")
- '(delete-tests-in-state "DELETE FROM tests WHERE state=? AND run_id=?;")
+ END WHERE id=?;") ;; DONE
+ '(test-set-log "UPDATE tests SET final_logf=? WHERE id=?;") ;; DONE
+ ;; '(test-set-rundir-by-test-id "UPDATE tests SET rundir=? WHERE id=?") ;; DONE
+ ;; '(test-set-rundir "UPDATE tests SET rundir=? AND testname=? AND item_path=?;") ;; DONE
+ '(test-set-rundir-shortdir "UPDATE tests SET rundir=?,shortdir=? WHERE testname=? AND item_path=?;")
+ '(delete-tests-in-state "DELETE FROM tests WHERE state=?;") ;; DONE
'(tests:test-set-toplog "UPDATE tests SET final_logf=? WHERE run_id=? AND testname=? AND item_path='';")
- '(update-cpuload-diskfree "UPDATE tests SET cpuload=?,diskfree=? WHERE id=?;")
- '(update-run-duration "UPDATE tests SET run_duration=? WHERE id=?;")
- '(update-uname-host "UPDATE tests SET uname=?,host=? WHERE id=?;")
+ '(update-cpuload-diskfree "UPDATE tests SET cpuload=?,diskfree=? WHERE id=?;") ;; DONE
+ '(update-uname-host "UPDATE tests SET uname=?,host=? WHERE id=?;") ;; DONE
'(update-test-state "UPDATE tests SET state=? WHERE state=? AND run_id=? AND testname=? AND NOT (item_path='' AND testname IN (SELECT DISTINCT testname FROM tests WHERE testname=? AND item_path != ''));")
'(update-test-status "UPDATE tests SET status=? WHERE status like ? AND run_id=? AND testname=? AND NOT (item_path='' AND testname IN (SELECT DISTINCT testname FROM tests WHERE testname=? AND item_path != ''));")
;; stuff for roll-up-pass-fail-counts
- '(update-fail-pass-counts "UPDATE tests
- SET fail_count=(SELECT count(id) FROM tests WHERE run_id=? AND testname=? AND item_path != '' AND status IN ('FAIL','CHECK')),
- pass_count=(SELECT count(id) FROM tests WHERE run_id=? AND testname=? AND item_path != '' AND status IN ('PASS','WARN','WAIVED'))
- WHERE run_id=? AND testname=? AND item_path='';")
- '(top-test-set-running "UPDATE tests SET state='RUNNING' WHERE run_id=? AND testname=? AND item_path='';")
+ '(update-pass-fail-counts "UPDATE tests
+ SET fail_count=(SELECT count(id) FROM tests WHERE testname=? AND item_path != '' AND status IN ('FAIL','CHECK')),
+ pass_count=(SELECT count(id) FROM tests WHERE testname=? AND item_path != '' AND status IN ('PASS','WARN','WAIVED'))
+ WHERE testname=? AND item_path='';") ;; DONE
+ '(top-test-set-running "UPDATE tests SET state='RUNNING' WHERE testname=? AND item_path='';") ;; DONE
'(top-test-set-per-pf-counts "UPDATE tests
SET state=CASE
WHEN (SELECT count(id) FROM tests
- WHERE run_id=? AND testname=?
+ WHERE testname=?
AND item_path != ''
AND state in ('RUNNING','NOT_STARTED','LAUNCHED','REMOTEHOSTSTART')) > 0 THEN 'RUNNING'
ELSE 'COMPLETED' END,
status=CASE
WHEN fail_count > 0 THEN 'FAIL'
WHEN pass_count > 0 AND fail_count=0 THEN 'PASS'
WHEN (SELECT count(id) FROM tests
- WHERE run_id=? AND testname=?
+ WHERE testname=?
AND item_path != ''
AND status = 'SKIP') > 0 THEN 'SKIP'
ELSE 'UNKNOWN' END
- WHERE run_id=? AND testname=? AND item_path='';")
+ WHERE testname=? AND item_path='';") ;; DONE
+
+ ;; STEPS
+ '(delete-test-step-records "UPDATE test_steps SET status='DELETED' WHERE id=?;")
+ '(delete-test-data-records "UPDATE test_data SET status='DELETED' WHERE id=?;") ;; using status since no state field
))
+
+(define (db:lookup-query qry-name)
+ (let ((q (alist-ref qry-name db:queries)))
+ (if q (car q) #f)))
;; do not run these as part of the transaction
(define db:special-queries '(rollup-tests-pass-fail
;; db:roll-up-pass-fail-counts ;; WHY NOT!?
login
@@ -1821,547 +1882,126 @@
sync
set-verbosity
killserver
))
-;; not used, intended to indicate to run in calling process
-(define db:run-local-queries '()) ;; rollup-tests-pass-fail))
-
-(define (db:process-cached-writes db)
- (let ((queries (make-hash-table))
- (data #f))
- (mutex-lock! *incoming-mutex*)
- ;; data is a list of query packets <vector qry-sig query params
- (set! data (reverse *incoming-writes*)) ;; (sort ... (lambda (a b)(< (vector-ref a 1)(vector-ref b 1)))))
- (set! *server:last-write-flush* (current-milliseconds))
- (set! *incoming-writes* '())
- (mutex-unlock! *incoming-mutex*)
- (if (> (length data) 0)
- ;; Process if we have data
- (begin
- (debug:print-info 7 "Writing cached data " data)
-
- ;; Prepare the needed sql statements
- ;;
- (for-each (lambda (request-item)
- (let ((stmt-key (vector-ref request-item 0))
- (query (vector-ref request-item 1)))
- (hash-table-set! queries stmt-key (sqlite3:prepare db query))))
- data)
-
- ;; No outer loop needed. Single loop for write items only. Reads trigger flush of queue
- ;; and then are executed.
- (sqlite3:with-transaction
- db
- (lambda ()
- (for-each
- (lambda (hed)
- (let* ((params (vector-ref hed 2))
- (stmt-key (vector-ref hed 0))
- (stmt (hash-table-ref/default queries stmt-key #f)))
- (if stmt
- (apply sqlite3:execute stmt params)
- (debug:print 0 "ERROR: Problem Executing " stmt-key " for " params))))
- data)))
-
- ;; let all the waiting calls know all is done
- (mutex-lock! *completed-mutex*)
- (for-each (lambda (item)
- (let ((qry-sig (cdb:packet-get-client-sig item)))
- (debug:print-info 7 "Registering query " qry-sig " as done")
- (hash-table-set! *completed-writes* qry-sig #t)))
- data)
- (mutex-unlock! *completed-mutex*)
-
- ;; Finalize the statements. Should this be done inside the mutex above?
- ;; I think sqlite3 mutexes will keep the data safe
- (for-each (lambda (stmt-key)
- (sqlite3:finalize! (hash-table-ref queries stmt-key)))
- (hash-table-keys queries))
-
- ;; Do a little record keeping
- (let ((cache-size (length data)))
- (if (> cache-size *max-cache-size*)
- (set! *max-cache-size* cache-size)))
- #t)
- #f)))
-
-(define *db:process-queue-mutex* (make-mutex))
-
-(define *number-of-writes* 0)
-(define *writes-total-delay* 0)
-(define *total-non-write-delay* 0)
-(define *number-non-write-queries* 0)
-
-;; The queue is a list of vectors where the zeroth slot indicates the type of query to
-;; apply and the second slot is the time of the query and the third entry is a list of
-;; values to be applied
-;;
-(define (db:queue-write-and-wait db qry-sig query params)
- (let ((queue-len 0)
- (res #f)
- (got-it #f)
- (qry-pkt (vector qry-sig query params))
- (start-time (current-milliseconds))
- (timeout (+ 10 (current-seconds)))) ;; set the time out to 10 secs in future
-
- ;; Put the item in the queue *incoming-writes*
- (mutex-lock! *incoming-mutex*)
- (set! *incoming-writes* (cons qry-pkt *incoming-writes*))
- (set! queue-len (length *incoming-writes*))
- (mutex-unlock! *incoming-mutex*)
-
- (debug:print-info 7 "Current write queue length is " queue-len)
-
- ;; poll for the write to complete, timeout after 10 seconds
- ;; periodic flushing of the queue is taken care of by
- ;; db:flush-queue
- (let loop ()
- (thread-sleep! 0.001)
- (mutex-lock! *completed-mutex*)
- (if (hash-table-ref/default *completed-writes* qry-sig #f)
- (begin
- (hash-table-delete! *completed-writes* qry-sig)
- (set! got-it #t)))
- (mutex-unlock! *completed-mutex*)
- (if (and (not got-it)
- (< (current-seconds) timeout))
- (begin
- (thread-sleep! 0.01)
- (loop))))
- (set! *number-of-writes* (+ *number-of-writes* 1))
- (set! *writes-total-delay* (+ *writes-total-delay* (- (current-milliseconds) start-time)))
- got-it))
-
-(define (db:process-queue-item db item)
- (let* ((stmt-key (cdb:packet-get-qtype item))
- (qry-sig (cdb:packet-get-query-sig item))
- (return-address (cdb:packet-get-client-sig item))
- (params (cdb:packet-get-params item))
- (query (let ((q (alist-ref stmt-key db:queries)))
- (if q (car q) #f))))
- (debug:print-info 11 "Special queries/requests stmt-key=" stmt-key ", return-address=" return-address ", query=" query ", params=" params)
- (if query
- ;; hand queries off to the write queue
- (let ((response (case *transport-type*
- ((http)
- (debug:print-info 7 "Queuing item " item " for wrapped write")
- (db:queue-write-and-wait db qry-sig query params))
- (else
- (apply sqlite3:execute db query params)
- #t))))
- (debug:print-info 7 "Received " response " from wrapped write")
- (server:reply return-address qry-sig response response))
- ;; otherwise if appropriate flush the queue (this is a read or complex query)
- (begin
- (cond
- ((member stmt-key db:special-queries)
- (let ((starttime (current-milliseconds)))
- (debug:print-info 9 "Handling special statement " stmt-key)
- (case stmt-key
- ((immediate)
- ;; This is a read or mixed read-write query, must clear the cache
- (case *transport-type*
- ((http)
- (mutex-lock! *db:process-queue-mutex*)
- (db:process-cached-writes db)
- (mutex-unlock! *db:process-queue-mutex*)))
- (let* ((proc (car params))
- (remparams (cdr params))
- ;; we are being handed a procedure so call it
- ;; (debug:print-info 11 "Running (apply " proc " " remparams ")")
- (result (server:reply return-address qry-sig #t (apply proc remparams))))
- (set! *total-non-write-delay* (+ *total-non-write-delay* (- (current-milliseconds) starttime)))
- (set! *number-non-write-queries* (+ *number-non-write-queries* 1))
- result))
- ((login)
- (if (< (length params) 3) ;; should get toppath, version and signature
- (server:reply return-address qry-sig '(#f "login failed due to missing params")) ;; missing params
- (let ((calling-path (car params))
- (calling-vers (cadr params))
- (client-key (caddr params)))
- (if (and (equal? calling-path *toppath*)
- (equal? megatest-version calling-vers))
- (begin
- (hash-table-set! *logged-in-clients* client-key (current-seconds))
- (server:reply return-address qry-sig #t '(#t "successful login"))) ;; path matches - pass! Should vet the caller at this time ...
- (server:reply return-address qry-sig #f (list #f (conc "Login failed due to mismatch paths: " calling-path ", " *toppath*)))))))
- ((flush sync)
- (server:reply return-address qry-sig #t 1)) ;; (length data)))
- ((set-verbosity)
- (set! *verbosity* (car params))
- (server:reply return-address qry-sig #t (list #t *verbosity*)))
- ((killserver)
- (let ((hostname (car *runremote*))
- (port (cadr *runremote*))
- (pid (car params)))
- (debug:print 0 "WARNING: Server on " hostname ":" port " going down by user request!")
- (debug:print-info 1 "current pid=" (current-process-id))
- (open-run-close tasks:server-deregister tasks:open-db
- hostname
- port: port)
- (set! *server-run* #f)
- (thread-sleep! 3)
- (process-signal pid signal/kill)
- (server:reply return-address qry-sig #t '(#t "exit process started"))))
- (else ;; not a command, i.e. is a query
- (debug:print 0 "ERROR: Unrecognised query/command " stmt-key)
- (server:reply return-address qry-sig #f 'failed)))))
- (else
- (debug:print-info 11 "Executing " stmt-key " for " params)
- (apply sqlite3:execute (hash-table-ref queries stmt-key) params)
- (server:reply return-address qry-sig #t #t)))))))
-
-(define (db:test-get-records-for-index-file db run-id test-name)
+(define (db:login dbstruct calling-path calling-version run-id client-signature)
+ (cond
+ ((not (equal? calling-path *toppath*))
+ (list #f "Login failed due to mismatch paths: " calling-path ", " *toppath*))
+ ((not (equal? *run-id* run-id))
+ (list #f "Login failed due to mismatch run-id: " run-id ", " *run-id*))
+ ((not (equal? megatest-version calling-version))
+ (list #f "Login failed due to mismatch megatest version: " calling-version ", " megatest-version))
+ (else
+ (hash-table-set! *logged-in-clients* client-signature (current-seconds))
+ '(#t "successful login"))))
+
+(define (db:general-call db stmtname params)
+ (let ((query (let ((q (alist-ref (if (string? stmtname)
+ (string->symbol stmtname)
+ stmtname)
+ db:queries)))
+ (if q (car q) #f))))
+ (apply sqlite3:execute db query params)
+ #t))
+
+;; get the previous records for when these tests were run where all keys match but runname
+;; NB// Merge this with test:get-previous-test-run-records? This one looks for all matching tests
+;; can use wildcards. Also can likely be factored in with get test paths?
+;;
+;; Run this remotely!!
+;;
+(define (db:get-matching-previous-test-run-records dbstruct run-id test-name item-path)
+ (let* ((db (db:get-db dbstruct #f))
+ (keys (db:get-keys db))
+ (selstr (string-intersperse (map (lambda (x)(vector-ref x 0)) keys) ","))
+ (qrystr (string-intersperse (map (lambda (x)(conc (vector-ref x 0) "=?")) keys) " AND "))
+ (keyvals #f)
+ (tests-hash (make-hash-table)))
+ ;; first look up the key values from the run selected by run-id
+ (sqlite3:for-each-row
+ (lambda (a . b)
+ (set! keyvals (cons a b)))
+ db
+ (conc "SELECT " selstr " FROM runs WHERE id=? ORDER BY event_time DESC;") run-id)
+ (if (not keyvals)
+ '()
+ (let ((prev-run-ids '()))
+ (apply sqlite3:for-each-row
+ (lambda (id)
+ (set! prev-run-ids (cons id prev-run-ids)))
+ db
+ (conc "SELECT id FROM runs WHERE " qrystr " AND id != ?;") (append keyvals (list run-id)))
+ ;; collect all matching tests for the runs then
+ ;; extract the most recent test and return that.
+ (debug:print 4 "selstr: " selstr ", qrystr: " qrystr ", keyvals: " keyvals
+ ", previous run ids found: " prev-run-ids)
+ (if (null? prev-run-ids) '() ;; no previous runs? return null
+ (let loop ((hed (car prev-run-ids))
+ (tal (cdr prev-run-ids)))
+ (let ((results (db:get-tests-for-run dbstruct run-id hed (conc test-name "/" item-path) '() '() #f #f #f #f #f #f)))
+ (debug:print 4 "Got tests for run-id " run-id ", test-name " test-name
+ ", item-path " item-path " results: " (intersperse results "\n"))
+ ;; Keep only the youngest of any test/item combination
+ (for-each
+ (lambda (testdat)
+ (let* ((full-testname (conc (db:test-get-testname testdat) "/" (db:test-get-item-path testdat)))
+ (stored-test (hash-table-ref/default tests-hash full-testname #f)))
+ (if (or (not stored-test)
+ (and stored-test
+ (> (db:test-get-event_time testdat)(db:test-get-event_time stored-test))))
+ ;; this test is younger, store it in the hash
+ (hash-table-set! tests-hash full-testname testdat))))
+ results)
+ (if (null? tal)
+ (map cdr (hash-table->alist tests-hash)) ;; return a list of the most recent tests
+ (loop (car tal)(cdr tal))))))))))
+
+(define (db:test-get-records-for-index-file dbstruct run-id test-name)
(let ((res '()))
(sqlite3:for-each-row
- (lambda (id itempath state status run_duration logf comment)
+ (lambda (id itempath state status run_duration logf-id comment-id)
+ (let ((logf (db:get-string dbstruct logf-id))
+ (comment (db:get-string dbstruct comment-id)))
(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 run_id=? AND testname=? AND item_path != '';"
- run-id test-name)
- res))
+ (db:get-db dbstruct run-id)
+ "SELECT id,item_path,state,status,run_duration,final_logf,comment FROM tests WHERE testname=? AND item_path != '';"
+ test-name)
+ res)))
;;======================================================================
;; Tests meta data
;;======================================================================
;; read the record given a testname
-(define (db:testmeta-get-record db testname)
+(define (db:testmeta-get-record dbstruct testname)
(let ((res #f))
(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=?;"
+ (db:get-db dbstruct #f)
+ "SELECT id,testname,author,owner,description,reviewed,iterated,avg_runtime,avg_disk,tags,jobgroup FROM test_meta WHERE testname=?;"
testname)
res))
;; create a new record for a given testname
-(define (db:testmeta-add-record db testname)
- (sqlite3:execute db "INSERT OR IGNORE INTO test_meta (testname,author,owner,description,reviewed,iterated,avg_runtime,avg_disk,tags) VALUES (?,'','','','','','','','');" testname))
+(define (db:testmeta-add-record dbstruct testname)
+ (sqlite3:execute (db:get-db dbstruct #f) "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 db testname field value)
- (sqlite3:execute db (conc "UPDATE test_meta SET " field "=? WHERE testname=?;") value testname))
-
-;;======================================================================
-;; T E S T D A T A
-;;======================================================================
-
-(define (db:csv->test-data db test-id csvdata #!key (work-area #f))
- (debug:print 4 "test-id " test-id ", csvdata: " csvdata)
- (let ((tdb (db:open-test-db-by-test-id db test-id work-area: work-area)))
- (if (sqlite3:database? tdb)
- (let ((csvlist (csv->list (make-csv-reader
- (open-input-string csvdata)
- '((strip-leading-whitespace? #t)
- (strip-trailing-whitespace? #t)) )))) ;; (csv->list csvdata)))
- (for-each
- (lambda (csvrow)
- (let* ((padded-row (take (append csvrow (list #f #f #f #f #f #f #f #f #f)) 9))
- (category (list-ref padded-row 0))
- (variable (list-ref padded-row 1))
- (value (any->number-if-possible (list-ref padded-row 2)))
- (expected (any->number-if-possible (list-ref padded-row 3)))
- (tol (any->number-if-possible (list-ref padded-row 4))) ;; >, <, >=, <=, or a number
- (units (list-ref padded-row 5))
- (comment (list-ref padded-row 6))
- (status (let ((s (list-ref padded-row 7)))
- (if (and (string? s)(or (string-match (regexp "^\\s*$") s)
- (string-match (regexp "^n/a$") s)))
- #f
- s))) ;; if specified on the input then use, else calculate
- (type (list-ref padded-row 8)))
- ;; look up expected,tol,units from previous best fit test if they are all either #f or ''
- (debug:print 4 "BEFORE: category: " category " variable: " variable " value: " value
- ", expected: " expected " tol: " tol " units: " units " status: " status " comment: " comment " type: " type)
-
- (if (and (or (not expected)(equal? expected ""))
- (or (not tol) (equal? expected ""))
- (or (not units) (equal? expected "")))
- (let-values (((new-expected new-tol new-units)(db:get-prev-tol-for-test db test-id category variable)))
- (set! expected new-expected)
- (set! tol new-tol)
- (set! units new-units)))
-
- (debug:print 4 "AFTER: category: " category " variable: " variable " value: " value
- ", expected: " expected " tol: " tol " units: " units " status: " status " comment: " comment)
- ;; calculate status if NOT specified
- (if (and (not status)(number? expected)(number? value)) ;; need expected and value to be numbers
- (if (number? tol) ;; if tol is a number then we do the standard comparison
- (let* ((max-val (+ expected tol))
- (min-val (- expected tol))
- (result (and (>= value min-val)(<= value max-val))))
- (debug:print 4 "max-val: " max-val " min-val: " min-val " result: " result)
- (set! status (if result "pass" "fail")))
- (set! status ;; NB// need to assess each one (i.e. not return operator since need to act if not valid op.
- (case (string->symbol tol) ;; tol should be >, <, >=, <=
- ((>) (if (> value expected) "pass" "fail"))
- ((<) (if (< value expected) "pass" "fail"))
- ((>=) (if (>= value expected) "pass" "fail"))
- ((<=) (if (<= value expected) "pass" "fail"))
- (else (conc "ERROR: bad tol comparator " tol))))))
- (debug:print 4 "AFTER2: category: " category " variable: " variable " value: " value
- ", expected: " expected " tol: " tol " units: " units " status: " status " comment: " comment)
- (sqlite3:execute tdb "INSERT OR REPLACE INTO test_data (test_id,category,variable,value,expected,tol,units,comment,status,type) VALUES (?,?,?,?,?,?,?,?,?,?);"
- test-id category variable value expected tol units (if comment comment "") status type)))
- csvlist)
- (sqlite3:finalize! tdb)))))
-
-;; get a list of test_data records matching categorypatt
-(define (db:read-test-data db test-id categorypatt #!key (work-area #f))
- (let ((tdb (db:open-test-db-by-test-id db test-id work-area: work-area)))
- (if (sqlite3:database? tdb)
- (let ((res '()))
- (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)))
- tdb
- "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)
- (sqlite3:finalize! tdb)
- (reverse res))
- '())))
-
-;; NOTE: Run this local with #f for db !!!
-(define (db:load-test-data db test-id #!key (work-area #f))
- (let loop ((lin (read-line)))
- (if (not (eof-object? lin))
- (begin
- (debug:print 4 lin)
- (db:csv->test-data db test-id lin work-area: work-area)
- (loop (read-line)))))
- ;; roll up the current results.
- ;; FIXME: Add the status to
- (db:test-data-rollup db test-id #f work-area: work-area))
-
-;; WARNING: Do NOT call this for the parent test on an iterated test
-;; Roll up test_data pass/fail results
-;; look at the test_data status field,
-;; if all are pass (any case) and the test status is PASS or NULL or '' then set test status to PASS.
-;; if one or more are fail (any case) then set test status to PASS, non "pass" or "fail" are ignored
-(define (db:test-data-rollup db test-id status #!key (work-area #f))
- (let ((tdb (db:open-test-db-by-test-id db test-id work-area: work-area))
- (fail-count 0)
- (pass-count 0))
- (if (sqlite3:database? tdb)
- (begin
- (sqlite3:for-each-row
- (lambda (fcount pcount)
- (set! fail-count fcount)
- (set! pass-count pcount))
- tdb
- "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)
- (sqlite3:finalize! tdb)
-
- ;; Now rollup the counts to the central megatest.db
- (cdb:pass-fail-counts *runremote* test-id fail-count pass-count)
- ;; (sqlite3:execute db "UPDATE tests SET fail_count=?,pass_count=? WHERE id=?;"
- ;; fail-count pass-count test-id)
-
- ;; The flush is not needed with the transaction based write agregation enabled. Remove these commented lines
- ;; next time you read this!
- ;;
- ;; (cdb:flush-queue *runremote*)
- ;; (thread-sleep! 1) ;; play nice with the queue by ensuring the rollup is at least 10ms later than the set
-
- ;; if the test is not FAIL then set status based on the fail and pass counts.
- (cdb:test-rollup-test_data-pass-fail *runremote* test-id)
- ;; (sqlite3:execute
- ;; db ;;; NOTE: Should this be WARN,FAIL? A WARN is not a FAIL????? BUG FIXME
- ;; "UPDATE tests
- ;; SET status=CASE WHEN (SELECT fail_count FROM tests WHERE id=?) > 0
- ;; THEN 'FAIL'
- ;; WHEN (SELECT pass_count FROM tests WHERE id=?) > 0 AND
- ;; (SELECT status FROM tests WHERE id=?) NOT IN ('WARN','FAIL')
- ;; THEN 'PASS'
- ;; ELSE status
- ;; END WHERE id=?;"
- ;; test-id test-id test-id test-id)
- ))))
-
-(define (db:get-prev-tol-for-test db test-id category variable)
- ;; Finish me?
- (values #f #f #f))
-
-;;======================================================================
-;; S T E P S
-;;======================================================================
-
-(define (db:step-get-time-as-string vec)
- (seconds->time-string (db:step-get-event_time vec)))
-
-;; db-get-test-steps-for-run
-(define (db:get-steps-for-test db test-id #!key (work-area #f))
- (let* ((tdb (db:open-test-db-by-test-id db test-id work-area: work-area))
- (res '()))
- (if (sqlite3:database? tdb)
- (handle-exceptions
- exn
- (begin
- (debug:print 0 "ERROR: error on access to testdat for test with id " test-id)
- '())
- (begin
- (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)))
- tdb
- "SELECT id,test_id,stepname,state,status,event_time,logfile FROM test_steps WHERE test_id=? ORDER BY id ASC;" ;; event_time DESC,id ASC;
- test-id)
- (sqlite3:finalize! tdb)
- (reverse res)))
- '())))
-
-;; get a pretty table to summarize steps
-;;
-(define (db:get-steps-table db test-id #!key (work-area #f))
- (let ((steps (db:get-steps-for-test db test-id work-area: work-area)))
- ;; organise the steps for better readability
- (let ((res (make-hash-table)))
- (for-each
- (lambda (step)
- (debug:print 6 "step=" step)
- (let ((record (hash-table-ref/default
- res
- (db:step-get-stepname step)
- ;; stepname start end status Duration Logfile
- (vector (db:step-get-stepname step) "" "" "" "" ""))))
- (debug:print 6 "record(before) = " record
- "\nid: " (db:step-get-id step)
- "\nstepname: " (db:step-get-stepname step)
- "\nstate: " (db:step-get-state step)
- "\nstatus: " (db:step-get-status step)
- "\ntime: " (db:step-get-event_time step))
- (case (string->symbol (db:step-get-state step))
- ((start)(vector-set! record 1 (db:step-get-event_time step))
- (vector-set! record 3 (if (equal? (vector-ref record 3) "")
- (db:step-get-status step)))
- (if (> (string-length (db:step-get-logfile step))
- 0)
- (vector-set! record 5 (db:step-get-logfile step))))
- ((end)
- (vector-set! record 2 (any->number (db:step-get-event_time step)))
- (vector-set! record 3 (db:step-get-status step))
- (vector-set! record 4 (let ((startt (any->number (vector-ref record 1)))
- (endt (any->number (vector-ref record 2))))
- (debug:print 4 "record[1]=" (vector-ref record 1)
- ", startt=" startt ", endt=" endt
- ", get-status: " (db:step-get-status step))
- (if (and (number? startt)(number? endt))
- (seconds->hr-min-sec (- endt startt)) "-1")))
- (if (> (string-length (db:step-get-logfile step))
- 0)
- (vector-set! record 5 (db:step-get-logfile step))))
- (else
- (vector-set! record 2 (db:step-get-state step))
- (vector-set! record 3 (db:step-get-status step))
- (vector-set! record 4 (db:step-get-event_time step))))
- (hash-table-set! res (db:step-get-stepname step) record)
- (debug:print 6 "record(after) = " record
- "\nid: " (db:step-get-id step)
- "\nstepname: " (db:step-get-stepname step)
- "\nstate: " (db:step-get-state step)
- "\nstatus: " (db:step-get-status step)
- "\ntime: " (db:step-get-event_time step))))
- ;; (else (vector-set! record 1 (db:step-get-event_time step)))
- (sort steps (lambda (a b)
- (cond
- ((< (db:step-get-event_time a)(db:step-get-event_time b)) #t)
- ((eq? (db:step-get-event_time a)(db:step-get-event_time b))
- (< (db:step-get-id a) (db:step-get-id b)))
- (else #f)))))
- res)))
-
-;; get a pretty table to summarize steps
-;;
-(define (db:get-steps-table-list db test-id #!key (work-area #f))
- (let ((steps (db:get-steps-for-test db test-id work-area: work-area)))
- ;; organise the steps for better readability
- (let ((res (make-hash-table)))
- (for-each
- (lambda (step)
- (debug:print 6 "step=" step)
- (let ((record (hash-table-ref/default
- res
- (db:step-get-stepname step)
- ;; stepname start end status
- (vector (db:step-get-stepname step) "" "" "" "" ""))))
- (debug:print 6 "record(before) = " record
- "\nid: " (db:step-get-id step)
- "\nstepname: " (db:step-get-stepname step)
- "\nstate: " (db:step-get-state step)
- "\nstatus: " (db:step-get-status step)
- "\ntime: " (db:step-get-event_time step))
- (case (string->symbol (db:step-get-state step))
- ((start)(vector-set! record 1 (db:step-get-event_time step))
- (vector-set! record 3 (if (equal? (vector-ref record 3) "")
- (db:step-get-status step)))
- (if (> (string-length (db:step-get-logfile step))
- 0)
- (vector-set! record 5 (db:step-get-logfile step))))
- ((end)
- (vector-set! record 2 (any->number (db:step-get-event_time step)))
- (vector-set! record 3 (db:step-get-status step))
- (vector-set! record 4 (let ((startt (any->number (vector-ref record 1)))
- (endt (any->number (vector-ref record 2))))
- (debug:print 4 "record[1]=" (vector-ref record 1)
- ", startt=" startt ", endt=" endt
- ", get-status: " (db:step-get-status step))
- (if (and (number? startt)(number? endt))
- (seconds->hr-min-sec (- endt startt)) "-1")))
- (if (> (string-length (db:step-get-logfile step))
- 0)
- (vector-set! record 5 (db:step-get-logfile step))))
- (else
- (vector-set! record 2 (db:step-get-state step))
- (vector-set! record 3 (db:step-get-status step))
- (vector-set! record 4 (db:step-get-event_time step))))
- (hash-table-set! res (db:step-get-stepname step) record)
- (debug:print 6 "record(after) = " record
- "\nid: " (db:step-get-id step)
- "\nstepname: " (db:step-get-stepname step)
- "\nstate: " (db:step-get-state step)
- "\nstatus: " (db:step-get-status step)
- "\ntime: " (db:step-get-event_time step))))
- ;; (else (vector-set! record 1 (db:step-get-event_time step)))
- (sort steps (lambda (a b)
- (cond
- ((< (db:step-get-event_time a)(db:step-get-event_time b)) #t)
- ((eq? (db:step-get-event_time a)(db:step-get-event_time b))
- (< (db:step-get-id a) (db:step-get-id b)))
- (else #f)))))
- res)))
-
-(define (db:get-compressed-steps test-id #!key (work-area #f)(tdb #f))
- (if (or (not work-area)
- (file-exists? (conc work-area "/testdat.db")))
- (let* ((comprsteps (open-run-close db:get-steps-table tdb test-id work-area: work-area)))
- (map (lambda (x)
- ;; take advantage of the \n on time->string
- (vector
- (vector-ref x 0)
- (let ((s (vector-ref x 1)))
- (if (number? s)(seconds->time-string s) s))
- (let ((s (vector-ref x 2)))
- (if (number? s)(seconds->time-string s) s))
- (vector-ref x 3) ;; status
- (vector-ref x 4)
- (vector-ref x 5))) ;; time delta
- (sort (hash-table-values comprsteps)
- (lambda (a b)
- (let ((time-a (vector-ref a 1))
- (time-b (vector-ref b 1)))
- (if (and (number? time-a)(number? time-b))
- (if (< time-a time-b)
- #t
- (if (eq? time-a time-b)
- (string<? (conc (vector-ref a 2))
- (conc (vector-ref b 2)))
- #f))
- (string<? (conc time-a)(conc time-b))))))))
- '()))
+(define (db:testmeta-update-field dbstruct testname field value)
+ (sqlite3:execute (db:get-db dbstruct #f) (conc "UPDATE test_meta SET " field "=? WHERE testname=?;") value testname))
+
+(define (db:testmeta-get-all dbstruct)
+ (let ((res '()))
+ (sqlite3:for-each-row
+ (lambda (a . b)
+ (set! res (cons (apply vector a b) res)))
+ (db:get-db dbstruct run-id)
+ "SELECT id,testname,author,owner,description,reviewed,iterated,avg_runtime,avg_disk,tags,jobgroup FROM test_meta;")
+ res))
;;======================================================================
;; M I S C M A N A G E M E N T I T E M S
;;======================================================================
@@ -2372,21 +2012,22 @@
;;
;; Note: mode 'normal means that tests must be COMPLETED and ok (i.e. PASS, WARN, CHECK, SKIP or WAIVED)
;; mode 'toplevel means that tests must be COMPLETED only
;; mode 'itemmatch or 'itemwait means that tests items must be COMPLETED and (PASS|WARN|WAIVED|CHECK) [[ NB// NOT IMPLEMENTED YET ]]
;;
-(define (db:get-prereqs-not-met run-id waitons ref-item-path #!key (mode 'normal))
+(define (db:get-prereqs-not-met dbstruct run-id waitons ref-item-path mode)
(if (or (not waitons)
(null? waitons))
'()
(let* ((unmet-pre-reqs '())
(result '()))
(for-each
(lambda (waitontest-name)
;; by getting the tests with matching name we are looking only at the matching test
;; and related sub items
- (let ((tests (cdb:remote-run db:get-tests-for-run-state-status #f run-id waitontest-name)) ;; (mt:get-tests-for-run run-id waitontest-name '() '()))
+ ;; next should be using mt:get-tests-for-run?
+ (let ((tests (db:get-tests-for-run-state-status dbstruct run-id waitontest-name))
(ever-seen #f)
(parent-waiton-met #f)
(item-waiton-met #f))
(for-each
(lambda (test)
@@ -2436,35 +2077,19 @@
(if (not ever-seen)
(set! result (append (if (null? tests)(list waitontest-name) tests) result)))))
waitons)
(delete-duplicates result))))
-(define (db:teststep-set-status! db test-id teststep-name state-in status-in comment logfile #!key (work-area #f))
- ;; db:open-test-db-by-test-id does cdb:remote-run
- (let* ((tdb (db:open-test-db-by-test-id db test-id work-area: work-area))
- (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 "WARNING: Invalid " (if status "status" "state")
- " value \"" (if status state-in status-in) "\", update your validvalues section in megatest.config"))
- (if (sqlite3:database? tdb)
- (begin
- (sqlite3:execute
- tdb
- "INSERT OR REPLACE into test_steps (test_id,stepname,state,status,event_time,comment,logfile) VALUES(?,?,?,?,?,?,?);"
- test-id teststep-name state-in status-in (current-seconds) (if comment comment "") (if logfile logfile ""))
- (sqlite3:finalize! tdb)
- #t)
- #f)))
-
;;======================================================================
;; Extract ods file from the db
;;======================================================================
+
+;; NOT REWRITTEN YET!!!!!
;; runspatt is a comma delimited list of run patterns
;; keypatt-alist must contain *all* keys with an associated pattern: '( ("KEY1" "%") .. )
-(define (db:extract-ods-file db outputfile keypatt-alist runspatt pathmod)
+(define (db:extract-ods-file dbstruct outputfile keypatt-alist runspatt pathmod)
(let* ((keysstr (string-intersperse (map car keypatt-alist) ","))
(keyqry (string-intersperse (map (lambda (p)(conc (car p) " LIKE ? ")) keypatt-alist) " AND "))
(numkeys (length keypatt-alist))
(test-ids '())
(windows (and pathmod (substring-index "\\" pathmod)))
@@ -2581,27 +2206,25 @@
;; (db:extract-ods-file db "outputfile.ods" '(("sysname" "%")("fsname" "%")("datapath" "%")) "%")
;; This is a list of all procs that write to the db
;;
-(define *db:all-write-procs*
- (list
- db:set-var
- db:del-var
- db:register-run
- db:set-comment-for-run
- db:delete-run
- db:update-run-event_time
- db:lock/unlock-run
- db:delete-test-step-records
- db:delete-test-records
- db:delete-tests-for-run
- db:delete-old-deleted-test-records
- db:set-tests-state-status
- db:test-set-state-status-by-id
- db:test-set-state-status-by-run-id-testname
- db:test-set-comment
- db:testmeta-add-record
- db:csv->test-data
- db:test-data-rollup
- db:teststep-set-status! ))
+;; (define *db:all-write-procs*
+;; (list
+;; db:set-var
+;; db:del-var
+;; db:register-run
+;; db:set-comment-for-run
+;; db:delete-run
+;; db:update-run-event_time
+;; db:lock/unlock-run
+;; db:delete-test-step-records
+;; db:delete-test-records
+;; db:delete-tests-for-run
+;; db:delete-old-deleted-test-records
+;; db:set-tests-state-status
+;; db:test-set-state-status-by-id
+;; db:test-set-state-status-by-run-id-testname
+;; db:testmeta-add-record
+;; db:csv->test-data
+;; ))
Index: db_records.scm
==================================================================
--- db_records.scm
+++ db_records.scm
@@ -1,5 +1,121 @@
+;;======================================================================
+;; dbstruct
+;;======================================================================
+
+;;
+;; -path-|-megatest.db
+;; |-db-|-main.db
+;; |-monitor.db
+;; |-sdb.db
+;; |-fdb.db
+;; |-1.db
+;; |-<N>.db
+;;
+;;
+;; Accessors for a dbstruct
+;;
+
+(define-inline (dbr:dbstruct-get-main vec) (vector-ref vec 0))
+(define-inline (dbr:dbstruct-get-strdb vec) (vector-ref vec 1))
+(define-inline (dbr:dbstruct-get-path vec) (vector-ref vec 2))
+(define-inline (dbr:dbstruct-get-local vec) (vector-ref vec 3))
+(define-inline (dbr:dbstruct-get-rundb vec) (vector-ref vec 4))
+(define-inline (dbr:dbstruct-get-inmem vec) (vector-ref vec 5))
+(define-inline (dbr:dbstruct-get-mtime vec) (vector-ref vec 6))
+(define-inline (dbr:dbstruct-get-rtime vec) (vector-ref vec 7))
+(define-inline (dbr:dbstruct-get-stime vec) (vector-ref vec 8))
+(define-inline (dbr:dbstruct-get-inuse vec) (vector-ref vec 9))
+(define-inline (dbr:dbstruct-get-refdb vec) (vector-ref vec 10))
+(define-inline (dbr:dbstruct-get-locdbs vec) (vector-ref vec 11))
+
+(define-inline (dbr:dbstruct-set-main! vec val)(vector-set! vec 0 val))
+(define-inline (dbr:dbstruct-set-strdb! vec val)(vector-set! vec 1 val))
+(define-inline (dbr:dbstruct-set-path! vec val)(vector-set! vec 2 val))
+(define-inline (dbr:dbstruct-set-local! vec val)(vector-set! vec 3 val))
+(define-inline (dbr:dbstruct-set-rundb! vec val)(vector-set! vec 4 val))
+(define-inline (dbr:dbstruct-set-inmem! vec val)(vector-set! vec 5 val))
+(define-inline (dbr:dbstruct-set-mtime! vec val)(vector-set! vec 6 val))
+(define-inline (dbr:dbstruct-set-rtime! vec val)(vector-set! vec 7 val))
+(define-inline (dbr:dbstruct-set-stime! vec val)(vector-set! vec 8 val))
+(define-inline (dbr:dbstruct-set-inuse! vec val)(vector-set! vec 9 val))
+(define-inline (dbr:dbstruct-set-refdb! vec val)(vector-set! vec 10 val))
+(define-inline (dbr:dbstruct-set-locdbs! vec val)(vector-set! vec 11 val))
+
+;; constructor for dbstruct
+;;
+(define (make-dbr:dbstruct #!key (path #f)(local #f))
+ (let ((v (make-vector 12 #f)))
+ (dbr:dbstruct-set-path! v path)
+ (dbr:dbstruct-set-local! v local)
+ (dbr:dbstruct-set-locdbs! v (make-hash-table))
+ v))
+
+(define (dbr:dbstruct-get-localdb v run-id)
+ (hash-table-ref/default (dbr:dbstruct-get-locdbs v) run-id #f))
+
+(define (dbr:dbstruct-set-localdb! v run-id db)
+ (hash-table-set! (dbr:dbstruct-get-locdbs v) run-id db))
+
+;; ;; get and set main db
+;; (define-inline (dbr:dbstruct-get-main vec) (vector-ref vec 0))
+;; (define-inline (dbr:dbstruct-set-main! vec db)(vector-set! vec 0 db))
+;; ;; get the runs hash
+;; (define-inline (dbr:dbstruct-get-dbhash vec) (vector-ref vec 1))
+;; ;; the string db
+;; (define-inline (dbr:dbstruct-get-strdb vec) (vector-ref vec 2))
+;; (define-inline (dbr:dbstruct-set-strdb! vec db)(vector-set! vec 2 db))
+;; ;; path
+;; (define-inline (dbr:dbstruct-get-path vec) (vector-ref vec 3))
+;; (define-inline (dbr:dbstruct-set-path! vec path)(vector-set! vec 3))
+;; ;; local
+;; (define-inline (dbr:dbstruct-get-local vec) (vector-ref vec 4))
+;; (define-inline (dbr:dbstruct-set-local! vec val)(vector-set! vec 4 val))
+;;
+;; ;; get a rundb vector, create it if not already existing
+;; (define (dbr:dbstruct-get-rundb-rec vec run-id)
+;; (let* ((dbhash (dbr:dbstruct-get-dbhash vec)) ;; get the runs hash
+;; (runvec (hash-table-ref/default dbhash run-id #f))) ;; get the vector for run-id
+;; (if (vector? runvec)
+;; runvec ;; rundb inmemdb last-mod last-read last-sync in-use refdb
+;; (let ((nvec (vector #f #f -1 -1 -1 #f #f)))
+;; (hash-table-set! dbhash run-id nvec)
+;; nvec))))
+;;
+;; ;; [ rundb inmemdb last-mod last-read last-sync ]
+;; (define-inline (dbr:dbstruct-field-name->num field-name)
+;; (case field-name
+;; ((rundb) 0) ;; the on-disk db
+;; ((inmem) 1) ;; the in-memory db
+;; ((mtime) 2) ;; last modification time
+;; ((rtime) 3) ;; last read time
+;; ((stime) 4) ;; last sync time
+;; ((inuse) 5) ;; is the db currently in use, #t yes, #f no.
+;; ((refdb) 6) ;; the db used for reference (can be on disk or inmem)
+;; (else -1)))
+;;
+;; ;; get/set rundb fields
+;; (define (dbr:dbstruct-get-runvec-val vec run-id field-name)
+;; (let ((runvec (dbr:dbstruct-get-rundb-rec vec run-id))
+;; (fieldnum (dbr:dbstruct-field-name->num field-name)))
+;; ;; (vector-set! runvec (dbr:dbstruct-field-name->num 'inuse) #t)
+;; (vector-ref runvec fieldnum)))
+;;
+;; (define (dbr:dbstruct-set-runvec-val! vec run-id field-name val)
+;; (let ((runvec (dbr:dbstruct-get-rundb-rec vec run-id)))
+;; (vector-set! runvec (dbr:dbstruct-field-name->num field-name) val)))
+;;
+;; ;; get/set inmemdb
+;; (define (dbr:dbstruct-get-inmemdb vec run-id)
+;; (let ((runvec (dbr:dbstruct-get-rundb-rec vec run-id)))
+;; (vector-ref runvec 1)))
+;;
+;; (define (dbr:dbstruct-set-inmemdb! vec run-id inmemdb)
+;; (let ((runvec (dbr:dbstruct-get-rundb-rec vec run-id)))
+;; (vector-set! runvec 1 inmemdb)))
+
+
(define (make-db:test)(make-vector 20))
(define-inline (db:test-get-id vec) (vector-ref vec 0))
(define-inline (db:test-get-run_id vec) (vector-ref vec 1))
(define-inline (db:test-get-testname vec) (vector-ref vec 2))
(define-inline (db:test-get-state vec) (vector-ref vec 3))
@@ -7,15 +123,18 @@
(define-inline (db:test-get-event_time vec) (vector-ref vec 5))
(define-inline (db:test-get-host vec) (vector-ref vec 6))
(define-inline (db:test-get-cpuload vec) (vector-ref vec 7))
(define-inline (db:test-get-diskfree vec) (vector-ref vec 8))
(define-inline (db:test-get-uname vec) (vector-ref vec 9))
+;; (define-inline (db:test-get-rundir vec) (sdb:qry 'getstr (vector-ref vec 10)))
(define-inline (db:test-get-rundir vec) (vector-ref vec 10))
(define-inline (db:test-get-item-path vec) (vector-ref vec 11))
(define-inline (db:test-get-run_duration vec) (vector-ref vec 12))
(define-inline (db:test-get-final_logf vec) (vector-ref vec 13))
(define-inline (db:test-get-comment vec) (vector-ref vec 14))
+(define-inline (db:test-get-pass_count vec) (vector-ref vec 15))
+(define-inline (db:test-get-fail_count vec) (vector-ref vec 16))
(define-inline (db:test-get-fullname vec)
(conc (db:test-get-testname vec) "/" (db:test-get-item-path vec)))
(define-inline (db:test-get-first_err vec) (printable (vector-ref vec 15)))
(define-inline (db:test-get-first_warn vec) (printable (vector-ref vec 16)))
@@ -26,14 +145,10 @@
(define-inline (db:test-set-state! vec val)(vector-set! vec 3 val))
(define-inline (db:test-set-status! vec val)(vector-set! vec 4 val))
(define-inline (db:test-set-run_duration! vec val)(vector-set! vec 12 val))
(define-inline (db:test-set-final_logf! vec val)(vector-set! vec 13 val))
-;; get rows and header from
-(define-inline (db:get-header vec)(vector-ref vec 0))
-(define-inline (db:get-rows vec)(vector-ref vec 1))
-
;; make-vector-record "" db mintest id run_id testname state status event_time item_path
;;
(define (make-db:mintest)(make-vector 7))
(define-inline (db:mintest-get-id vec) (vector-ref vec 0))
(define-inline (db:mintest-get-run_id vec) (vector-ref vec 1))
@@ -97,41 +212,38 @@
;; S T E P S
;;======================================================================
;; Run steps
;; make-vector-record "Run steps" db step id test_id stepname step_complete step_pass event_time
(define (make-db:step)(make-vector 7))
-(define-inline (db:step-get-id vec) (vector-ref vec 0))
-(define-inline (db:step-get-test_id vec) (vector-ref vec 1))
-(define-inline (db:step-get-stepname vec) (vector-ref vec 2))
-(define-inline (db:step-get-state vec) (vector-ref vec 3))
-(define-inline (db:step-get-status vec) (vector-ref vec 4))
-(define-inline (db:step-get-event_time vec) (vector-ref vec 5))
-(define-inline (db:step-get-logfile vec) (vector-ref vec 6))
-(define-inline (db:step-set-id! vec val)(vector-set! vec 0 val))
-(define-inline (db:step-set-test_id! vec val)(vector-set! vec 1 val))
-(define-inline (db:step-set-stepname! vec val)(vector-set! vec 2 val))
-(define-inline (db:step-set-state! vec val)(vector-set! vec 3 val))
-(define-inline (db:step-set-status! vec val)(vector-set! vec 4 val))
-(define-inline (db:step-set-event_time! vec val)(vector-set! vec 5 val))
-(define-inline (db:step-set-logfile! vec val)(vector-set! vec 6 val))
+(define-inline (tdb:step-get-id vec) (vector-ref vec 0))
+(define-inline (tdb:step-get-test_id vec) (vector-ref vec 1))
+(define-inline (tdb:step-get-stepname vec) (vector-ref vec 2))
+(define-inline (tdb:step-get-state vec) (vector-ref vec 3))
+(define-inline (tdb:step-get-status vec) (vector-ref vec 4))
+(define-inline (tdb:step-get-event_time vec) (vector-ref vec 5))
+(define-inline (tdb:step-get-logfile vec) (vector-ref vec 6))
+(define-inline (tdb:step-set-id! vec val)(vector-set! vec 0 val))
+(define-inline (tdb:step-set-test_id! vec val)(vector-set! vec 1 val))
+(define-inline (tdb:step-set-stepname! vec val)(vector-set! vec 2 val))
+(define-inline (tdb:step-set-state! vec val)(vector-set! vec 3 val))
+(define-inline (tdb:step-set-status! vec val)(vector-set! vec 4 val))
+(define-inline (tdb:step-set-event_time! vec val)(vector-set! vec 5 val))
+(define-inline (tdb:step-set-logfile! vec val)(vector-set! vec 6 val))
;; The steps table
(define (make-db:steps-table)(make-vector 5))
-(define-inline (db:steps-table-get-stepname vec) (vector-ref vec 0))
-(define-inline (db:steps-table-get-start vec) (vector-ref vec 1))
-(define-inline (db:steps-table-get-end vec) (vector-ref vec 2))
-(define-inline (db:steps-table-get-status vec) (vector-ref vec 3))
-(define-inline (db:steps-table-get-runtime vec) (vector-ref vec 4))
-(define-inline (db:step-stable-set-stepname! vec val)(vector-set! vec 0 val))
-(define-inline (db:step-stable-set-start! vec val)(vector-set! vec 1 val))
-(define-inline (db:step-stable-set-end! vec val)(vector-set! vec 2 val))
-(define-inline (db:step-stable-set-status! vec val)(vector-set! vec 3 val))
-(define-inline (db:step-stable-set-runtime! vec val)(vector-set! vec 4 val))
-
-;; use this one for db-get-run-info
-(define-inline (db:get-row vec)(vector-ref vec 1))
+(define-inline (tdb:steps-table-get-stepname vec) (vector-ref vec 0))
+(define-inline (tdb:steps-table-get-start vec) (vector-ref vec 1))
+(define-inline (tdb:steps-table-get-end vec) (vector-ref vec 2))
+(define-inline (tdb:steps-table-get-status vec) (vector-ref vec 3))
+(define-inline (tdb:steps-table-get-runtime vec) (vector-ref vec 4))
+(define-inline (tdb:step-stable-set-stepname! vec val)(vector-set! vec 0 val))
+(define-inline (tdb:step-stable-set-start! vec val)(vector-set! vec 1 val))
+(define-inline (tdb:step-stable-set-end! vec val)(vector-set! vec 2 val))
+(define-inline (tdb:step-stable-set-status! vec val)(vector-set! vec 3 val))
+(define-inline (tdb:step-stable-set-runtime! vec val)(vector-set! vec 4 val))
;; The data structure for handing off requests via wire
(define (make-cdb:packet)(make-vector 6))
(define-inline (cdb:packet-get-client-sig vec) (vector-ref vec 0))
(define-inline (cdb:packet-get-qtype vec) (vector-ref vec 1))
ADDED dbwars/NOTES
Index: dbwars/NOTES
==================================================================
--- /dev/null
+++ dbwars/NOTES
@@ -0,0 +1,31 @@
+Before using prepare:
+
+matt@xena:/tmp/megatest/dbwars$ ./sqlite3-test insert
+Adding 1047 test3 item/39 host0-0.3-200000-240-this one sucks eh? (added 51886 records so far)
+Adding 1122 test5 item/52 host2-0.2-200000-120-this is a good one eh? (added 78889 records so far)
+Adding 1050 test7 item/31 host1-0.1-100000-120-this is a good one eh? (added 110641 records so far)
+create-tests ran register-test 144000 times in 41.0 seconds
+
+After using prepare:
+
+matt@xena:/tmp/megatest/dbwars$ csc sqlite3-test.scm && ./sqlite3-test insert
+Adding 1082 test4 item/74 host1-0.3-100000-120-this is a good one eh? (added 61281 records so far)
+Adding 1138 test7 item/43 host2-0.3-200000-120-this is a good one eh? (added 109001 records so far)
+Adding 1023 test9 item/00 host0-0.2-100000-240-this one sucks eh? (added 143878 records so far)
+create-tests ran register-test 144000 times in 38.0 seconds
+
+After moving the prepare outside the call (so it isn't done each time):
+
+matt@xena:/tmp/megatest/dbwars$ ./sqlite3-test insert
+Adding 1042 test4 item/59 host0-0.3-200000-120-this is a good one eh? (added 63401 records so far)
+Adding 1011 test6 item/40 host0-0.1-200000-120-this one sucks eh? (added 94906 records so far)
+Adding 1076 test9 item/34 host1-0.2-200000-120-just eh, eh? (added 139035 records so far)
+create-tests ran register-test 144000 times in 33.0 seconds
+
+Using sql-de-lite with very similar code:
+
+matt@xena:/tmp/megatest/dbwars$ ./sql-de-lite-test insert
+Adding 1029 test4 item/53 host0-0.2-200000-240- (added 64252 records so far)
+Adding 1134 test7 item/64 host2-0.3-100000-240-this is a good one eh? (added 105973 records so far)
+create-tests ran register-test 144000 times in 31.0 seconds
+
ADDED dbwars/sql-de-lite-test.scm
Index: dbwars/sql-de-lite-test.scm
==================================================================
--- /dev/null
+++ dbwars/sql-de-lite-test.scm
@@ -0,0 +1,19 @@
+
+(use sql-de-lite)
+(include "test-common.scm")
+
+(define db (open-database "test.db"))
+
+(exec (sql db test-table-defn))
+(exec (sql db syncsetup))
+
+(define (register-test stmth run-id testname host cpuload diskfree uname rundir shortdir item-path state status final-logf run-duration comment event-time)
+ (exec
+ stmth ;; (sql db test-insert)
+ run-id
+ testname host cpuload diskfree uname rundir shortdir item-path state status final-logf run-duration comment event-time))
+
+(let ((stmth (sql db test-insert)))
+ (create-tests stmth))
+
+(close-database db)
ADDED dbwars/sqlite3-test.scm
Index: dbwars/sqlite3-test.scm
==================================================================
--- /dev/null
+++ dbwars/sqlite3-test.scm
@@ -0,0 +1,20 @@
+
+(use sqlite3)
+(include "test-common.scm")
+
+(define db (open-database "test.db"))
+
+(execute db test-table-defn)
+(execute db syncsetup)
+
+
+(define (register-test stmth run-id testname host cpuload diskfree uname rundir shortdir item-path state status final-logf run-duration comment event-time)
+ (execute stmth
+ run-id
+ testname host cpuload diskfree uname rundir shortdir item-path state status final-logf run-duration comment event-time))
+
+(let ((stmth (prepare db test-insert)))
+ (create-tests stmth)
+ (finalize! stmth))
+
+(finalize! db)
ADDED dbwars/test-common.scm
Index: dbwars/test-common.scm
==================================================================
--- /dev/null
+++ dbwars/test-common.scm
@@ -0,0 +1,129 @@
+(use srfi-18 srfi-69 apropos)
+
+(define args (argv))
+
+(if (not (eq? (length args) 2))
+ (begin
+ (print "Usage: sqlitecompare [insert|update]")
+ (exit 0)))
+
+(define action (string->symbol (cadr args)))
+
+(system "rm -f test.db")
+
+(define test-table-defn
+ "CREATE TABLE IF NOT EXISTS tests
+ (id INTEGER PRIMARY KEY,
+ run_id INTEGER,
+ testname TEXT,
+ host TEXT DEFAULT 'n/a',
+ cpuload REAL DEFAULT -1,
+ diskfree INTEGER DEFAULT -1,
+ uname TEXT DEFAULT 'n/a',
+ rundir TEXT DEFAULT 'n/a',
+ shortdir TEXT DEFAULT '',
+ item_path TEXT DEFAULT '',
+ state TEXT DEFAULT 'NOT_STARTED',
+ status TEXT DEFAULT 'FAIL',
+ attemptnum INTEGER DEFAULT 0,
+ final_logf TEXT DEFAULT 'logs/final.log',
+ logdat BLOB,
+ run_duration INTEGER DEFAULT 0,
+ comment TEXT DEFAULT '',
+ event_time TIMESTAMP,
+ fail_count INTEGER DEFAULT 0,
+ pass_count INTEGER DEFAULT 0,
+ archived INTEGER DEFAULT 0, -- 0=no, 1=in progress, 2=yes
+ CONSTRAINT testsconstraint UNIQUE (run_id, testname, item_path)
+ );")
+
+(define test-insert "INSERT INTO tests (run_id,testname,host,cpuload,diskfree,uname,rundir,shortdir,item_path,state,status,final_logf,run_duration,comment,event_time)
+ values (?, ?, ?, ?, ?, ?, ?, ?, ?, ?, ?, ?, ?, ?, ? );")
+(define syncsetup "PRAGMA synchronous = OFF;")
+
+(define tests '("test0" "test1" "test2" "test3" "test4" "test5" "test6" "test7" "test8" "test9"))
+(define items '())
+(for-each
+ (lambda (n)
+ (for-each
+ (lambda (m)
+ (set! items (cons (conc "item/" n m) items)))
+ '(0 1 2 3 4 5 6 7 8 9)))
+ '(0 1 2 3 4 5 6 7 8 9))
+(define hosts '("host0" "host1" "host2")) ;; "host3" "host4" "host5" "host6" "host7" "host8" "host9"))
+(define cpuloads '(0.1 0.2 0.3)) ;; 0.4 0.5 0.6 0.7 0.8 0.9))
+(define diskfrees '(100000 200000)) ;; 300000 400000 500000 600000 700000 800000 900000))
+(define uname "Linux xena 3.5.0-40-generic #62~precise1-Ubuntu SMP Fri Aug 23 17:59:10 UTC 2013 i686 i686 i386 GNU/Linux")
+(define basedir "/mfs/matt/data/megatest/runs/testing")
+(define final-logf "finallog.html")
+(define run-durations (list 120 240)) ;; 260))
+(define comments '("" "this is a good one eh?" "this one sucks eh?" "just eh, eh?"))
+
+(define run-ids (make-hash-table))
+(define max-run-id 1000)
+
+(define (test-factors->run-id host cpuload diskfree run-duration comment)
+ (let* ((factor (conc host "-" cpuload "-" diskfree "-" run-duration "-" comment))
+ (run-id (hash-table-ref/default run-ids factor #f)))
+ (if run-id
+ (list run-id factor)
+ (let ((new-id (+ max-run-id 1)))
+ (set! max-run-id new-id)
+ (hash-table-set! run-ids factor new-id)
+ (list new-id factor)))))
+
+
+(define (create-tests stmth)
+ (let ((num-created 0)
+ (last-print (current-seconds))
+ (start-time (current-seconds)))
+ (for-each
+ (lambda (test)
+ (for-each
+ (lambda (item)
+ (for-each
+ (lambda (host)
+ (for-each
+ (lambda (cpuload)
+ (for-each
+ (lambda (diskfree)
+ (for-each
+ (lambda (run-duration)
+ (for-each
+ (lambda (comment)
+ (let* ((run-id-dat (test-factors->run-id host cpuload diskfree run-duration comment))
+ (run-id (car run-id-dat))
+ (factor (cadr run-id-dat))
+ (curr-time (current-seconds)))
+ (if (> (- curr-time last-print) 10)
+ (begin
+ (print "Adding " run-id " " test " " item " " factor " (added " num-created " records so far)")
+ (set! last-print curr-time)))
+ (set! num-created (+ num-created 1))
+ (register-test stmth ;; db
+ run-id
+ test ;; testname
+ host
+ cpuload
+ diskfree
+ uname
+ (conc basedir "/" test "/" item) ;; rundir
+ (conc test "/" item) ;; shortdir
+ item ;; item-path
+ "NOT_STARTED" ;; state
+ "NA" ;; status
+ final-logf
+ run-duration
+ comment
+ (current-seconds))))
+ comments))
+ run-durations))
+ diskfrees))
+ cpuloads))
+ hosts))
+ items))
+ tests)
+ (print "create-tests ran register-test " num-created " times in " (- (current-seconds) start-time) " seconds")))
+
+
+
Index: dcommon.scm
==================================================================
--- dcommon.scm
+++ dcommon.scm
@@ -358,32 +358,32 @@
(define (dcommon:general-info)
(let ((general-matrix (iup:matrix
#:alignment1 "ALEFT"
#:expand "YES" ;; "HORIZONTAL"
#:numcol 1
- #:numlin 3
+ #:numlin 2
#:numcol-visible 1
- #:numlin-visible 3)))
- (iup:attribute-set! general-matrix "WIDTH1" "200")
+ #:numlin-visible 2)))
+ (iup:attribute-set! general-matrix "WIDTH1" "150")
(iup:attribute-set! general-matrix "0:1" "About this Megatest area")
;; User (this is not always obvious - it is common to run as a different user
(iup:attribute-set! general-matrix "1:0" "User")
(iup:attribute-set! general-matrix "1:1" (current-user-name))
;; Megatest area
- (iup:attribute-set! general-matrix "2:0" "Area")
- (iup:attribute-set! general-matrix "2:1" *toppath*)
+ ;; (iup:attribute-set! general-matrix "2:0" "Area")
+ ;; (iup:attribute-set! general-matrix "2:1" *toppath*)
;; Megatest version
- (iup:attribute-set! general-matrix "3:0" "Version")
- (iup:attribute-set! general-matrix "3:1" megatest-version)
+ (iup:attribute-set! general-matrix "2:0" "Version")
+ (iup:attribute-set! general-matrix "2:1" (conc megatest-version "-" (substring megatest-fossil-hash 0 4)))
general-matrix))
-(define (dcommon:run-stats)
+(define (dcommon:run-stats dbstruct)
(let* ((stats-matrix (iup:matrix expand: "YES"))
(changed #f)
(updater (lambda ()
- (let* ((run-stats (mt:get-run-stats))
+ (let* ((run-stats (db:get-run-stats dbstruct))
(indices (common:sparse-list-generate-index run-stats)) ;; proc: set-cell))
(row-indices (car indices))
(col-indices (cadr indices))
(max-row (if (null? row-indices) 1 (apply max (map cadr row-indices))))
(max-col (if (null? col-indices) 1
@@ -445,13 +445,13 @@
(let* ((colnum 0)
(rownum 0)
(servers-matrix (iup:matrix #:expand "YES"
#:numcol 7
#:numcol-visible 7
- #:numlin-visible 3
+ #:numlin-visible 5
))
- (colnames (list "Id" "MTver" "Pid" "Host" "Interface:OutPort" "InPort" "State" "Transport"))
+ (colnames (list "Id" "MTver" "Pid" "Host" "Interface:OutPort" "RunTime" "State" "RunId"))
(updater (lambda ()
(let ((servers (open-run-close tasks:get-all-servers tasks:open-db)))
(iup:attribute-set! servers-matrix "NUMLIN" (length servers))
;; (set! colnum 0)
;; (for-each (lambda (colname)
@@ -466,25 +466,27 @@
(let* ((vals (list (vector-ref server 0) ;; Id
(vector-ref server 9) ;; MT-Ver
(vector-ref server 1) ;; Pid
(vector-ref server 2) ;; Hostname
(conc (vector-ref server 3) ":" (vector-ref server 4)) ;; IP:Port
- (vector-ref server 5) ;; Pubport
+ (seconds->hr-min-sec (- (current-seconds)(vector-ref server 6)))
+ ;; (vector-ref server 5) ;; Pubport
;; (vector-ref server 10) ;; Last beat
;; (vector-ref server 6) ;; Start time
;; (vector-ref server 7) ;; Priority
;; (vector-ref server 8) ;; State
- (if (< (vector-ref server 10) 20) ;; Status (Please redo this properly!)
- "alive"
- "dead")
- (vector-ref server 11) ;; Transport
+ (vector-ref server 8) ;; State
+ (vector-ref server 12) ;; RunId
)))
(for-each (lambda (val)
- ;; (print "rownum: " rownum " colnum: " colnum " val: " val)
- (iup:attribute-set! servers-matrix (conc rownum ":" colnum) val)
- (iup:attribute-set! servers-matrix "FITTOTEXT" (conc "C" colnum))
- (set! colnum (+ 1 colnum)))
+ (let* ((row-col (conc rownum ":" colnum))
+ (curr-val (iup:attribute servers-matrix row-col)))
+ (if (not (equal? (conc val) curr-val))
+ (begin
+ (iup:attribute-set! servers-matrix row-col val)
+ (iup:attribute-set! servers-matrix "FITTOTEXT" (conc "C" colnum))))
+ (set! colnum (+ 1 colnum))))
vals)
(set! rownum (+ rownum 1)))
(iup:attribute-set! servers-matrix "REDRAW" "ALL"))
servers)))))
(set! colnum 0)
@@ -493,39 +495,41 @@
(iup:attribute-set! servers-matrix "FITTOTEXT" (conc "C" colnum))
(set! colnum (+ colnum 1)))
colnames)
(set! dashboard:update-servers-table updater)
;; (iup:attribute-set! servers-matrix "WIDTHDEF" "40")
- (iup:hbox
- (iup:vbox
- (iup:button "Start"
- ;; #:size "50x"
- #:expand "YES"
- #:action (lambda (obj)
- (let ((cmd (conc ;; "xterm -geometry 180x20 -e \""
- "megatest -server - &")))
- ;; ";echo Press any key to continue;bash -c 'read -n 1 -s'\" &")))
- (system cmd))))
- (iup:button "Stop"
- #:expand "YES"
- ;; #:size "50x"
- #:action (lambda (obj)
- (let ((cmd (conc ;; "xterm -geometry 180x20 -e \""
- "megatest -stop-server 0 &")))
- ;; ";echo Press any key to continue;bash -c 'read -n 1 -s'\" &")))
- (system cmd))))
- (iup:button "Restart"
- #:expand "YES"
- ;; #:size "50x"
- #:action (lambda (obj)
- (let ((cmd (conc ;; "xterm -geometry 180x20 -e \""
- "megatest -stop-server 0;megatest -server - &")))
- ;; ";echo Press any key to continue;bash -c 'read -n 1 -s'\" &")))
- (system cmd)))))
- servers-matrix
- )))
-
+ ;; (iup:hbox
+ ;; (iup:vbox
+ ;; (iup:button "Start"
+ ;; ;; #:size "50x"
+ ;; #:expand "YES"
+ ;; #:action (lambda (obj)
+ ;; (let ((cmd (conc ;; "xterm -geometry 180x20 -e \""
+ ;; "megatest -server - &")))
+ ;; ;; ";echo Press any key to continue;bash -c 'read -n 1 -s'\" &")))
+ ;; (system cmd))))
+ ;; (iup:button "Stop"
+ ;; #:expand "YES"
+ ;; ;; #:size "50x"
+ ;; #:action (lambda (obj)
+ ;; (let ((cmd (conc ;; "xterm -geometry 180x20 -e \""
+ ;; "megatest -stop-server 0 &")))
+ ;; ;; ";echo Press any key to continue;bash -c 'read -n 1 -s'\" &")))
+ ;; (system cmd))))
+ ;; (iup:button "Restart"
+ ;; #:expand "YES"
+ ;; ;; #:size "50x"
+ ;; #:action (lambda (obj)
+ ;; (let ((cmd (conc ;; "xterm -geometry 180x20 -e \""
+ ;; "megatest -stop-server 0;megatest -server - &")))
+ ;; ;; ";echo Press any key to continue;bash -c 'read -n 1 -s'\" &")))
+ ;; (system cmd)))))
+ ;; servers-matrix
+ ;; )))
+ servers-matrix
+ ))
+
;; The main menu
(define (dcommon:main-menu)
(iup:menu ;; a menu is a special attribute to a dialog (think Gnome putting the menu at screen top)
(iup:menu-item "Files" (iup:menu ;; Note that you can use either #:action or action: for options
(iup:menu-item "Open" action: (lambda (obj)
Index: docs/html/megatest.html
==================================================================
--- docs/html/megatest.html
+++ docs/html/megatest.html
@@ -2,11 +2,11 @@
<!DOCTYPE html PUBLIC "-//W3C//DTD XHTML 1.0 Transitional//EN" "http://www.w3.org/TR/xhtml1/DTD/xhtml1-transitional.dtd">
<html xmlns="http://www.w3.org/1999/xhtml" xml:lang="en" lang="en">
<head>
<meta http-equiv="Content-Type" content="text/html; charset=UTF-8"/>
<meta name="generator" content="http://www.nongnu.org/elyxer/"/>
-<meta name="create-date" content="2012-01-29"/>
+<meta name="create-date" content="2014-01-25"/>
<link rel="stylesheet" href="http://elyxer.nongnu.org/lyx.css" type="text/css" media="all"/>
<title>Megatest User Manual</title>
</head>
<body>
<div id="globalWrapper">
@@ -782,11 +782,11 @@
</h2>
<div class="Standard">
Note: The monitor is usable but incomplete as of Megatest v1.31. Click on the “Monitor” button on the dashboard to start the monitor and give it a try.
</div>
<div class="Standard">
-<img class="embedded" src="monitor-state-diagram.png" alt="figure monitor-state-diagram.png" style="max-width: 383px; max-height: 335px;"/>
+<img class="embedded" src="monitor-state-diagram.png" alt="figure monitor-state-diagram.png" style="max-width: 531px; max-height: 465px;"/>
</div>
<h1 class="Section">
<a class="toc" name="toc-Section-14">14</a> Reference
</h1>
@@ -1708,10 +1708,10 @@
<a class="toc" name="toc-Appendix-B">B</a> References
</h1>
<hr class="footer"/>
<div class="footer" id="generated-by">
-Document generated by <a href="http://elyxer.nongnu.org/">eLyXer 1.2.2 (2011-06-12)</a> on <span class="create-date">2012-01-29T19:15:57.445316</span>
+Document generated by <a href="http://elyxer.nongnu.org/">eLyXer 1.2.3 (2011-08-31)</a> on <span class="create-date">2014-01-25T22:27:14.268137</span>
</div>
</div>
</body>
</html>
Index: docs/html/monitor-state-diagram.png
==================================================================
--- docs/html/monitor-state-diagram.png
+++ docs/html/monitor-state-diagram.png
cannot compute difference between binary files
Index: docs/manual/Makefile
==================================================================
--- docs/manual/Makefile
+++ docs/manual/Makefile
@@ -1,7 +1,14 @@
+all : server.pdf megatest_manual.html client.pdf
megatest_manual.html : megatest_manual.txt getting_started.txt writing_tests.txt reference.txt ../plan.txt
asciidoc megatest_manual.txt
dos2unix megatest_manual.html
+server.pdf : server.dot
+ dot -Tpdf server.dot > server.pdf
+
+client.pdf : client.dot
+ dot -Tpdf client.dot > client.pdf
+
clean:
rm -f megatest_manual.html
ADDED docs/manual/client.dot
Index: docs/manual/client.dot
==================================================================
--- /dev/null
+++ docs/manual/client.dot
@@ -0,0 +1,35 @@
+digraph G {
+
+ // put client after server so server_start node is visible
+ //
+ subgraph cluster_2 {
+ node [style=filled,shape=box];
+
+ "client:setup start" -> runremote_lookup_server;
+ runremote_lookup_server -> login_attempt [label="have server"];
+ runremote_lookup_server -> monitordb_lookup_server [label="no server"];
+
+ monitordb_lookup_server -> login_attempt [label="have server"];
+ monitordb_lookup_server -> server_start_remote [label="no server"];
+
+ server_start_remote -> delay_2_sec;
+ delay_2_sec -> runremote_lookup_server;
+
+ login_attempt -> "rmt:send-receive_start" [label="login sucessful"];
+ "rmt:send-receive_start" -> "rmt:send-receive_start";
+
+ "rmt:send-receive_start" -> runremote_lookup_server [label=exception];
+ login_attempt -> clear_runremote [label="login failed"];
+
+ "remove_running > 5s" -> runremote_lookup_server;
+
+ subgraph cluster_3 {
+ node [style=filled];
+ clear_runremote -> "remove_running > 5s";
+ }
+
+ label = "client:setup";
+ color=green;
+ }
+
+}
Index: docs/manual/howto.txt
==================================================================
--- docs/manual/howto.txt
+++ docs/manual/howto.txt
@@ -5,10 +5,33 @@
Tricks
------
This section is a compendium of a various useful tricks for debugging,
configuring and generally getting the most out of Megatest.
+
+Limiting your running jobs
+--------------------------
+
+The following example will limit a test in the jobgroup "group1" to no more than 10 tests simultaneously.
+
+In your testconfig:
+
+----------------
+[test_meta]
+jobgroup group1
+----------------
+
+In your megatest.config:
+
+---------------
+[jobgroups]
+group1 10
+custdes 4
+---------------
+
+
+
Debugging Tricks
----------------
Examining The Environment
@@ -17,11 +40,11 @@
During Config File Processing
^^^^^^^^^^^^^^^^^^^^^^^^^^^^^
Organising Your Tests and Tasks
^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^
-/nfs/ch/disks/ch_unienv_disk005/qa_mrwellan/interim/src/megatest/tests/fdktestqa/testqa
+
----------------------------
[tests-paths]
1 #{get misc parent}/simplerun/tests
----------------------------
@@ -34,15 +57,13 @@
-------------------
runscript main.csh
-------------------
-
-ww30.2
-cellname/LVS/cellname.LAYOUT_ERRORS
-
-Error: text open
-
-ww31.3
-cellname/LVS/cellname.LAYOUT_ERRORS
-
-Error: text open
+Debugging Server Problems
+~~~~~~~~~~~~~~~~~~~~~~~~~
+
+----------------
+sudo lsof -i
+sudo netstat -lptu
+sudo netstat -tulpn
+----------------
Index: docs/manual/megatest_manual.html
==================================================================
--- docs/manual/megatest_manual.html
+++ docs/manual/megatest_manual.html
@@ -781,322 +781,80 @@
sqlite3 database.</p></div>
</div>
</div>
</div>
<h1 id="_road_map">Road Map</h1>
-<div class="paragraph"><p>Note: This road-map is tentative and subject to change without notice.</p></div>
-<div class="sect2">
-<h3 id="_ww32">ww32</h3>
-<div class="olist arabic"><ol class="arabic">
-<li>
-<p>
-Rerun step and or subsequent steps from gui
-</p>
-</li>
-<li>
-<p>
-Refresh test area files from gui
-</p>
-</li>
-<li>
-<p>
-Clean and re-run button
-</p>
-</li>
-<li>
-<p>
-Clean up STATE and STATUS handling.
-</p>
-<div class="olist loweralpha"><ol class="loweralpha">
-<li>
-<p>
-Dashboard and Test control panel are reverse order - choose and fix
-</p>
-</li>
-<li>
-<p>
-Move seldom used states and status to drop down selector
-</p>
-</li>
-</ol></div>
-</li>
-<li>
-<p>
-Access test control panel when clicking on Run Summary tests
-</p>
-</li>
-<li>
-<p>
-Feature: -generate-index-tree
-</p>
-</li>
-<li>
-<p>
-Change specifing of state and status to use STATE1/STATUS1,STATE2/STATUS2
-</p>
-</li>
-</ol></div>
-</div>
-<div class="sect2">
-<h3 id="_ww33">ww33</h3>
-<div class="olist arabic"><ol class="arabic">
-<li>
-<p>
-http api available for use with Perl, Ruby etc. scripts
-</p>
-</li>
-<li>
-<p>
-megatest.config setup entries for:
-</p>
-<div class="olist loweralpha"><ol class="loweralpha">
-<li>
-<p>
-run launching (e.g. /bin/sh %CMD% > /dev/null)
-</p>
-</li>
-<li>
-<p>
-browser "konqueror %FNAME%
-</p>
-</li>
-</ol></div>
-</li>
-</ol></div>
-</div>
-<div class="sect2">
-<h3 id="_ww34">ww34</h3>
-<div class="olist arabic"><ol class="arabic">
-<li>
-<p>
-Mark dependent tests for clean/rerun -rerun-downstream
-</p>
-</li>
-<li>
-<p>
-On run start check for defunct tests in RUNNING, LAUNCHED or REMOTEHOSTSTART and correct or notify
-</p>
-</li>
-<li>
-<p>
-Fix: refresh of gui sometimes fails on last item (race condition?)
-</p>
-</li>
-</ol></div>
-</div>
-<div class="sect2">
-<h3 id="_ww35">ww35</h3>
-<div class="olist arabic"><ol class="arabic">
-<li>
-<p>
-refdb: Add export of csv, json and sexp
-</p>
-</li>
-<li>
-<p>
-Convert to using call-with-environment-variables where possible. Should allow handling of parallel runs in same process.
-</p>
-</li>
-<li>
-<p>
-Re-work text interface wizards. Several bugs on record. Possibly convert to gui based.
-</p>
-</li>
-<li>
-<p>
-Add to testconfig requirements section; launchlimiter scriptname, calls scriptname to check if ok to launch test
-</p>
-</li>
-<li>
-<p>
-Refactor Run Summary view, currently very clumsy
-</p>
-</li>
-<li>
-<p>
-Add option to show steps in Run Summary view
-</p>
-</li>
-</ol></div>
-</div>
-<div class="sect2">
-<h3 id="_ww36">ww36</h3>
-<div class="olist arabic"><ol class="arabic">
-<li>
-<p>
-Refactor guis for resizeablity
-</p>
-</li>
-<li>
-<p>
-Add filters to Run Summary view and Run Control view
-</p>
-</li>
-<li>
-<p>
-Add to megatest.config or testconfig; rerunok STATE/STATUS,STATE/STATUS…
-</p>
-</li>
-<li>
-<p>
-Launch gates for diskspace; /path/one>1G,/path/two>200M,/tmp>5G,#{scheme <strong>toppath</strong>}>1G
-</p>
-</li>
-</ol></div>
-</div>
-<div class="sect2">
-<h3 id="_bin_list">Bin List</h3>
-<div class="olist arabic"><ol class="arabic">
-<li>
-<p>
-Quality improvements
-</p>
-<div class="olist loweralpha"><ol class="loweralpha">
-<li>
-<p>
-Server stutters occasionally
-</p>
-</li>
-<li>
-<p>
-Large number of items or tests still has some issues.
-</p>
-</li>
-<li>
-<p>
-Code refactoring
-</p>
-</li>
-<li>
-<p>
-Replace remote process with true API using json (supports Web app also)
-</p>
-</li>
-</ol></div>
-</li>
-<li>
-<p>
-Streamline the gui
-</p>
-<div class="olist loweralpha"><ol class="loweralpha">
-<li>
-<p>
-Everything resizable
-</p>
-</li>
-<li>
-<p>
-Less clutter
-</p>
-</li>
-<li>
-<p>
-Tool tips
-</p>
-</li>
-<li>
-<p>
-Filters on Run Summary, Summary and Run Control panel
-</p>
-</li>
-<li>
-<p>
-Built in log viewer (partially implemented)
-</p>
-</li>
-<li>
-<p>
-Refactor the test control panel
-</p>
-</li>
-</ol></div>
-</li>
-<li>
-<p>
-Help and documentation
-</p>
-<div class="olist loweralpha"><ol class="loweralpha">
-<li>
-<p>
-Complete the user manual (I’ve been working on this lately).
-</p>
-</li>
-<li>
-<p>
-Online help in the gui
-</p>
-</li>
-</ol></div>
-</li>
-<li>
-<p>
-Streamlined install
-</p>
-<div class="olist loweralpha"><ol class="loweralpha">
-<li>
-<p>
-Deployed version (download a location independent ready to run binary bundle)
-</p>
-</li>
-<li>
-<p>
-Install Makefile (in progress, needed for Mike to install on VMs)
-</p>
-</li>
-<li>
-<p>
-Added option to compile IUP (needed for VMs)
-</p>
-</li>
-</ol></div>
-</li>
-<li>
-<p>
-Server side run launching
-</p>
-</li>
-<li>
-<p>
-Support for re-running, cleaning etc. of individual steps (ezsteps makes this very easy to implement).
-</p>
-</li>
-<li>
-<p>
-Launch process needs built in daemonizing (easy to do, just need to test it thoroughly).
-</p>
-</li>
-<li>
-<p>
-Wizards for creating tests, regression areas (current ones are text only and limited).
-</p>
-</li>
-<li>
-<p>
-Fully functional built in web service (currently you can browse runs but it is very simplistic).
-</p>
-</li>
-<li>
-<p>
-Wildcards in runconfigs: e.g. [p1271/9/%/%]
-</p>
-</li>
-<li>
-<p>
-Gui panels for editing megatest.config and runconfigs.config
-</p>
-</li>
-<li>
-<p>
-Fully isolated tests (no use of NFS to see regression area files)
-</p>
-</li>
-<li>
-<p>
-Windows version
-</p>
-</li>
-</ol></div>
+<div class="paragraph"><p>Note 1: This road-map is tentative and subject to change without notice.</p></div>
+<div class="paragraph"><p>Note 2: Starting over. Old plan is commented out.</p></div>
+<div class="sect1">
+<h2 id="_current_items">Current Items</h2>
+<div class="sectionbody">
+<div class="sect2">
+<h3 id="_ww05_migrate_to_inmem_db">ww05 - migrate to inmem-db</h3>
+<div class="paragraph"><p>Keep as much the same as possible. Add internal reference to almost
+eliminate contention on db(s).</p></div>
+<div class="olist arabic"><ol class="arabic">
+<li>
+<p>
+Add internal reference db
+</p>
+</li>
+<li>
+<p>
+Verify that actions are accessing correct db
+</p>
+<div class="olist loweralpha"><ol class="loweralpha">
+<li>
+<p>
+-runtests - inmem
+</p>
+</li>
+<li>
+<p>
+-list-runs - local (but not megatest.db)
+</p>
+</li>
+<li>
+<p>
+dashboard - local (but not megatest.db)
+</p>
+</li>
+</ol></div>
+</li>
+<li>
+<p>
+Mirror db to /var/tmp…
+</p>
+</li>
+<li>
+<p>
+Dashboard read db from per-run db.
+</p>
+</li>
+<li>
+<p>
+Dashboard read db from /var/tmp
+</p>
+</li>
+<li>
+<p>
+Runs register in tasks table in monitor.db
+</p>
+</li>
+<li>
+<p>
+Server polls tasks table for next action (in addition?)
+</p>
+</li>
+<li>
+<p>
+Change run loop to execute in server, triggered by call to polling of tasks table
+</p>
+</li>
+</ol></div>
+</div>
+</div>
</div>
<h1 id="_getting_started">Getting Started</h1>
<div class="openblock">
<div class="title">Getting started with Megatest</div>
<div class="content">
@@ -1193,10 +951,46 @@
<div class="paragraph"><p>Chapters grouped into book parts are at level 1 and can contain
sub-sections.</p></div>
</div>
</div>
<h1 id="_how_to_do_things">How To Do Things</h1>
+<div class="sect1">
+<h2 id="_tricks">Tricks</h2>
+<div class="sectionbody">
+<div class="paragraph"><p>This section is a compendium of a various useful tricks for debugging,
+configuring and generally getting the most out of Megatest.</p></div>
+</div>
+</div>
+<div class="sect1">
+<h2 id="_debugging_tricks">Debugging Tricks</h2>
+<div class="sectionbody">
+<div class="sect2">
+<h3 id="_examining_the_environment">Examining The Environment</h3>
+<div class="sect3">
+<h4 id="_during_config_file_processing">During Config File Processing</h4>
+</div>
+<div class="sect3">
+<h4 id="_organising_your_tests_and_tasks">Organising Your Tests and Tasks</h4>
+<div class="listingblock">
+<div class="content">
+<pre><tt>[tests-paths]
+1 #{get misc parent}/simplerun/tests</tt></pre>
+</div></div>
+<div class="listingblock">
+<div class="content">
+<pre><tt>[setup]</tt></pre>
+</div></div>
+<div class="paragraph"><p>The runscript method is a brute force way to run scripts where the
+user is responsible for setting STATE and STATUS</p></div>
+<div class="listingblock">
+<div class="content">
+<pre><tt>runscript main.csh</tt></pre>
+</div></div>
+</div>
+</div>
+</div>
+</div>
<div class="sect1">
<h2 id="_tricks">Tricks</h2>
<div class="sectionbody">
<div class="paragraph"><p>This section is a compendium of a various useful tricks for debugging,
configuring and generally getting the most out of Megatest.</p></div>
@@ -1327,10 +1121,18 @@
<div class="paragraph"><p>To transfer the environment to the next step you can do the following:</p></div>
<div class="listingblock">
<div class="content">
<pre><tt>$MT_MEGATEST -env2file .ezsteps/${stepname}</tt></pre>
</div></div>
+<div class="sect2">
+<h3 id="_megatest_internals">Megatest Internals</h3>
+<div class="imageblock graphviz">
+<div class="content">
+<img src="server.png" alt="server.png" />
+</div>
+</div>
+</div>
<div class="paragraph"><p>One or more optional appendixes go here at section level zero.</p></div>
<div class="admonitionblock">
<table><tr>
<td class="icon">
<div class="title">Note</div>
@@ -1385,10 +1187,10 @@
</div>
<div id="footnotes"><hr /></div>
<div id="footer">
<div id="footer-text">
Version 1.0<br />
-Last updated 2014-02-13 21:27:42 MST
+Last updated 2014-02-18 07:24:48 MST
</div>
</div>
</body>
</html>
Index: docs/manual/megatest_manual.txt
==================================================================
--- docs/manual/megatest_manual.txt
+++ docs/manual/megatest_manual.txt
@@ -48,10 +48,19 @@
include::../plan.txt[]
include::getting_started.txt[]
include::writing_tests.txt[]
include::howto.txt[]
include::reference.txt[]
+
+Megatest Internals
+~~~~~~~~~~~~~~~~~~
+
+["graphviz", "server.png"]
+----------------------------------------------------------------------
+include::server.dot[]
+----------------------------------------------------------------------
+
[appendix]
Example Appendix
================
One or more optional appendixes go here at section level zero.
Index: docs/manual/reference.txt
==================================================================
--- docs/manual/reference.txt
+++ docs/manual/reference.txt
@@ -2,10 +2,11 @@
Reference
=========
The First Chapter of the Second Part
------------------------------------
+
Chapters grouped into book parts are at level 1 and can contain
sub-sections.
The testconfig File
-------------------
ADDED docs/manual/server.dot
Index: docs/manual/server.dot
==================================================================
--- /dev/null
+++ docs/manual/server.dot
@@ -0,0 +1,62 @@
+digraph G {
+
+ subgraph cluster_1 {
+ node [style=filled,shape=box];
+
+ check_available_queue -> remove_entries_over_10s_old;
+ remove_entries_over_10s_old -> set_available [label="num_avail < 3"];
+ remove_entries_over_10s_old -> exit [label="num_avail > 2"];
+
+ set_available -> delay_2s;
+ delay_2s -> check_place_in_queue;
+
+ check_place_in_queue -> "http:transport-launch" [label="at head"];
+ check_place_in_queue -> exit [label="not at head"];
+
+ "client:login" -> "server:shutdown" [label="login failed"];
+ "server:shutdown" -> exit;
+
+ subgraph cluster_2 {
+ "http:transport-launch" -> "http:transport-run";
+ "http:transport-launch" -> "http:transport-keep-running";
+
+ "http:transport-keep-running" -> "tests running?";
+ "tests running?" -> "client:login" [label=yes];
+ "tests running?" -> "server:shutdown" [label=no];
+ "client:login" -> delay_5s [label="login ok"];
+ delay_5s -> "http:transport-keep-running";
+ }
+
+ // start_server -> "server_running?";
+ // "server_running?" -> set_available [label="no"];
+ // "server_running?" -> delay_2s [label="yes"];
+ // delay_2s -> "still_running?";
+ // "still_running?" -> ping_server [label=yes];
+ // "still_running?" -> set_available [label=no];
+ // ping_server -> exit [label=alive];
+ // ping_server -> remove_server_record [label=dead];
+ // remove_server_record -> set_available;
+ // set_available -> avail_delay [label="delay 3s"];
+ // avail_delay -> "first_in_queue?";
+ //
+ // "first_in_queue?" -> set_running [label=yes];
+ // set_running -> get_next_port -> handle_requests;
+ // "first_in_queue?" -> "dead_entry_in_queue?" [label=no];
+ // "dead_entry_in_queue?" -> "server_running?" [label=no];
+ // "dead_entry_in_queue?" -> "remove_dead_entries" [label=yes];
+ // remove_dead_entries -> "server_running?";
+ //
+ // handle_requests -> start_shutdown [label="no traffic\nno running tests"];
+ // handle_requests -> shutdown_request;
+ // start_shutdown -> shutdown_delay;
+ // shutdown_request -> shutdown_delay;
+ // shutdown_delay -> exit;
+
+ label = "server:launch";
+ color=brown;
+ }
+
+// client_start_server -> start_server;
+// handle_requests -> read_write;
+// read_write -> handle_requests;
+}
ADDED docs/manual/server.pdf
Index: docs/manual/server.pdf
==================================================================
--- /dev/null
+++ docs/manual/server.pdf
cannot compute difference between binary files
ADDED docs/manual/server.png
Index: docs/manual/server.png
==================================================================
--- /dev/null
+++ docs/manual/server.png
cannot compute difference between binary files
Index: docs/plan.txt
==================================================================
--- docs/plan.txt
+++ docs/plan.txt
@@ -1,83 +1,107 @@
Road Map
========
-Note: This road-map is tentative and subject to change without notice.
-
-ww32
-~~~~
-
-. Rerun step and or subsequent steps from gui
-. Refresh test area files from gui
-. Clean and re-run button
-. Clean up STATE and STATUS handling.
-.. Dashboard and Test control panel are reverse order - choose and fix
-.. Move seldom used states and status to drop down selector
-. Access test control panel when clicking on Run Summary tests
-. Feature: -generate-index-tree
-. Change specifing of state and status to use STATE1/STATUS1,STATE2/STATUS2
-
-ww33
-~~~~
-
-. http api available for use with Perl, Ruby etc. scripts
-. megatest.config setup entries for:
-.. run launching (e.g. /bin/sh %CMD% > /dev/null)
-.. browser "konqueror %FNAME%
-
-ww34
-~~~~
-
-. Mark dependent tests for clean/rerun -rerun-downstream
-. On run start check for defunct tests in RUNNING, LAUNCHED or REMOTEHOSTSTART and correct or notify
-. Fix: refresh of gui sometimes fails on last item (race condition?)
-
-ww35
-~~~~
-
-. refdb: Add export of csv, json and sexp
-. Convert to using call-with-environment-variables where possible. Should allow handling of parallel runs in same process.
-. Re-work text interface wizards. Several bugs on record. Possibly convert to gui based.
-. Add to testconfig requirements section; launchlimiter scriptname, calls scriptname to check if ok to launch test
-. Refactor Run Summary view, currently very clumsy
-. Add option to show steps in Run Summary view
-
-ww36
-~~~~
-
-. Refactor guis for resizeablity
-. Add filters to Run Summary view and Run Control view
-. Add to megatest.config or testconfig; rerunok STATE/STATUS,STATE/STATUS...
-. Launch gates for diskspace; /path/one>1G,/path/two>200M,/tmp>5G,#{scheme *toppath*}>1G
-
-Bin List
-~~~~~~~~
-
-. Quality improvements
-.. Server stutters occasionally
-.. Large number of items or tests still has some issues.
-.. Code refactoring
-.. Replace remote process with true API using json (supports Web app also)
-. Streamline the gui
-.. Everything resizable
-.. Less clutter
-.. Tool tips
-.. Filters on Run Summary, Summary and Run Control panel
-.. Built in log viewer (partially implemented)
-.. Refactor the test control panel
-. Help and documentation
-.. Complete the user manual (I’ve been working on this lately).
-.. Online help in the gui
-. Streamlined install
-.. Deployed version (download a location independent ready to run binary bundle)
-.. Install Makefile (in progress, needed for Mike to install on VMs)
-.. Added option to compile IUP (needed for VMs)
-. Server side run launching
-. Support for re-running, cleaning etc. of individual steps (ezsteps makes this very easy to implement).
-. Launch process needs built in daemonizing (easy to do, just need to test it thoroughly).
-. Wizards for creating tests, regression areas (current ones are text only and limited).
-. Fully functional built in web service (currently you can browse runs but it is very simplistic).
-. Wildcards in runconfigs: e.g. [p1271/9/%/%]
-. Gui panels for editing megatest.config and runconfigs.config
-. Fully isolated tests (no use of NFS to see regression area files)
-. Windows version
+Note 1: This road-map is tentative and subject to change without notice.
+
+Note 2: Starting over. Old plan is commented out.
+
+Current Items
+-------------
+
+ww05 - migrate to inmem-db
+~~~~~~~~~~~~~~~~~~~~~~~~~~
+
+Keep as much the same as possible. Add internal reference to almost
+eliminate contention on db(s).
+
+. Add internal reference db
+. Verify that actions are accessing correct db
+.. -runtests - inmem
+.. -list-runs - local (but not megatest.db)
+.. dashboard - local (but not megatest.db)
+. Mirror db to /var/tmp...
+. Dashboard read db from per-run db.
+. Dashboard read db from /var/tmp
+. Runs register in tasks table in monitor.db
+. Server polls tasks table for next action (in addition?)
+. Change run loop to execute in server, triggered by call to polling of tasks table
+
+
+// ww32
+// ~~~~
+//
+// . Rerun step and or subsequent steps from gui
+// . Refresh test area files from gui
+// . Clean and re-run button
+// . Clean up STATE and STATUS handling.
+// .. Dashboard and Test control panel are reverse order - choose and fix
+// .. Move seldom used states and status to drop down selector
+// . Access test control panel when clicking on Run Summary tests
+// . Feature: -generate-index-tree
+// . Change specifing of state and status to use STATE1/STATUS1,STATE2/STATUS2
+//
+// ww33
+// ~~~~
+//
+// . http api available for use with Perl, Ruby etc. scripts
+// . megatest.config setup entries for:
+// .. run launching (e.g. /bin/sh %CMD% > /dev/null)
+// .. browser "konqueror %FNAME%
+//
+// ww34
+// ~~~~
+//
+// . Mark dependent tests for clean/rerun -rerun-downstream
+// . On run start check for defunct tests in RUNNING, LAUNCHED or REMOTEHOSTSTART and correct or notify
+// . Fix: refresh of gui sometimes fails on last item (race condition?)
+//
+// ww35
+// ~~~~
+//
+// . refdb: Add export of csv, json and sexp
+// . Convert to using call-with-environment-variables where possible. Should allow handling of parallel runs in same process.
+// . Re-work text interface wizards. Several bugs on record. Possibly convert to gui based.
+// . Add to testconfig requirements section; launchlimiter scriptname, calls scriptname to check if ok to launch test
+// . Refactor Run Summary view, currently very clumsy
+// . Add option to show steps in Run Summary view
+//
+// ww36
+// ~~~~
+//
+// . Refactor guis for resizeablity
+// . Add filters to Run Summary view and Run Control view
+// . Add to megatest.config or testconfig; rerunok STATE/STATUS,STATE/STATUS...
+// . Launch gates for diskspace; /path/one>1G,/path/two>200M,/tmp>5G,#{scheme *toppath*}>1G
+//
+// Bin List
+// ~~~~~~~~
+//
+// . Quality improvements
+// .. Server stutters occasionally
+// .. Large number of items or tests still has some issues.
+// .. Code refactoring
+// .. Replace remote process with true API using json (supports Web app also)
+// . Streamline the gui
+// .. Everything resizable
+// .. Less clutter
+// .. Tool tips
+// .. Filters on Run Summary, Summary and Run Control panel
+// .. Built in log viewer (partially implemented)
+// .. Refactor the test control panel
+// . Help and documentation
+// .. Complete the user manual (I’ve been working on this lately).
+// .. Online help in the gui
+// . Streamlined install
+// .. Deployed version (download a location independent ready to run binary bundle)
+// .. Install Makefile (in progress, needed for Mike to install on VMs)
+// .. Added option to compile IUP (needed for VMs)
+// . Server side run launching
+// . Support for re-running, cleaning etc. of individual steps (ezsteps makes this very easy to implement).
+// . Launch process needs built in daemonizing (easy to do, just need to test it thoroughly).
+// . Wizards for creating tests, regression areas (current ones are text only and limited).
+// . Fully functional built in web service (currently you can browse runs but it is very simplistic).
+// . Wildcards in runconfigs: e.g. [p1271/9/%/%]
+// . Gui panels for editing megatest.config and runconfigs.config
+// . Fully isolated tests (no use of NFS to see regression area files)
+// . Windows version
ADDED docs/results.pdf
Index: docs/results.pdf
==================================================================
--- /dev/null
+++ docs/results.pdf
cannot compute difference between binary files
Index: ezsteps.scm
==================================================================
--- ezsteps.scm
+++ ezsteps.scm
@@ -16,24 +16,28 @@
(declare (unit ezsteps))
(declare (uses db))
(declare (uses common))
(declare (uses items))
(declare (uses runconfig))
+;; (declare (uses sdb))
+;; (declare (uses filedb))
(include "common_records.scm")
(include "key_records.scm")
(include "db_records.scm")
(include "run_records.scm")
(define (ezsteps:run-from testdat start-step-name run-one)
- (let* ((test-run-dir (db:test-get-rundir testdat))
+ (let* ((test-run-dir ;; (filedb:get-path *fdb*
+ (db:test-get-rundir testdat)) ;; )
(testconfig (read-config (conc test-run-dir "/testconfig") #f #t environ-patt: "pre-launch-env-vars"))
(ezstepslst (hash-table-ref/default testconfig "ezsteps" '()))
(run-mutex (make-mutex))
(rollup-status 0)
(exit-info (vector #t #t #t))
(test-id (db:test-get-id testdat))
+ (run-id (db:test-get-run_id testdat))
(test-name (db:test-get-testname testdat))
(kill-job #f)) ;; for future use (on re-factoring with launch.scm code
(let loop ((count 5))
(if (file-exists? test-run-dir)
(push-directory test-run-dir)
@@ -77,12 +81,11 @@
;; call the command using mt_ezstep
(set! script (conc "mt_ezstep " stepname " " (if prevstep prevstep "-") " " stepcmd))
(debug:print 4 "script: " script)
- ;; DO NOT remote
- (db:teststep-set-status! #f test-id stepname "start" "-" #f #f work-area: test-run-dir)
+ (rmt:teststep-set-status! run-id test-id stepname "start" "-" #f #f)
;; now launch
(let ((pid (process-run script)))
(let processloop ((i 0))
(let-values (((pid-val exit-status exit-code)(process-wait pid #t)))
(mutex-lock! run-mutex)
@@ -95,14 +98,13 @@
(thread-sleep! 1)
(processloop (+ i 1))))
))
(let ((exinfo (vector-ref exit-info 2))
(logfna (if logpro-used (conc stepname ".html") "")))
- ;; testing if procedures called in a remote call cause problems (ans: no or so I suspect)
- (db:teststep-set-status! #f test-id stepname "end" exinfo #f logfna work-area: test-run-dir))
+ (rmt:teststep-set-status! run-id test-id stepname "end" exinfo #f logfna))
(if logpro-used
- (cdb:test-set-log! *runremote* test-id (conc stepname ".html")))
+ (rmt:test-set-log! test-id (conc stepname ".html")))
;; set the test final status
(let* ((this-step-status (cond
((and (eq? (vector-ref exit-info 2) 2) logpro-used) 'warn)
((eq? (vector-ref exit-info 2) 0) 'pass)
(else 'fail)))
@@ -138,11 +140,11 @@
(debug:print 4 "WARNING: a prior step failed, stopping at " ezstep)))
;; Once done with step/steps update the test record
;;
(let* ((item-path (db:test-get-item-path testdat)) ;; (item-list->path itemdat))
- (testinfo (cdb:get-test-info-by-id *runremote* test-id))) ;; refresh the testdat, call it iteminfo in case need prev/curr
+ (testinfo (rmt:get-testinfo-by-id run-id test-id))) ;; refresh the testdat, call it iteminfo in case need prev/curr
;; Am I completed?
(if (equal? (db:test-get-state testinfo) "RUNNING") ;; (not (equal? (db:test-get-state testinfo) "COMPLETED"))
(let ((new-state (if kill-job "KILLED" "COMPLETED") ;; (if (eq? (vector-ref exit-info 2) 0) ;; exited with "good" status
;; "COMPLETED"
;; (db:test-get-state testinfo))) ;; else preseve the state as set within the test
Index: filedb.scm
==================================================================
--- filedb.scm
+++ filedb.scm
@@ -23,11 +23,11 @@
(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-timeout! db 1000000)
+ (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);")
@@ -40,12 +40,20 @@
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)))))
@@ -108,10 +116,11 @@
(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))
@@ -214,10 +223,11 @@
(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
DELETED fs-transport.scm
Index: fs-transport.scm
==================================================================
--- fs-transport.scm
+++ /dev/null
@@ -1,44 +0,0 @@
-
-;; Copyright 2006-2012, Matthew Welland.
-;;
-;; This program is made available under the GNU GPL version 2.0 or
-;; greater. See the accompanying file COPYING for details.
-;;
-;; This program is distributed WITHOUT ANY WARRANTY; without even the
-;; implied warranty of MERCHANTABILITY or FITNESS FOR A PARTICULAR
-;; PURPOSE.
-
-(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 *megatest-db*) ;; we will require that (setup-for-run) has already been called
- (set! *megatest-db* (open-db)))
- (debug:print-info 11 "fs:process-queue-item called with packet=" packet)
- (db:process-queue-item *megatest-db* packet))
-
Index: http-transport.scm
==================================================================
--- http-transport.scm
+++ http-transport.scm
@@ -58,71 +58,64 @@
(string-intersperse
(map number->string
(u8vector->list
(if res res (hostname->ip hostname)))) ".")))
-(define (http-transport:run hostn)
+(define (http-transport:run hostn run-id server-id)
(debug:print 2 "Attempting to start the server ...")
- (if (not *toppath*)
- (if (not (setup-for-run))
- (begin
- (debug:print 0 "ERROR: cannot find megatest.config, cannot start server, exiting")
- (exit))))
- (let* (;; (iface (if (string=? "-" hostn)
- ;; #f ;; (get-host-name)
- ;; hostn))
- (db #f) ;; (open-db)) ;; we don't want the server to be opening and closing the db unnecesarily
+ (let* ((db #f) ;; (open-db)) ;; we don't want the server to be opening and closing the db unnecesarily
(hostname (get-host-name))
(ipaddrstr (let ((ipstr (if (string=? "-" hostn)
;; (string-intersperse (map number->string (u8vector->list (hostname->ip hostname))) ".")
(server:get-best-guess-address hostname)
#f)))
- (if ipstr ipstr hostn))) ;; hostname)))
- (start-port (if (and (args:get-arg "-port")
- (string->number (args:get-arg "-port")))
- (string->number (args:get-arg "-port"))
- (if (and (config-lookup *configdat* "server" "port")
- (string->number (config-lookup *configdat* "server" "port")))
- (string->number (config-lookup *configdat* "server" "port"))
- (+ 5000 (random 1001)))))
- (link-tree-path (config-lookup *configdat* "setup" "linktree")))
- (set! *cache-on* #t)
+ (if ipstr ipstr hostn))) ;; hostname)))
+ (start-port (open-run-close tasks:server-get-next-port tasks:open-db))
+ (link-tree-path (configf:lookup *configdat* "setup" "linktree")))
+ (set! db *inmemdb*)
(root-path (if link-tree-path
link-tree-path
(current-directory))) ;; WARNING: SECURITY HOLE. FIX ASAP!
(handle-directory spiffy-directory-listing)
;; http-transport:handle-directory) ;; simple-directory-handler)
;; Setup the web server and a /ctrl interface
;;
(vhost-map `(((* any) . ,(lambda (continue)
;; open the db on the first call
- (if (not db)(set! db (open-db)))
+ ;; This is were we set up the database connections
(let* (($ (request-vars source: 'both))
(dat ($ 'dat))
(res #f))
(cond
+ ((equal? (uri-path (request-uri (current-request)))
+ '(/ "api"))
+ (send-response body: (api:process-request db $) ;; the $ is the request vars proc
+ headers: '((content-type text/plain)))
+ (mutex-lock! *heartbeat-mutex*)
+ (set! *last-db-access* (current-seconds))
+ (mutex-unlock! *heartbeat-mutex*))
;; This is the /ctrl path where data is handed to the server and
;; responses
- ((equal? (uri-path (request-uri (current-request)))
- '(/ "ctrl"))
- (let* ((packet (db:string->obj dat))
- (qtype (cdb:packet-get-qtype packet)))
- (debug:print-info 12 "server=> received packet=" packet)
- (if (not (member qtype '(sync ping)))
- (begin
- (mutex-lock! *heartbeat-mutex*)
- (set! *last-db-access* (current-seconds))
- (mutex-unlock! *heartbeat-mutex*)))
- ;; (mutex-lock! *db:process-queue-mutex*) ;; trying a mutex
- ;; (set! res (open-run-close db:process-queue-item open-db packet))
- (set! res (db:process-queue-item db packet))
- ;; (mutex-unlock! *db:process-queue-mutex*)
- (debug:print-info 11 "Return value from db:process-queue-item is " res)
- (send-response body: (conc "<head>ctrl data</head>\n<body>"
- res
- "</body>")
- headers: '((content-type text/plain)))))
+ ;; ((equal? (uri-path (request-uri (current-request)))
+ ;; '(/ "ctrl"))
+ ;; (let* ((packet (db:string->obj dat))
+ ;; (qtype (cdb:packet-get-qtype packet)))
+ ;; (debug:print-info 12 "server=> received packet=" packet)
+ ;; (if (not (member qtype '(sync ping)))
+ ;; (begin
+ ;; (mutex-lock! *heartbeat-mutex*)
+ ;; (set! *last-db-access* (current-seconds))
+ ;; (mutex-unlock! *heartbeat-mutex*)))
+ ;; ;; (mutex-lock! *db:process-queue-mutex*) ;; trying a mutex
+ ;; ;; (set! res (open-run-close db:process-queue-item open-db packet))
+ ;; (set! res (db:process-queue-item db packet))
+ ;; ;; (mutex-unlock! *db:process-queue-mutex*)
+ ;; (debug:print-info 11 "Return value from db:process-queue-item is " res)
+ ;; (send-response body: (conc "<head>ctrl data</head>\n<body>"
+ ;; res
+ ;; "</body>")
+ ;; headers: '((content-type text/plain)))))
((equal? (uri-path (request-uri (current-request)))
'(/ ""))
(send-response body: (http-transport:main-page)))
((equal? (uri-path (request-uri (current-request)))
'(/ "runs"))
@@ -134,39 +127,42 @@
((equal? (uri-path (request-uri (current-request)))
'(/ "hey"))
(send-response body: "hey there!\n"
headers: '((content-type text/plain))))
(else (continue))))))))
- (http-transport:try-start-server ipaddrstr start-port)))
+ (http-transport:try-start-server run-id ipaddrstr start-port server-id)))
;; This is recursively run by http-transport:run until sucessful
;;
-(define (http-transport:try-start-server ipaddrstr portnum)
+(define (http-transport:try-start-server run-id ipaddrstr portnum server-id)
(handle-exceptions
exn
(begin
(print-error-message exn)
(if (< portnum 9000)
(begin
(debug:print 0 "WARNING: failed to start on portnum: " portnum ", trying next port")
(thread-sleep! 0.1)
- ;; (open-run-close tasks:remove-server-records tasks:open-db)
- (open-run-close tasks:server-delete tasks:open-db ipaddrstr portnum)
- (http-transport:try-start-server ipaddrstr (+ portnum 1)))
- (print "ERROR: Tried and tried but could not start the server")))
+
+ ;; get_next_port goes here
+
+ (http-transport:try-start-server run-id ipaddrstr (+ portnum 1) server-id))
+ (begin
+ (open-run-close tasks:server-force-clean-run-record tasks:open-db run-id ipaddrstr portnum " http-transport:try-start-server")
+ (print "ERROR: Tried and tried but could not start the server"))))
;; any error in following steps will result in a retry
- (set! *runremote* (list ipaddrstr portnum))
- ;; (open-run-close tasks:remove-server-records tasks:open-db)
- (open-run-close tasks:server-register
+ (set! *server-info* (list ipaddrstr portnum))
+ (open-run-close tasks:server-set-interface-port
tasks:open-db
- (current-process-id)
- ipaddrstr portnum 0 'startup 'http)
+ server-id
+ ipaddrstr portnum)
(debug:print 1 "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)
- (open-run-close tasks:server-delete tasks:open-db ipaddrstr portnum)
+ ;; (start-server bind-address: ipaddrstr port: portnum)
+ (start-server port: portnum)
+ (open-run-close tasks:server-force-clean-run-record tasks:open-db run-id ipaddrstr portnum " http-transport:try-start-server")
(debug:print 1 "INFO: server has been stopped")))
;;======================================================================
;; S E R V E R U T I L I T I E S
;;======================================================================
@@ -175,240 +171,322 @@
;; C L I E N T S
;;======================================================================
(define *http-mutex* (make-mutex))
-;; (system "megatest -list-servers | grep alive || megatest -server - -daemonize && sleep 4")
-
-;; <html>
-;; <head></head>
-;; <body>1 Hello, world! Goodbye Dolly</body></html>
-;; Send msg to serverdat and receive result
-(define (http-transport:client-send-receive serverdat msg #!key (numretries 30))
- (let* (;; (url (http-transport:make-server-url serverdat))
- (fullurl (if (list? serverdat)
- (caddr serverdat)
+;; NOTE: Large block of code from 32436b426188080f72fceb6894af541fbad9921e removed here
+;; I'm pretty sure it is defunct.
+
+;; This next block all imported en-mass from the api branch
+(define *http-requests-in-progress* 0)
+(define *http-connections-next-cleanup* (current-seconds))
+
+(define (http-transport:get-time-to-cleanup)
+ (let ((res #f))
+ (mutex-lock! *http-mutex*)
+ (set! res (> (current-seconds) *http-connections-next-cleanup*))
+ (mutex-unlock! *http-mutex*)
+ res))
+
+(define (http-transport:inc-requests-count)
+ (mutex-lock! *http-mutex*)
+ (set! *http-requests-in-progress* (+ 1 *http-requests-in-progress*))
+ ;; Use this opportunity to slow things down iff there are too many requests in flight
+ (if (> *http-requests-in-progress* 5)
+ (begin
+ (debug:print-info 0 "Whoa there buddy, ease up...")
+ (thread-sleep! 1)))
+ (mutex-unlock! *http-mutex*))
+
+(define (http-transport:dec-requests-count proc)
+ (mutex-lock! *http-mutex*)
+ (proc)
+ (set! *http-requests-in-progress* (- *http-requests-in-progress* 1))
+ (mutex-unlock! *http-mutex*))
+
+(define (http-transport:dec-requests-count-and-close-all-connections)
+ (set! *http-requests-in-progress* (- *http-requests-in-progress* 1))
+ (let loop ((etime (+ (current-seconds) 5))) ;; give up in five seconds
+ (if (> *http-requests-in-progress* 0)
+ (if (> etime (current-seconds))
+ (begin
+ (thread-sleep! 0.05)
+ (loop etime))
+ (debug:print 0 "ERROR: requests still in progress after 5 seconds of waiting. I'm going to pass on cleaning up http connections"))
+ (close-all-connections!)))
+ (set! *http-connections-next-cleanup* (+ (current-seconds) 10))
+ (mutex-unlock! *http-mutex*))
+
+(define (http-transport:inc-requests-and-prep-to-close-all-connections)
+ (mutex-lock! *http-mutex*)
+ (set! *http-requests-in-progress* (+ 1 *http-requests-in-progress*)))
+
+;; Send "cmd" with json payload "params" to serverdat and receive result
+;;
+(define (http-transport:client-api-send-receive run-id serverdat cmd params #!key (numretries 3))
+ (let* ((fullurl (if (vector? serverdat)
+ (http-transport:server-dat-get-api-req serverdat)
(begin
- (debug:print 0 "FATAL ERROR: http-transport:client-send-receive called with no server info")
- (exit 1)))) ;; (conc url "/ctrl")) ;; (conc url "/?dat=" msg)))
+ (debug:print 0 "FATAL ERROR: http-transport:client-api-send-receive called with no server info")
+ (exit 1))))
(res #f))
(handle-exceptions
exn
- (begin
- (print "ERROR IN http-transport:client-send-receive " ((condition-property-accessor 'exn 'message) exn))
- (thread-sleep! 2)
- (if (> numretries 0)
- (http-transport:client-send-receive serverdat msg numretries: (- numretries 1))))
- (begin
- (debug:print-info 11 "fullurl=" fullurl "\n")
- ;; set up the http-client here
- (max-retry-attempts 5)
+ (if (> numretries 0)
+ (begin
+ (mutex-unlock! *http-mutex*)
+ (thread-sleep! 1)
+ (close-all-connections!)
+ (debug:print 0 "WARNING: Failed to communicate with server, trying again, numretries left: " numretries)
+ (http-transport:client-api-send-receive run-id serverdat cmd params numretries: (- numretries 1)))
+ (begin
+ (mutex-unlock! *http-mutex*)
+ #f))
+ (begin
+ (debug:print-info 11 "fullurl=" fullurl ", cmd=" cmd ", params=" params ", run-id=" run-id "\n")
+ ;; set up the http-client here
+ (max-retry-attempts 1)
;; consider all requests indempotent
(retry-request? (lambda (request)
- #t)) ;; (thread-sleep! (/ (if (> numretries 100) 100 numretries) 10))
- ;; (set! numretries (- numretries 1))
- ;; #t))
+ #f))
;; send the data and get the response
;; extract the needed info from the http data and
;; process and return it.
(let* ((send-recieve (lambda ()
(mutex-lock! *http-mutex*)
- (set! res (with-input-from-request
+ (set! res (with-input-from-request ;; was dat
fullurl
- (list (cons 'dat msg))
+ (list (cons 'key "thekey")
+ (cons 'cmd cmd)
+ (cons 'params params))
read-string))
- (close-all-connections!)
- (mutex-unlock! *http-mutex*)))
+ ;; Shouldn't this be a call to the managed call-all-connections stuff above?
+ (close-all-connections!)
+ (mutex-unlock! *http-mutex*)
+ ))
(time-out (lambda ()
(thread-sleep! 45)
- (if (not res)
- (begin
- (debug:print 0 "WARNING: communication with the server timed out.")
- (mutex-unlock! *http-mutex*)
- (http-transport:client-send-receive serverdat msg numretries: (- numretries 1))
- (if (< numretries 3) ;; on last try just exit
- (begin
- (debug:print 0 "ERROR: communication with the server timed out. Giving up.")
- (exit 1)))))))
+ #f))
(th1 (make-thread send-recieve "with-input-from-request"))
(th2 (make-thread time-out "time out")))
(thread-start! th1)
(thread-start! th2)
(thread-join! th1)
(thread-terminate! th2)
(debug:print-info 11 "got res=" res)
- (let ((match (string-search (regexp "<body>(.*)<.body>") res)))
- (debug:print-info 11 "match=" match)
- (let ((final (cadr match)))
- (debug:print-info 11 "final=" final)
- final)))))))
+ res)))))
+
+;; careful closing of connections stored in *runremote*
+;;
+(define (http-transport:close-connections run-id)
+ (let* ((server-dat (hash-table-ref/default *runremote* run-id #f)))
+ (if (vector? server-dat)
+ (let ((api-dat (http-transport:server-dat-get-api-uri server-dat)))
+ (close-connection! api-dat)
+ #t)
+ #f)))
+
+
+(define (make-http-transport:server-dat)(make-vector 5))
+(define (http-transport:server-dat-get-iface vec) (vector-ref vec 0))
+(define (http-transport:server-dat-get-port vec) (vector-ref vec 1))
+(define (http-transport:server-dat-get-api-uri vec) (vector-ref vec 2))
+(define (http-transport:server-dat-get-api-url vec) (vector-ref vec 3))
+(define (http-transport:server-dat-get-api-req vec) (vector-ref vec 4))
+
+(define (http-transport:server-dat-make-url vec)
+ (if (and (http-transport:server-dat-get-iface vec)
+ (http-transport:server-dat-get-port vec))
+ (conc "http://"
+ (http-transport:server-dat-get-iface vec)
+ ":"
+ (http-transport:server-dat-get-port vec))
+ #f))
+;;
+;; connect
+;;
(define (http-transport:client-connect iface port)
- (let* ((login-res #f)
- (uri-dat (make-request method: 'POST uri: (uri-reference (conc "http://" iface ":" port "/ctrl"))))
- (serverdat (list iface port uri-dat)))
- (set! login-res (client:login serverdat))
- (if (and (not (null? login-res))
- (car login-res))
- (begin
- (debug:print-info 2 "Logged in and connected to " iface ":" port)
- (set! *runremote* serverdat)
- serverdat)
- (begin
- (debug:print-info 0 "ERROR: Failed to login or connect to " iface ":" port)
- (exit 1)))))
-;; (set! *runremote* #f)
-;; (set! *transport-type* 'fs)
-;; #f))))
-
+ (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)))
+ 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)
+(define (http-transport:keep-running server-id)
;; if none running or if > 20 seconds since
;; server last used then start shutdown
;; This thread waits for the server to come alive
- (let* ((server-info (let loop ()
+ (let* ((server-info (let loop ((start-time (current-seconds))
+ (changed #t)
+ (last-sdat "not this"))
(let ((sdat #f))
(mutex-lock! *heartbeat-mutex*)
- (set! sdat *runremote*)
+ (set! sdat *server-info*)
(mutex-unlock! *heartbeat-mutex*)
- (if sdat
+ (if (and sdat
+ (not changed)
+ (> (- (current-seconds) start-time) 2))
sdat
(begin
(sleep 4)
- (loop))))))
+ (loop start-time
+ (equal? sdat last-sdat)
+ sdat))))))
(iface (car server-info))
(port (cadr server-info))
(last-access 0)
(tdb (tasks:open-db))
- (spid ;;(open-run-close tasks:server-get-server-id tasks:open-db #f iface port #f))
- (tasks:server-get-server-id tdb #f iface port #f))
- (server-timeout (let ((tmo (config-lookup *configdat* "server" "timeout")))
+ (server-timeout (let ((tmo (configf:lookup *configdat* "server" "timeout")))
(if (and (string? tmo)
(string->number tmo))
(* 60 60 (string->number tmo))
- ;; default to three days
- (* 3 24 60 60)))))
- (debug:print-info 2 "server-timeout: " server-timeout ", server pid: " spid " on " iface ":" port)
- (let loop ((count 0))
- (thread-sleep! 4) ;; no need to do this very often
- ;; NB// sync currently does NOT return queue-length
- (let () ;; (queue-len (cdb:client-call server-info 'sync #t 1)))
- ;; (print "Server running, count is " count)
- (if (< count 1) ;; 3x3 = 9 secs aprox
- (loop (+ count 1)))
-
- ;; Check that iface and port have not changed (can happen if server port collides)
- (mutex-lock! *heartbeat-mutex*)
- (set! sdat *runremote*)
- (mutex-unlock! *heartbeat-mutex*)
-
- (if (or (not (equal? sdat (list iface port)))
- (not spid))
- (begin
- (debug:print-info 0 "interface changed, refreshing iface and port info")
- (set! iface (car sdat))
- (set! port (cadr sdat))
- (set! spid (tasks:server-get-server-id tdb #f iface port #f))))
-
- ;; NOTE: Get rid of this mechanism! It really is not needed...
- ;; (open-run-close tasks:server-update-heartbeat tasks:open-db spid)
- (tasks:server-update-heartbeat tdb spid)
-
- ;; (if ;; (or (> numrunning 0) ;; stay alive for two days after last access
- (mutex-lock! *heartbeat-mutex*)
- (set! last-access *last-db-access*)
- (mutex-unlock! *heartbeat-mutex*)
- ;; (debug:print 11 "last-access=" last-access ", server-timeout=" server-timeout)
- (if (and *server-run*
- (> (+ last-access server-timeout)
- (current-seconds)))
- (begin
- (debug:print-info 0 "Server continuing, seconds since last db access: " (- (current-seconds) last-access))
- (loop 0))
- (begin
- (debug:print-info 0 "Starting to shutdown the server.")
- ;; need to delete only *my* server entry (future use)
- (set! *time-to-exit* #t)
- (open-run-close tasks:server-deregister-self tasks:open-db (get-host-name))
- (thread-sleep! 1)
- (debug:print-info 0 "Max cached queries was " *max-cache-size*)
- (debug:print-info 0 "Number of cached writes " *number-of-writes*)
- (debug:print-info 0 "Average cached write time "
- (if (eq? *number-of-writes* 0)
- "n/a (no writes)"
- (/ *writes-total-delay*
- *number-of-writes*))
- " ms")
- (debug:print-info 0 "Number non-cached queries " *number-non-write-queries*)
- (debug:print-info 0 "Average non-cached time "
- (if (eq? *number-non-write-queries* 0)
- "n/a (no queries)"
- (/ *total-non-write-delay*
- *number-non-write-queries*))
- " ms")
- (debug:print-info 0 "Server shutdown complete. Exiting")
- (exit)))))))
+ ;; (* 3 24 60 60) ;; default to three days
+ ;; (* 60 1) ;; default to one minute
+ (* 60 60 25) ;; default to 25 hours
+ ))))
+ (let loop ((count 0)
+ (server-state 'available))
+ ;; Use this opportunity to sync the inmemdb to db
+ (let ((start-time (current-milliseconds))
+ (sync-time #f)
+ (rem-time #f))
+
+ (if *inmemdb* (db:sync-touched *inmemdb* force-sync: #t))
+ (set! sync-time (- (current-milliseconds) start-time))
+ (set! rem-time (quotient (- 4000 sync-time) 1000))
+ (debug:print 0 "SYNC: time= " sync-time ", rem-time=" rem-time)
+
+ ;;
+ ;; set_running after our first pass through
+ ;;
+ (if (eq? server-state 'available)
+ (tasks:server-set-state! tdb server-id "running"))
+
+ (if (and (<= rem-time 4)
+ (> rem-time 0))
+ (thread-sleep! rem-time)
+ (thread-sleep! 4))) ;; fallback for if the math is changed ...
+
+ (if (< count 1) ;; 3x3 = 9 secs aprox
+ (loop (+ count 1) 'running))
+
+ ;; Check that iface and port have not changed (can happen if server port collides)
+ (mutex-lock! *heartbeat-mutex*)
+ (set! sdat *server-info*)
+ (mutex-unlock! *heartbeat-mutex*)
+
+ (if (or (not (equal? sdat (list iface port)))
+ (not server-id))
+ (begin
+ (debug:print-info 0 "interface changed, refreshing iface and port info")
+ (set! iface (car sdat))
+ (set! port (cadr sdat))))
+
+ ;; Transfer *last-db-access* to last-access to use in checking that we are still alive
+ (mutex-lock! *heartbeat-mutex*)
+ (set! last-access *last-db-access*)
+ (mutex-unlock! *heartbeat-mutex*)
+
+ ;; (debug:print 11 "last-access=" last-access ", server-timeout=" server-timeout)
+ ;;
+ ;; no_traffic
+ ;;
+ (if (and *server-run*
+ (> (+ last-access server-timeout)
+ (current-seconds)))
+ (begin
+ (debug:print-info 0 "Server continuing, seconds since last db access: " (- (current-seconds) last-access))
+ ;;
+ ;; Consider implementing some smarts here to re-insert the record or kill self is
+ ;; the db indicates so
+ ;;
+ ;; (if (tasks:server-am-i-the-server? tdb run-id)
+ ;; (tasks:server-set-state! tdb server-id "running"))
+ ;;
+ (loop 0 server-state))
+ (begin
+ (debug:print-info 0 "Starting to shutdown the server.")
+ ;; need to delete only *my* server entry (future use)
+ (set! *time-to-exit* #t)
+ (if *inmemdb* (db:sync-touched *inmemdb* force-sync: #t))
+ ;;
+ ;; start_shutdown
+ ;;
+ ( tasks:server-set-state! tdb server-id "shutting-down")
+ (thread-sleep! 5)
+ (debug:print-info 0 "Max cached queries was " *max-cache-size*)
+ (debug:print-info 0 "Number of cached writes " *number-of-writes*)
+ (debug:print-info 0 "Average cached write time "
+ (if (eq? *number-of-writes* 0)
+ "n/a (no writes)"
+ (/ *writes-total-delay*
+ *number-of-writes*))
+ " ms")
+ (debug:print-info 0 "Number non-cached queries " *number-non-write-queries*)
+ (debug:print-info 0 "Average non-cached time "
+ (if (eq? *number-non-write-queries* 0)
+ "n/a (no queries)"
+ (/ *total-non-write-delay*
+ *number-non-write-queries*))
+ " ms")
+ (debug:print-info 0 "Server shutdown complete. Exiting")
+ (tasks:server-delete-record tdb server-id " http-transport:keep-running")
+ (exit))))))
;; all routes though here end in exit ...
-(define (http-transport:launch)
- (if (not *toppath*)
- (if (not (setup-for-run))
- (begin
- (debug:print 0 "ERROR: cannot find megatest.config, exiting")
- (exit))))
- (debug:print-info 2 "Starting the standalone server")
+;;
+;; start_server?
+;;
+(define (http-transport:launch run-id)
+ (set! *run-id* run-id)
(if (args:get-arg "-daemonize")
(daemon:ize))
- (let ((hostinfo (open-run-close tasks:get-best-server tasks:open-db)))
- (debug:print 11 "http-transport:launch hostinfo=" hostinfo)
- ;; #(1 "143.182.207.24" 5736 -1 "http" 22771 "hostname")
- (if hostinfo
- (debug:print-info 2 "NOT starting new server, one is already running on " (vector-ref hostinfo 1) ":" (vector-ref hostinfo 2))
- (if *toppath*
- (let* ((th2 (make-thread (lambda ()
- (http-transport:run
- (if (args:get-arg "-server")
- (args:get-arg "-server")
- "-"))) "Server run"))
- (th3 (make-thread http-transport:keep-running "Keep running"))
- (th1 (make-thread server:write-queue-handler "write queue")))
- (thread-start! th2)
- (thread-start! th3)
- (thread-start! th1)
- (set! *didsomething* #t)
- (thread-join! th2))
- (debug:print 0 "ERROR: Failed to setup for megatest")))
- (exit)))
-
-;; (use trace)
-;; (trace http-transport:keep-running
-;; tasks:server-update-heartbeat
-;; tasks:server-get-server-id)
-;; tasks:get-best-server
-;; http-transport:run
-;; http-transport:launch
-;; http-transport:try-start-server
-;; http-transport:client-send-receive
-;; http-transport:make-server-url
-;; tasks:server-register
-;; tasks:server-delete
-;; start-server
-;; hostname->ip
-;; with-input-from-request
-;; tasks:server-deregister-self)
+ (if (server:check-if-running run-id)
+ (begin
+ (debug:print 0 "INFO: Server for run-id " run-id " already running")
+ (exit 0)))
+ (let loop ((server-id (open-run-close tasks:server-lock-slot tasks:open-db run-id))
+ (remtries 4))
+ (if (not server-id)
+ (if (> remtries 0)
+ (begin
+ (thread-sleep! 2)
+ (loop (open-run-close tasks:server-lock-slot tasks:open-db run-id)
+ (- remtries 1)))
+ (begin
+ ;; since we didn't get the server lock we are going to clean up and bail out
+ (debug:print-info 2 "INFO: server pid=" (current-process-id) ", hostname=" (get-host-name) " not starting due to other candidates ahead in start queue")
+ (open-run-close tasks:server-delete-records-for-this-pid tasks:open-db " http-transport:launch")
+ ))
+ (let* ((th2 (make-thread (lambda ()
+ (http-transport:run
+ (if (args:get-arg "-server")
+ (args:get-arg "-server")
+ "-")
+ run-id
+ server-id)) "Server run"))
+ (th3 (make-thread (lambda ()
+ (http-transport:keep-running server-id))
+ "Keep running")))
+ ;; Database connection
+ (set! *inmemdb* (db:setup run-id))
+ (thread-start! th2)
+ (thread-start! th3)
+ (set! *didsomething* #t)
+ (thread-join! th2)
+ (exit)))))
(define (http-transport:server-signal-handler signum)
(handle-exceptions
exn
(debug:print " ... exiting ...")
(let ((th1 (make-thread (lambda ()
(thread-sleep! 1))
- ;; (if (not *received-response*)
- ;; (receive-message* *runremote*))) ;; flush out last call if applicable
"eat response"))
(th2 (make-thread (lambda ()
(debug:print 0 "ERROR: Received ^C, attempting clean exit. Please be patient and wait a few seconds before hitting ^C again.")
(thread-sleep! 3) ;; give the flush three seconds to do it's stuff
(debug:print 0 " Done.")
Index: launch.scm
==================================================================
--- launch.scm
+++ launch.scm
@@ -11,18 +11,21 @@
;;======================================================================
;; launch a task - this runs on the originating host, tests themselves
;;
;;======================================================================
-(use regex regex-case base64 sqlite3 srfi-18)
+(use regex regex-case base64 sqlite3 srfi-18 directory-utils posix-extras)
(import (prefix base64 base64:))
(import (prefix sqlite3 sqlite3:))
(declare (unit launch))
(declare (uses common))
(declare (uses configf))
(declare (uses db))
+;; (declare (uses sdb))
+(declare (uses tdb))
+;; (declare (uses filedb))
(include "common_records.scm")
(include "key_records.scm")
(include "db_records.scm")
@@ -87,15 +90,11 @@
fulln
runscript))))) ;; assume it is on the path
(rollup-status 0))
(change-directory top-path)
(debug:print 2 "Exectuing " test-name " (id: " test-id ") on " (get-host-name))
- ;; Setup the *runremote* global var
- (if *runremote* (debug:print 2 "ERROR: I'm not expecting *runremote* to be set at this time"))
- ;; (set! *runremote* runremote)
- ;; (set! *transport-type* (string->symbol transport))
- (set! keys (cdb:remote-run db:get-keys #f))
+ (set! keys (rmt:get-keys))
(set! keyvals (keys:target->keyval keys target))
;; apply pre-overrides before other variables. The pre-override vars must not
;; clobbers things from the official sources such as megatest.config and runconfigs.config
(if (string? set-vars)
(let ((varpairs (string-split set-vars ",")))
@@ -145,14 +144,14 @@
(alist->env-vars env-ovrd)
(set-megatest-env-vars run-id inkeys: keys inkeyvals: keyvals)
(set-item-env-vars itemdat)
(save-environment-as-files "megatest")
;; open-run-close not needed for test-set-meta-info
- (tests:set-full-meta-info #f test-id run-id 0 work-area)
+ (tests:set-full-meta-info test-id run-id 0 work-area)
;; (tests:test-set-status! test-id "REMOTEHOSTSTART" "n/a" (args:get-arg "-m") #f)
- (tests:test-force-state-status! test-id "REMOTEHOSTSTART" "n/a")
+ (tests:test-force-state-status! run-id test-id "REMOTEHOSTSTART" "n/a")
(thread-sleep! 0.3) ;; NFS slowness has caused grief here
(if (args:get-arg "-xterm")
(set! fullrunscript "xterm")
(if (and fullrunscript (not (file-execute-access? fullrunscript)))
@@ -176,11 +175,11 @@
;; any of the other stuff that tests:test-set-status! does. Let's just
;; force RUNNING/n/a
(thread-sleep! 0.3)
- (tests:test-force-state-status! test-id "RUNNING" "n/a")
+ (tests:test-force-state-status! run-id test-id "RUNNING" "n/a")
(thread-sleep! 0.3) ;; NFS slowness has caused grief here
;; if there is a runscript do it first
(if fullrunscript
(let ((pid (process-run fullrunscript)))
@@ -234,12 +233,11 @@
;; call the command using mt_ezstep
(set! script (conc "mt_ezstep " stepname " " (if prevstep prevstep "-") " " stepcmd))
(debug:print 4 "script: " script)
- ;; DO NOT remote
- (db:teststep-set-status! #f test-id stepname "start" "-" #f #f work-area: work-area)
+ (rmt:teststep-set-status! run-id test-id stepname "start" "-" #f #f)
;; now launch
(let ((pid (process-run script)))
(let processloop ((i 0))
(let-values (((pid-val exit-status exit-code)(process-wait pid #t)))
(mutex-lock! m)
@@ -252,14 +250,13 @@
(thread-sleep! 2)
(processloop (+ i 1))))
))
(let ((exinfo (vector-ref exit-info 2))
(logfna (if logpro-used (conc stepname ".html") "")))
- ;; testing if procedures called in a remote call cause problems (ans: no or so I suspect)
- (db:teststep-set-status! #f test-id stepname "end" exinfo #f logfna work-area: work-area))
+ (rmt:teststep-set-status! run-id test-id stepname "end" exinfo #f logfna))
(if logpro-used
- (cdb:test-set-log! *runremote* test-id (conc stepname ".html")))
+ (rmt:test-set-log! run-id test-id (conc stepname ".html")))
;; set the test final status
(let* ((this-step-status (cond
((and (eq? (vector-ref exit-info 2) 2) logpro-used) 'warn)
((eq? (vector-ref exit-info 2) 0) 'pass)
(else 'fail)))
@@ -283,18 +280,18 @@
" next-status: " next-status " rollup-status: " rollup-status)
(case next-status
((warn)
(set! rollup-status 2)
;; NB// test-set-status! does rdb calls under the hood
- (tests:test-set-status! test-id next-state "WARN"
+ (tests:test-set-status! run-id test-id next-state "WARN"
(if (eq? this-step-status 'warn) "Logpro warning found" #f)
#f))
((pass)
- (tests:test-set-status! test-id next-state "PASS" #f #f))
+ (tests:test-set-status! run-id test-id next-state "PASS" #f #f))
(else ;; 'fail
(set! rollup-status 1) ;; force fail, this used to be next-state but that doesn't make sense. should always be "COMPLETED"
- (tests:test-set-status! test-id "COMPLETED" "FAIL" (conc "Failed at step " stepname) #f)
+ (tests:test-set-status! run-id test-id "COMPLETED" "FAIL" (conc "Failed at step " stepname) #f)
))))
(if (and (steprun-good? logpro-used (vector-ref exit-info 2))
(not (null? tal)))
(loop (car tal) (cdr tal) stepname)))
(debug:print 4 "WARNING: a prior step failed, stopping at " ezstep))))))))
@@ -305,23 +302,24 @@
(round
(-
(current-seconds)
start-seconds)))))
(kill-tries 0))
- (tests:set-full-meta-info #f test-id run-id (calc-minutes) work-area)
+ (tests:set-full-meta-info test-id run-id (calc-minutes) work-area)
(let loop ((minutes (calc-minutes)))
(begin
- (set! kill-job? (or (test-get-kill-request test-id) ;; run-id test-name itemdat))
+ (set! kill-job? (or (test-get-kill-request run-id test-id) ;; run-id test-name itemdat))
(and runtlim (let* ((run-seconds (- (current-seconds) start-seconds))
(time-exceeded (> run-seconds runtlim)))
(if time-exceeded
(begin
(debug:print-info 0 "KILLING TEST DUE TO TIME LIMIT EXCEEDED! Runtime=" run-seconds " seconds, limit=" runtlim)
#t)
#f)))))
;; open-run-close not needed for test-set-meta-info
- (tests:set-partial-meta-info #f test-id run-id minutes work-area)
+ (tests:update-central-meta-info run-id test-id (get-cpu-load) (get-df (current-directory))(calc-minutes) #f #f)
+ ;; (tests:set-partial-meta-info test-id run-id minutes work-area)
(if kill-job?
(begin
(mutex-lock! m)
;; NOTE: The pid can change as different steps are run. Do we need handshaking between this
;; section and the runit section? Or add a loop that tries three times with a 1/4 second
@@ -344,40 +342,35 @@
;; (system (conc "kill -9 " p-id))))))
;; (car processes))
;; (system (conc "kill -9 -" pid))))
(begin
(debug:print 0 "WARNING: Request received to kill job but problem with process, attempting to kill manager process")
- (tests:test-set-status! test-id "KILLED" "FAIL"
+ (tests:test-set-status! run-id test-id "KILLED" "FAIL"
(args:get-arg "-m") #f)
- (sqlite3:finalize! tdb)
(exit 1) ;; IS THIS NECESSARY OR WISE???
)))
(set! kill-tries (+ 1 kill-tries))
(mutex-unlock! m)))
- ;; (sqlite3:finalize! db)
(if keep-going
(begin
(thread-sleep! 3) ;; (+ 3 (random 6))) ;; add some jitter to the call home time to spread out the db accesses
(if keep-going
(loop (calc-minutes)))))))
- (tests:update-central-meta-info test-id (get-cpu-load) (get-df (current-directory))(calc-minutes) #f #f)))) ;; NOTE: Checking twice for keep-going is intentional
+ (tests:update-central-meta-info run-id test-id (get-cpu-load) (get-df (current-directory))(calc-minutes) #f #f)))) ;; NOTE: Checking twice for keep-going is intentional
(th1 (make-thread monitorjob "monitor job"))
(th2 (make-thread runit "run job")))
(set! job-thread th2)
(thread-start! th1)
(thread-start! th2)
(thread-join! th2)
(set! keep-going #f)
(thread-join! th1)
- ;; (thread-sleep! 1)
- ;; (thread-terminate! th1) ;; Not sure if this is a good idea
(thread-sleep! 1) ;; give thread th1 a chance to be done TODO: Verify this is needed. At 0.1 I was getting fail to stop, increased to total of 1.1 sec.
- ;; (tests:update-central-meta-info test-id cpuload diskfree minutes #f #f)
(mutex-lock! m)
(let* ((item-path (item-list->path itemdat))
;; only state and status needed - use lazy routine
- (testinfo (cdb:remote-run db:get-testinfo-state-status #f test-id))) ;;;(cdb:get-test-info-by-id *runremote* test-id))) ;; )) ;; run-id test-name item-path)))
+ (testinfo (rmt:get-testinfo-state-status run-id test-id)))
;; Am I completed?
(if (member (db:test-get-state testinfo) '("REMOTEHOSTSTART" "RUNNING")) ;; NOTE: It should *not* be REMOTEHOSTSTART but for reasons I don't yet understand it sometimes gets stuck in that state ;; (not (equal? (db:test-get-state testinfo) "COMPLETED"))
(let ((new-state (if kill-job? "KILLED" "COMPLETED") ;; (if (eq? (vector-ref exit-info 2) 0) ;; exited with "good" status
;; "COMPLETED"
;; (db:test-get-state testinfo))) ;; else preseve the state as set within the test
@@ -391,24 +384,21 @@
((eq? rollup-status 2)
;; if the current status is AUTO the defer to the calculated value but qualify (i.e. make this AUTO-WARN)
(if (equal? (db:test-get-status testinfo) "AUTO") "AUTO-WARN" "WARN"))
(else "FAIL")))) ;; (db:test-get-status testinfo)))
(debug:print-info 1 "Test exited in state=" (db:test-get-state testinfo) ", setting state/status based on exit code of " (vector-ref exit-info 1) " and rollup-status of " rollup-status)
- (tests:test-set-status! test-id
+ (tests:test-set-status! run-id
+ test-id
new-state
new-status
(args:get-arg "-m") #f)
;; need to update the top test record if PASS or FAIL and this is a subtest
;; NO NEED TO CALL roll-up-pass-fail-counts HERE, THIS IS DONE IN roll-up-pass-fail-counts called by tests:test-set-status!
- ;; (if (not (equal? item-path ""))
- ;; (begin
- ;; (thread-sleep! 0.1) ;; give other processes an opportunity to access the db as rollup is lower priority
- ;; (cdb:roll-up-pass-fail-counts *runremote* run-id test-name item-path new-status)))
))
;; for automated creation of the rollup html file this is a good place...
(if (not (equal? item-path ""))
- (tests:summarize-items #f run-id test-id test-name #f))) ;; don't force - just update if no
+ (tests:summarize-items run-id test-id test-name #f))) ;; don't force - just update if no
(mutex-unlock! m)
(debug:print 2 "Output from running " fullrunscript ", pid " (vector-ref exit-info 0) " in work area "
work-area ":\n====\n exit code " (vector-ref exit-info 2) "\n" "====\n")
(if (not (vector-ref exit-info 1))
(exit 4)))))))
@@ -426,13 +416,39 @@
environ-patt: "env-override"
given-toppath: (get-environment-variable "MT_RUN_AREA_HOME")
pathenvvar: "MT_RUN_AREA_HOME"))
(set! *configdat* (if (car *configinfo*)(car *configinfo*) #f))
(set! *toppath* (if (car *configinfo*)(cadr *configinfo*) #f))
- (if *toppath*
- (setenv "MT_RUN_AREA_HOME" *toppath*) ;; to be deprecated
- (debug:print 0 "ERROR: failed to find the top path to your Megatest area."))))
+ (let ((linktree (configf:lookup *configdat* "setup" "linktree"))) ;; link tree is critical
+ (if linktree
+ (if (not (file-exists? linktree))
+ (begin
+ (handle-exceptions
+ exn
+ (begin
+ (debug:print 0 "ERROR: Something went wrong when trying to create linktree dir at " linktree)
+ (exit 1))
+ (create-directory linktree #t))))
+ (begin
+ (debug:print 0 "ERROR: linktree not defined in [setup] section of megatest.config")
+ (exit 1)))
+ (if linktree
+ (let ((dbdir (conc linktree "/.db")))
+ (handle-exceptions
+ exn
+ (debug:print 0 "ERROR: failed to create the " dbdir " area for your database files")
+ (if (not (directory-exists? dbdir))(create-directory dbdir)))
+ (setenv "MT_LINKTREE" linktree))
+ (begin
+ (debug:print 0 "ERROR: linktree is required in your megatest.config [setup] section")
+ (exit 1)))
+ (if (and *toppath*
+ (directory-exists? *toppath*))
+ (setenv "MT_RUN_AREA_HOME" *toppath*)
+ (begin
+ (debug:print 0 "ERROR: failed to find the top path to your Megatest area.")
+ (exit 1))))))
*toppath*)
(define (get-best-disk confdat)
(let* ((disks (hash-table-ref/default confdat "disks" #f))
(best #f)
@@ -473,11 +489,11 @@
;;
;; <target> - <testname> [ - <itempath> ]
;;
(define (create-work-area run-id run-info keyvals test-id test-src-path disk-path testname itemdat)
(let* ((item-path (item-list->path itemdat))
- (runname (db:get-value-by-header (db:get-row run-info)
+ (runname (db:get-value-by-header (db:get-rows run-info)
(db:get-header run-info)
"runname"))
;; convert back to db: from rdb: - this is always run at server end
(target (string-intersperse (map cadr keyvals) "/"))
@@ -498,11 +514,11 @@
(lnkbase (conc linktree "/" target "/" runname))
(lnkpath (conc lnkbase "/" testname))
(lnkpathf (conc lnkpath (if not-iterated "" "/") item-path)))
;; Update the rundir path in the test record for all
- (cdb:test-set-rundir-by-test-id *runremote* test-id lnkpathf)
+ (rmt:general-call 'test-set-rundir-shortdir run-id lnkpathf test-path testname item-path)
(debug:print 2 "INFO:\n lnkbase=" lnkbase "\n lnkpath=" lnkpath "\n toptest-path=" toptest-path "\n test-path=" test-path)
(if (not (file-exists? linktree))
(begin
(debug:print 0 "WARNING: linktree did not exist! Creating it now at " linktree)
@@ -515,25 +531,10 @@
;; update the toptest record with its location rundir, cache the path
;; This wass highly inefficient, one db write for every subtest, potentially
;; thousands of unnecessary updates, cache the fact it was set and don't set it
;; again.
- ;; NB - This is not working right - some top tests are not getting the path set!!!
-
- (if (not (hash-table-ref/default *toptest-paths* testname #f))
- (let* ((testinfo (cdb:get-test-info-by-id *runremote* test-id)) ;; run-id testname item-path))
- (curr-test-path (if testinfo (db:test-get-rundir testinfo) #f)))
- (hash-table-set! *toptest-paths* testname curr-test-path)
- ;; NB// Was this for the test or for the parent in an iterated test?
- (cdb:test-set-rundir! *runremote* run-id testname "" lnkpath) ;; toptest-path)
- (if (or (not curr-test-path)
- (not (directory-exists? toptest-path)))
- (begin
- (debug:print-info 2 "Creating " toptest-path " and link " lnkpath)
- (create-directory toptest-path #t)
- (hash-table-set! *toptest-paths* testname toptest-path)))))
-
;; Now create the link from the test path to the link tree, however
;; if the test is iterated it is necessary to create the parent path
;; to the iteration. use pathname-directory to trim the path by one
;; level
(if (not not-iterated) ;; i.e. iterated
@@ -561,10 +562,38 @@
(begin
(debug:print 0 "ERROR: Failed to create symlink " lnkpath ((condition-property-accessor 'exn 'message) exn) ", exiting")
(exit 1))
(create-symbolic-link toptest-path lnkpath)))
+ ;; NB - This was not working right - some top tests are not getting the path set!!!
+ ;;
+ ;; Do the setting of this record after the paths are created so that the shortdir can
+ ;; be set to the real directory location. This is safer for future clean up if the link
+ ;; tree is damaged or lost.
+ ;;
+ (if (not (hash-table-ref/default *toptest-paths* testname #f))
+ (let* ((testinfo (rmt:get-test-info-by-id run-id test-id)) ;; run-id testname item-path))
+ (curr-test-path (if testinfo ;; (filedb:get-path *fdb*
+ ;; (db:get-path dbstruct
+ ;; (rmt:sdb-qry 'getstr
+ (db:test-get-rundir testinfo) ;; ) ;; )
+ #f)))
+ (hash-table-set! *toptest-paths* testname curr-test-path)
+ ;; NB// Was this for the test or for the parent in an iterated test?
+ (rmt:general-call 'test-set-rundir-shortdir run-id lnkpath
+ (if (file-exists? lnkpath)
+ (resolve-pathname lnkpath)
+ lnkpath)
+ testname "")
+ ;; (rmt:general-call 'test-set-rundir run-id lnkpath testname "") ;; toptest-path)
+ (if (or (not curr-test-path)
+ (not (directory-exists? toptest-path)))
+ (begin
+ (debug:print-info 2 "Creating " toptest-path " and link " lnkpath)
+ (create-directory toptest-path #t)
+ (hash-table-set! *toptest-paths* testname toptest-path)))))
+
;; The toptest path has been created, the link to the test in the linktree has
;; been created. Now, if this is an iterated test the real test dir must be created
(if (not not-iterated) ;; this is an iterated test
(let ((lnktarget (conc lnkpath "/" item-path)))
(debug:print 2 "Setting up sub test run area")
@@ -581,24 +610,15 @@
;; If there is already a symlink delete it and recreate it.
(handle-exceptions
exn
(begin
- (debug:print 0 "ERROR: Failed to re-create link " lnktarget ((condition-property-accessor 'exn 'message) exn) ", exiting")
+ (debug:print 0 "ERROR: Failed to re-create link " linktarget ((condition-property-accessor 'exn 'message) exn) ", exiting")
(exit))
(if (symbolic-link? lnktarget) (delete-file lnktarget))
(if (not (file-exists? lnktarget)) (create-symbolic-link test-path lnktarget)))))
- ;; I suspect this section was deleting test directories under some
- ;; wierd sitations? This doesn't make sense - reenabling the rm -f
- ;; I honestly don't remember *why* this chunk was needed...
- ;; (let ((testlink (conc lnkpath "/" testname)))
- ;; (if (and (file-exists? testlink)
- ;; (or (regular-file? testlink)
- ;; (symbolic-link? testlink)))
- ;; (system (conc "rm -f " testlink)))
- ;; (system (conc "ln -sf " test-path " " testlink)))
(if (directory? test-path)
(begin
(let* ((ovrcmd (let ((cmd (config-lookup *configdat* "setup" "testcopycmd")))
(if cmd
;; substitute the TEST_SRC_PATH and TEST_TARG_PATH
@@ -667,11 +687,11 @@
(cmdparms #f)
(fullcmd #f) ;; (define a (with-output-to-string (lambda ()(write x))))
(mt-bindir-path #f)
(item-path (item-list->path itemdat))
;; (test-id (cdb:remote-run db:get-test-id #f run-id test-name item-path))
- (testinfo (cdb:get-test-info-by-id *runremote* test-id))
+ (testinfo (rmt:get-test-info-by-id run-id test-id))
(mt_target (string-intersperse (map cadr keyvals) "/"))
(debug-param (append (if (args:get-arg "-debug") (list "-debug" (args:get-arg "-debug")) '())
(if (args:get-arg "-logging")(list "-logging") '()))))
(setenv "MT_ITEMPATH" item-path)
(if hosts (set! hosts (string-split hosts)))
@@ -692,11 +712,10 @@
(debug:print 0 "WARNING: No disk work area specified - running in the test directory under tmp_run")))
(set! cmdparms (base64:base64-encode
(with-output-to-string
(lambda () ;; (list 'hosts hosts)
(write (list (list 'testpath test-path)
- ;; (list 'runremote *runremote*)
(list 'transport (conc *transport-type*))
(list 'serverinf *server-info*)
(list 'toppath *toppath*)
(list 'work-area work-area)
(list 'test-name test-name)
@@ -714,11 +733,11 @@
(list 'mt-bindir-path mt-bindir-path)))))))
;; clean out step records from previous run if they exist
;; (debug:print-info 4 "FIXMEEEEE!!!! This can be removed some day, perhaps move all test records to the test db?")
;; (open-run-close db:delete-test-step-records db test-id)
(change-directory work-area) ;; so that log files from the launch process don't clutter the test dir
- (tests:test-set-status! test-id "LAUNCHED" "n/a" #f #f) ;; (if launch-results launch-results "FAILED"))
+ (tests:test-set-status! run-id test-id "LAUNCHED" "n/a" #f #f) ;; (if launch-results launch-results "FAILED"))
(cond
((and launcher hosts) ;; must be using ssh hostname
(set! fullcmd (append launcher (car hosts)(list remote-megatest test-sig "-execute" cmdparms) debug-param)))
;; (set! fullcmd (append launcher (car hosts)(list remote-megatest test-sig "-execute" cmdparms))))
(launcher
Index: lock-queue.scm
==================================================================
--- lock-queue.scm
+++ lock-queue.scm
@@ -47,25 +47,45 @@
run_lock TEXT,
CONSTRAINT runlock_constraint UNIQUE (run_lock));")))
(sqlite3:set-busy-handler! db handler)
db))
-(define (lock-queue:set-state db test-id newstate)
- (sqlite3:execute db "UPDATE queue SET state=? WHERE test_id=?;"
- newstate
- test-id))
-
-(define (lock-queue:any-younger? db mystart test-id)
- (let ((res #f))
- (sqlite3:for-each-row
- (lambda (tid)
- ;; Actually this should not be needed as mystart cannot be simultaneously less than and test-id same as
- (if (not (equal? tid test-id))
- (set! res tid)))
- db
- "SELECT test_id FROM queue WHERE start_time > ?;" mystart)
- res))
+(define (lock-queue:set-state db test-id newstate #!key (remtries 10))
+ (handle-exceptions
+ exn
+ (if (> remtries 0)
+ (begin
+ (debug:print 0 "WARNING: exception on lock-queue:set-state. Trying again in 30 seconds.")
+ (thread-sleep! 30)
+ (lock-queue:set-state db test-id newstate remtries: (- remtries 1)))
+ (begin
+ (debug:print 0 "ERROR: Failed to set lock state for test with id " test-id ", error: " ((condition-property-accessor 'exn 'message) exn) ", giving up.")
+ #f))
+ (sqlite3:execute db "UPDATE queue SET state=? WHERE test_id=?;"
+ newstate
+ test-id)))
+
+(define (lock-queue:any-younger? db mystart test-id #!key (remtries 10))
+ (handle-exceptions
+ exn
+ (if (> remtries 0)
+ (begin
+ (debug:print 0 "WARNING: exception on lock-queue:any-younger. Trying again in 30 seconds.")
+ (thread-sleep! 30)
+ (lock-queue:any-younger? db mystart test-id remtries: (- remtries 1)))
+ (begin
+ (debug:print 0 "ERROR: Failed to find younger locks for test with id " test-id ", error: " ((condition-property-accessor 'exn 'message) exn) ", giving up.")
+ #f))
+ (let ((res #f))
+ (sqlite3:for-each-row
+ (lambda (tid)
+ ;; Actually this should not be needed as mystart cannot be simultaneously less than and test-id same as
+ (if (not (equal? tid test-id))
+ (set! res tid)))
+ db
+ "SELECT test_id FROM queue WHERE start_time > ?;" mystart)
+ res)))
(define (lock-queue:get-lock db test-id)
(let ((res #f)
(lckqry (sqlite3:prepare db "SELECT test_id,run_lock FROM runlocks WHERE run_lock='locked';"))
(mklckqry (sqlite3:prepare db "INSERT INTO runlocks (test_id,run_lock) VALUES (?,'locked');")))
Index: megatest-version.scm
==================================================================
--- megatest-version.scm
+++ megatest-version.scm
@@ -1,7 +1,7 @@
;; Always use two digit decimal
;; 1.01, 1.02...1.10,1.11 ... 1.99,2.00..
(declare (unit megatest-version))
-(define megatest-version 1.5515)
+(define megatest-version 1.6001)
Index: megatest.scm
==================================================================
--- megatest.scm
+++ megatest.scm
@@ -25,10 +25,16 @@
(declare (uses client))
(declare (uses tests))
(declare (uses genexample))
(declare (uses daemon))
(declare (uses db))
+;; (declare (uses sdb))
+;; (declare (uses filedb))
+(declare (uses tdb))
+(declare (uses mt))
+(declare (uses api))
+(declare (uses tasks)) ;; only used for debugging.
(define *db* #f) ;; this is only for the repl, do not use in general!!!!
(include "common_records.scm")
(include "key_records.scm")
@@ -119,18 +125,18 @@
-env2file fname : write the environment to fname.csh and fname.sh
-setvars VAR1=val1,VAR2=val2 : Add environment variables to a run NB// these are
overwritten by values set in config files.
-server -|hostname : start the server (reduces contention on megatest.db), use
- to automatically figure out hostname
- -transport http|fs : use http or direct access for transport (default is http)
-daemonize : fork into background and disconnect from stdin/out
-list-servers : list the servers
-stop-server id : stop server specified by id (see output of -list-servers), use
0 to kill all
-repl : start a repl (useful for extending megatest)
-load file.scm : load and run file.scm
-mark-incompletes : find and mark incomplete tests
+ -ping run-id|host:port : ping server, exit with 0 if found
Spreadsheet generation
-extract-ods fname.ods : extract an open document spreadsheet from the database
-pathmod path : insert path, i.e. path/runame/itempath/logfile.html
will clear the field if no rundir/testname/itempath/logfile
@@ -187,11 +193,10 @@
":tol"
":units"
;; misc
"-start-dir"
"-server"
- "-transport"
"-stop-server"
"-port"
"-extract-ods"
"-pathmod"
"-env2file"
@@ -202,10 +207,12 @@
"-gen-megatest-test"
"-override-timeout"
"-test-files" ;; -test-paths is for listing all
"-load" ;; load and exectute a scheme file
"-dumpmode"
+ "-run-id"
+ "-ping"
)
(list "-h"
"-version"
"-force"
"-xterm"
@@ -244,10 +251,14 @@
"-rollup"
"-update-meta"
"-gen-megatest-area"
"-mark-incompletes"
+ "-convert-to-norm"
+ "-convert-to-old"
+ "-import-megatest.db"
+
"-logging"
"-v" ;; verbose 2, more than normal (normal is 1)
"-q" ;; quiet 0, errors/warnings only
)
args:arg-hash
@@ -294,16 +305,10 @@
(printf "Sending signal/term to ~A\n" pid)
(process-signal pid signal/term))))))
(process:children #f))
(original-exit exit-code)))))
-;; Force default transport to fs
-;; (if ;; (and (or (args:get-arg "-list-targets")
-;; ;; (args:get-arg "-list-db-targets"))
-;; (not (args:get-arg "-transport"))
-;; (hash-table-set! args:arg-hash "-transport" "fs"))
-
;;======================================================================
;; Misc setup stuff
;;======================================================================
(debug:setup)
@@ -338,10 +343,15 @@
" => "))
(common:get-disks) )
"\n"))
(set! *didsomething* #t)))
+(if (args:get-arg "-ping")
+ (let* ((run-id (string->number (args:get-arg "-run-id")))
+ (host:port (args:get-arg "-ping")))
+ (server:ping run-id host:port)))
+
;;======================================================================
;; Start the server - can be done in conjunction with -runall or -runtests (one day...)
;; we start the server if not running else start the client thread
;;======================================================================
@@ -348,55 +358,44 @@
(if (args:get-arg "-server")
;; Server? Start up here.
;;
(let ((tl (setup-for-run))
- (transport (or (configf:lookup *configdat* "setup" "transport")
- (args:get-arg "-transport" "http"))))
- (debug:print 2 "Launching server using transport " transport)
- (server:launch (string->symbol transport)))
+ (run-id (and (args:get-arg "-run-id")
+ (string->number (args:get-arg "-run-id")))))
+ (if run-id
+ (begin
+ (server:launch run-id)
+ (set! *didsomething* #t))
+ (debug:print 0 "ERROR: server requires run-id be specified with -run-id")))
;; Not a server? This section will decide how to communicate
;;
;; Setup client for all expect listed here
(if (null? (lset-intersection
equal?
(hash-table-keys args:arg-hash)
'("-list-servers"
"-stop-server"
- "-show-cmdinfo")))
+ "-show-cmdinfo"
+ "-list-runs")))
(if (setup-for-run)
- (begin
-
+ (let ((run-id (and (args:get-arg "-run-id")
+ (string->number (args:get-arg "-run-id")))))
+ ;; (set! *fdb* (filedb:open-db (conc *toppath* "/db/paths.db")))
;; if not list or kill then start a client (if appropriate)
(if (or (args-defined? "-h" "-version" "-gen-megatest-area" "-gen-megatest-test")
(eq? (length (hash-table-keys args:arg-hash)) 0))
(debug:print-info 1 "Server connection not needed")
- ;; ok, so lets connect to the server
- (let* ((transport-from-config (configf:lookup *configdat* "setup" "transport"))
- (transport-from-cmdln (args:get-arg "-transport"))
- (transport-from-cmdinfo (if (getenv "MT_CMDINFO")
- (let ((res (assoc 'transport
- (read
- (open-input-string
- (base64:base64-decode
- (getenv "MT_CMDINFO")))))))
- (if res (cadr res) #f))
- #f))
- (chosen-transport (string->symbol (or transport-from-cmdln
- transport-from-cmdinfo
- transport-from-config
- "fs"))))
- (debug:print 2 "chosen-transport: " chosen-transport " have; config=" transport-from-config ", cmdln=" transport-from-cmdln ", cmdinfo=" transport-from-cmdinfo)
- (case chosen-transport
- ((http)
- (set! *transport-type 'http)
- (server:ensure-running)
- (client:launch))
- (else ;; (fs)
- (set! *transport-type* 'fs)
- (set! *megatest-db* (open-db))))))))))
+ (begin
+ (if run-id
+ (client:launch run-id)
+ (client:launch 0) ;; without run-id we'll start a server for "0"
+ )))))))
+
+;; MAY STILL NEED THIS
+;; (set! *megatest-db* (make-dbr:dbstruct path: *toppath* local: #t))))))))))
(if (or (args:get-arg "-list-servers")
(args:get-arg "-stop-server"))
(let ((tl (setup-for-run)))
(if tl
@@ -418,11 +417,11 @@
(pubport (vector-ref server 5))
(start-time (vector-ref server 6))
(priority (vector-ref server 7))
(state (vector-ref server 8))
(mt-ver (vector-ref server 9))
- (last-update (vector-ref server 10)) ;; (open-run-close tasks:server-alive? tasks:open-db #f hostname: hostname port: port))
+ (last-update (vector-ref server 10))
(transport (vector-ref server 11))
(killed #f)
(status (< last-update 20)))
;; (zmq-sockets (if status (server:client-connect hostname port) #f)))
;; no need to login as status of #t indicates we are connecting to correct
@@ -457,11 +456,11 @@
(print x))
targets)
(set! *didsomething* #t)))
(define (full-runconfigs-read)
- (let* ((keys (cdb:remote-run db:get-keys #f))
+ (let* ((keys (rmt:get-keys))
(target (if (args:get-arg "-reqtarg")
(args:get-arg "-reqtarg")
(if (args:get-arg "-target")
(args:get-arg "-target")
#f)))
@@ -588,21 +587,24 @@
;;======================================================================
;; Query runs
;;======================================================================
+;; NOTE: list-runs and list-db-targets operate on local db!!!
+;;
(if (or (args:get-arg "-list-runs")
(args:get-arg "-list-db-targets"))
(if (setup-for-run)
- (let* ((db #f)
+ (let* ((dbstruct (make-dbr:dbstruct path: *toppath* local: #t))
(runpatt (args:get-arg "-list-runs"))
(testpatt (if (args:get-arg "-testpatt")
(args:get-arg "-testpatt")
"%"))
- (keys (cdb:remote-run db:get-keys #f))
- (runsdat (cdb:remote-run db:get-runs-by-patt #f keys runpatt (or (args:get-arg "-target")
- (args:get-arg "-reqtarg")) #f #f))
+ (keys (db:get-keys dbstruct))
+ ;; (runsdat (db:get-runs dbstruct runpatt #f #f '()))
+ (runsdat (db:get-runs-by-patt dbstruct keys runpatt (or (args:get-arg "-target")
+ (args:get-arg "-reqtarg")) #f #f))
;; (cdb:remote-run db:get-runs #f runpatt #f #f '()))
(runs (db:get-rows runsdat))
(header (db:get-header runsdat))
(db-targets (args:get-arg "-list-db-targets"))
(seen (make-hash-table)))
@@ -618,11 +620,11 @@
(hash-table-set! seen targetstr #t)
;; (print "[" targetstr "]"))))
(print targetstr))))
(if (not db-targets)
(let* ((run-id (db:get-value-by-header run header "id"))
- (tests (mt:get-tests-for-run run-id testpatt '() '())))
+ (tests (db:get-tests-for-run dbstruct run-id testpatt '() '() #f #f #f 'testname 'asc #f)))
(print "Run: " targetstr "/" (db:get-value-by-header run header "runname")
" status: " (db:get-value-by-header run header "state")
" run-id: " run-id ", number tests: " (length tests))
(for-each
(lambda (test)
@@ -636,33 +638,36 @@
(db:test-get-status test)
(db:test-get-run_duration test)
(db:test-get-event_time test)
(db:test-get-host test))
(if (not (or (equal? (db:test-get-status test) "PASS")
- (equal? (db:test-get-status test) "WARN")
+ (equal? (db:test-get-status test) "WARN")
(equal? (db:test-get-state test) "NOT_STARTED")))
(begin
- (print " cpuload: " (db:test-get-cpuload test)
+ (print " cpuload: " (db:test-get-cpuload test)
"\n diskfree: " (db:test-get-diskfree test)
- "\n uname: " (db:test-get-uname test)
- "\n rundir: " (db:test-get-rundir test)
+ "\n uname: " ;; (sdb:qry 'getstr
+ (db:test-get-uname test) ;; )
+ "\n rundir: " ;; (sdb:qry 'getstr ;; (filedb:get-path *fdb*
+ (db:test-get-rundir test) ;; )
)
;; Each test
;; DO NOT remote run
- (let ((steps (db:get-steps-for-test #f (db:test-get-id test))))
+ (let ((steps (db:get-steps-for-test dbstruct run-id (db:test-get-id test))))
(for-each
(lambda (step)
(format #t
" Step: ~20a State: ~10a Status: ~10a Time ~22a\n"
- (db:step-get-stepname step)
- (db:step-get-state step)
- (db:step-get-status step)
- (db:step-get-event_time step)))
+ (tdb:step-get-stepname step)
+ (tdb:step-get-state step)
+ (tdb:step-get-status step)
+ (tdb:step-get-event_time step)))
steps)))))
tests)))))
runs)
- (set! *didsomething* #t))))
+ (db:close-all dbstruct)
+ (set! *didsomething* #t))))
;;======================================================================
;; full run
;;======================================================================
@@ -712,10 +717,21 @@
(if (args:get-arg "-runtests")
(general-run-call
"-runtests"
"run a test"
(lambda (target runname keys keyvals)
+ ;;
+ ;; May or may not implement it this way ...
+ ;;
+ ;; Insert this run into the tasks queue
+ ;; (open-run-close tasks:add tasks:open-db
+ ;; "runtests"
+ ;; user
+ ;; target
+ ;; runname
+ ;; (args:get-arg "-runtests")
+ ;; #f))))
(runs:run-tests target
runname
(args:get-arg "-runtests")
user
args:arg-hash))))
@@ -758,37 +774,32 @@
(if (or (args:get-arg "-test-files")(args:get-arg "-test-paths"))
;; if we are in a test use the MT_CMDINFO data
(if (getenv "MT_CMDINFO")
(let* ((startingdir (current-directory))
(cmdinfo (read (open-input-string (base64:base64-decode (getenv "MT_CMDINFO")))))
- ;; (runremote (assoc/default 'runremote cmdinfo))
- (transport (assoc/default 'transport cmdinfo))
(testpath (assoc/default 'testpath cmdinfo))
(test-name (assoc/default 'test-name cmdinfo))
(runscript (assoc/default 'runscript cmdinfo))
(db-host (assoc/default 'db-host cmdinfo))
(run-id (assoc/default 'run-id cmdinfo))
(itemdat (assoc/default 'itemdat cmdinfo))
- (db #f)
(state (args:get-arg ":state"))
(status (args:get-arg ":status"))
(target (args:get-arg "-target"))
(toppath (assoc/default 'toppath cmdinfo)))
(change-directory toppath)
- ;; (set! *runremote* runremote)
- ;; (set! *transport-type* (string->symbol transport))
(if (not target)
(begin
(debug:print 0 "ERROR: -target is required.")
(exit 1)))
(if (not (setup-for-run))
(begin
(debug:print 0 "Failed to setup, giving up on -test-paths or -test-files, exiting")
(exit 1)))
- (let* ((keys (cdb:remote-run db:get-keys db))
+ (let* ((keys (rmt:get-keys))
;; db:test-get-paths must not be run remote
- (paths (db:test-get-paths-matching db keys target (args:get-arg "-test-files"))))
+ (paths (tests:test-get-paths-matching keys target (args:get-arg "-test-files"))))
(set! *didsomething* #t)
(for-each (lambda (path)
(print path))
paths)))
;; else do a general-run-call
@@ -796,11 +807,11 @@
"-test-files"
"Get paths to test"
(lambda (target runname keys keyvals)
(let* ((db #f)
;; DO NOT run remote
- (paths (db:test-get-paths-matching db keys target (args:get-arg "-test-files"))))
+ (paths (tests:test-get-paths-matching keys target (args:get-arg "-test-files"))))
(for-each (lambda (path)
(print path))
paths))))))
;;======================================================================
@@ -810,48 +821,42 @@
(if (args:get-arg "-archive")
;; if we are in a test use the MT_CMDINFO data
(if (getenv "MT_CMDINFO")
(let* ((startingdir (current-directory))
(cmdinfo (read (open-input-string (base64:base64-decode (getenv "MT_CMDINFO")))))
- ;; (runremote (assoc/default 'runremote cmdinfo))
- (transport (assoc/default 'transport cmdinfo))
(testpath (assoc/default 'testpath cmdinfo))
(test-name (assoc/default 'test-name cmdinfo))
(runscript (assoc/default 'runscript cmdinfo))
(db-host (assoc/default 'db-host cmdinfo))
(run-id (assoc/default 'run-id cmdinfo))
(itemdat (assoc/default 'itemdat cmdinfo))
- (db #f)
(state (args:get-arg ":state"))
(status (args:get-arg ":status"))
(target (args:get-arg "-target")))
(change-directory testpath)
- ;; (set! *runremote* runremote)
- ;; (set! *transport-type* (string->symbol transport))
(if (not target)
(begin
(debug:print 0 "ERROR: -target is required.")
(exit 1)))
(if (not (setup-for-run))
(begin
(debug:print 0 "Failed to setup, giving up on -archive, exiting")
(exit 1)))
- (let* ((keys (cdb:remote-run db:get-keys db))
- ;; DO NOT run remote
- (paths (db:test-get-paths-matching db keys target)))
+ (let* ((keys (rmt:get-keys))
+ (paths (tests:test-get-paths-matching keys target)))
(set! *didsomething* #t)
(for-each (lambda (path)
(print path))
- paths)))
+ paths))
+ ;; (if (sqlite3:database? db)(sqlite3:finalize! db))
+ )
;; else do a general-run-call
(general-run-call
"-test-paths"
"Get paths to tests"
(lambda (target runname keys keyvals)
- (let* ((db #f)
- ;; DO NOT run remote
- (paths (db:test-get-paths-matching db keys target)))
+ (let* ((paths (tests:test-get-paths-matching keys target)))
(for-each (lambda (path)
(print path))
paths))))))
;;======================================================================
@@ -861,17 +866,19 @@
(if (args:get-arg "-extract-ods")
(general-run-call
"-extract-ods"
"Make ods spreadsheet"
(lambda (target runname keys keyvals)
- (let ((db #f)
+ (let ((dbstruct (make-dbr:dbstruct path: *toppath* local: #t))
(outputfile (args:get-arg "-extract-ods"))
(runspatt (args:get-arg ":runname"))
(pathmod (args:get-arg "-pathmod")))
;; (keyvalalist (keys->alist keys "%")))
(debug:print 2 "Extract ods, outputfile: " outputfile " runspatt: " runspatt " keyvals: " keyvals)
- (cdb:remote-run db:extract-ods-file db outputfile keyvals (if runspatt runspatt "%") pathmod)))))
+ (db:extract-ods-file dbstruct outputfile keyvals (if runspatt runspatt "%") pathmod)
+ (db:close-all dbstruct)
+ (set! *didsomething* #t)))))
;;======================================================================
;; execute the test
;; - gets called on remote host
;; - receives info from the -execute param
@@ -892,12 +899,10 @@
(if (not (getenv "MT_CMDINFO"))
(begin
(debug:print 0 "ERROR: MT_CMDINFO env var not set, -step must be called *inside* a megatest invoked environment!")
(exit 5))
(let* ((cmdinfo (read (open-input-string (base64:base64-decode (getenv "MT_CMDINFO")))))
- ;; (runremote (assoc/default 'runremote cmdinfo))
- (transport (assoc/default 'transport cmdinfo))
(testpath (assoc/default 'testpath cmdinfo))
(test-name (assoc/default 'test-name cmdinfo))
(runscript (assoc/default 'runscript cmdinfo))
(db-host (assoc/default 'db-host cmdinfo))
(run-id (assoc/default 'run-id cmdinfo))
@@ -904,20 +909,16 @@
(test-id (assoc/default 'test-id cmdinfo))
(itemdat (assoc/default 'itemdat cmdinfo))
(work-area (assoc/default 'work-area cmdinfo))
(db #f))
(change-directory testpath)
- ;; (set! *runremote* runremote)
- ;; The transport is handled earlier in the loading process of megatest.
- ;; (set! *transport-type* (string->symbol transport))
(if (not (setup-for-run))
(begin
(debug:print 0 "Failed to setup, exiting")
(exit 1)))
(if (and state status)
- ;; DO NOT remote run, makes calls to the testdat.db test db.
- (db:teststep-set-status! db test-id step state status msg logfile work-area: work-area)
+ (rmt:teststep-set-status! run-id test-id step state status msg logfile)
(begin
(debug:print 0 "ERROR: You must specify :state and :status with every call to -step")
(exit 6))))))
(if (args:get-arg "-step")
@@ -944,12 +945,10 @@
(begin
(debug:print 0 "ERROR: MT_CMDINFO env var not set, commands -test-status, -runstep and -setlog must be called *inside* a megatest environment!")
(exit 5))
(let* ((startingdir (current-directory))
(cmdinfo (read (open-input-string (base64:base64-decode (getenv "MT_CMDINFO")))))
- ;; (runremote (assoc/default 'runremote cmdinfo))
- (transport (assoc/default 'transport cmdinfo))
(testpath (assoc/default 'testpath cmdinfo))
(test-name (assoc/default 'test-name cmdinfo))
(runscript (assoc/default 'runscript cmdinfo))
(db-host (assoc/default 'db-host cmdinfo))
(run-id (assoc/default 'run-id cmdinfo))
@@ -957,12 +956,10 @@
(itemdat (assoc/default 'itemdat cmdinfo))
(work-area (assoc/default 'work-area cmdinfo))
(db #f) ;; (open-db))
(state (args:get-arg ":state"))
(status (args:get-arg ":status")))
- ;; (set! *runremote* runremote)
- ;; (set! *transport-type* (string->symbol transport))
(if (not (setup-for-run))
(begin
(debug:print 0 "Failed to setup, exiting")
(exit 1)))
@@ -972,20 +969,20 @@
;; (client:setup)
(if (args:get-arg "-load-test-data")
;; has sub commands that are rdb:
;; DO NOT put this one into either cdb:remote-run or open-run-close
- (db:load-test-data db test-id work-area: work-area))
+ (tdb:load-test-data run-id test-id))
(if (args:get-arg "-setlog")
(let ((logfname (args:get-arg "-setlog")))
- (cdb:test-set-log! *runremote* test-id logfname)))
+ (rmt:test-set-log! run-id test-id logfname)))
(if (args:get-arg "-set-toplog")
;; DO NOT run remote
- (tests:test-set-toplog! db run-id test-name (args:get-arg "-set-toplog")))
+ (tests:test-set-toplog! run-id test-name (args:get-arg "-set-toplog")))
(if (args:get-arg "-summarize-items")
;; DO NOT run remote
- (tests:summarize-items db run-id test-id test-name #t)) ;; do force here
+ (tests:summarize-items run-id test-id test-name #t)) ;; do force here
(if (args:get-arg "-runstep")
(if (null? remargs)
(begin
(debug:print 0 "ERROR: nothing specified to run!")
(if db (sqlite3:finalize! db))
@@ -1003,16 +1000,15 @@
(else ">&")))
(fullcmd (conc "(" (string-intersperse
(cons cmd params) " ")
") " redir " " logfile)))
;; mark the start of the test
- ;; DO NOT run remote
- (db:teststep-set-status! db test-id stepname "start" "n/a" (args:get-arg "-m") logfile work-area: work-area)
+ (rmt:teststep-set-status! run-id test-id stepname "start" "n/a" (args:get-arg "-m") logfile)
;; run the test step
(debug:print-info 2 "Running \"" fullcmd "\" in directory \"" startingdir)
(change-directory startingdir)
- (set! exitstat (system fullcmd)) ;; cmd params))
+ (set! exitstat (system fullcmd))
(set! *globalexitstatus* exitstat)
;; (change-directory testpath)
;; run logpro if applicable ;; (process-run "ls" (list "/foo" "2>&1" "blah.log"))
(if logprofile
(let* ((htmllogfile (conc stepname ".html"))
@@ -1021,14 +1017,13 @@
(debug:print-info 2 "running \"" cmd "\"")
(change-directory startingdir)
(set! exitstat (system cmd))
(set! *globalexitstatus* exitstat) ;; no necessary
(change-directory testpath)
- (cdb:test-set-log! *runremote* test-id htmllogfile)))
+ (rmt:test-set-log! run-id test-id htmllogfile)))
(let ((msg (args:get-arg "-m")))
- ;; DO NOT run remote
- (db:teststep-set-status! db test-id stepname "end" exitstat msg logfile work-area: work-area))
+ (rmt:teststep-set-status! run-id test-id stepname "end" exitstat msg logfile))
)))
(if (or (args:get-arg "-test-status")
(args:get-arg "-set-values"))
(let ((newstatus (cond
((number? status) (if (equal? status 0) "PASS" "FAIL"))
@@ -1046,17 +1041,17 @@
(if (and (args:get-arg "-test-status")
(or (not state)
(not status)))
(begin
(debug:print 0 "ERROR: You must specify :state and :status with every call to -test-status\n" help)
- ;; (sqlite3:finalize! db)
+ (if (sqlite3:database? db)(sqlite3:finalize! db))
(exit 6)))
(let* ((msg (args:get-arg "-m"))
(numoth (length (hash-table-keys otherdata))))
;; Convert to rpc inside the tests:test-set-status! call, not here
- (tests:test-set-status! test-id state newstatus msg otherdata work-area: work-area))))
- (if db (sqlite3:finalize! db))
+ (tests:test-set-status! run-id test-id state newstatus msg otherdata work-area: work-area))))
+ (if (sqlite3:database? db)(sqlite3:finalize! db))
(set! *didsomething* #t))))
;;======================================================================
;; Various helper commands can go below here
;;======================================================================
@@ -1069,11 +1064,11 @@
(begin
(debug:print 0 "Failed to setup, exiting")
(exit 1)))
(set! keys (cdb:remote-run db:get-keys db))
(debug:print 1 "Keys: " (string-intersperse keys ", "))
- (if db (sqlite3:finalize! db))
+ (if (sqlite3:database? db)(sqlite3:finalize! db))
(set! *didsomething* #t)))
(if (args:get-arg "-gui")
(begin
(debug:print 0 "Look at the dashboard for now")
@@ -1156,43 +1151,85 @@
;;======================================================================
(if (or (args:get-arg "-repl")
(args:get-arg "-load"))
(let* ((toppath (setup-for-run))
- (db (if toppath (open-db) #f)))
- (if db
+ (dbstruct (if toppath (make-dbr:dbstruct path: toppath local: #t) #f)))
+ (if dbstruct
(begin
- (set! *db* db)
+ (set! *db* dbstruct)
(set! *client-non-blocking-mode* #t)
(import readline)
(import apropos)
+ ;; (import (prefix sqlite3 sqlite3:)) ;; doesn't work ...
(gnu-history-install-file-manager
(string-append
(or (get-environment-variable "HOME") ".") "/.megatest_history"))
(current-input-port (make-gnu-readline-port "megatest> "))
(if (args:get-arg "-repl")
(repl)
- (load (args:get-arg "-load"))))
+ (load (args:get-arg "-load")))
+ (db:close-all dbstruct))
(exit))
(set! *didsomething* #t)))
+
+;; Not converted to use dbstruct yet
+;;
+(if (args:get-arg "-convert-to-norm")
+ (let* ((toppath (setup-for-run))
+ (dbstruct (if toppath (make-dbr:dbstruct path: toppath local: #t))))
+ (for-each
+ (lambda (field)
+ (let ((dat '()))
+ (debug:print-info 0 "Getting data for field " field)
+ (sqlite3:for-each-row
+ (lambda (id val)
+ (set! dat (cons (list id val) dat)))
+ (get-db db run-id)
+ (conc "SELECT id," field " FROM tests;"))
+ (debug:print-info 0 "found " (length dat) " items for field " field)
+ (let ((qry (sqlite3:prepare db (conc "UPDATE tests SET " field "=? WHERE id=?;"))))
+ (for-each
+ (lambda (item)
+ (let ((newval ;; (sdb:qry 'getid
+ (cadr item))) ;; )
+ (if (not (equal? newval (cadr item)))
+ (debug:print-info 0 "Converting " (cadr item) " to " newval " for test #" (car item)))
+ (sqlite3:execute qry newval (car item))))
+ dat)
+ (sqlite3:finalize! qry))))
+ (db:close-all dbstruct)
+ (list "uname" "rundir" "final_logf" "comment"))
+ (set! *didsomething* #t)))
+
+(if (args:get-arg "-import-megatest.db")
+ (let* ((toppath (setup-for-run))
+ (dbstruct (if toppath (make-dbr:dbstruct path: toppath) #f))
+ (mtdb (if toppath (db:open-megatest-db)))
+ (run-ids (if toppath (db:get-all-run-ids mtdb))))
+ ;; sync runs, test_meta etc.
+ (db:sync-tables (db:sync-main-list mtdb) mtdb (db:get-db dbstruct #f))
+ (for-each
+ (lambda (run-id)
+ (let ((testrecs (db:get-all-tests-info-by-run-id mtdb run-id)))
+ (debug:print 0 "INFO: Updating " (length testrecs) " records for run-id=" run-id)
+ (db:replace-test-records dbstruct run-id testrecs)))
+ run-ids)
+ (set! *didsomething* #t)
+ (db:close-all dbstruct)))
+
+
;;======================================================================
;; Exit and clean up
;;======================================================================
(if *runremote* (close-all-connections!))
-;; this is the socket if we are a client
-;; (if (and *runremote*
-;; (socket? *runremote*))
-;; (close-socket *runremote*))
-
(if (not *didsomething*)
(debug:print 0 help))
-;; (if *runremote* (rpc:close-all-connections!))
-
(if (not (eq? *globalexitstatus* 0))
(if (or (args:get-arg "-runtests")(args:get-arg "-runall"))
(begin
(debug:print 0 "NOTE: Subprocesses with non-zero exit code detected: " *globalexitstatus*)
(exit 0))
Index: mt.scm
==================================================================
--- mt.scm
+++ mt.scm
@@ -17,10 +17,12 @@
(declare (uses items))
(declare (uses runconfig))
(declare (uses tests))
(declare (uses server))
(declare (uses runs))
+(declare (uses rmt))
+;; (declare (uses filedb))
(include "common_records.scm")
(include "key_records.scm")
(include "db_records.scm")
(include "run_records.scm")
@@ -35,15 +37,15 @@
;; runs:get-runs-by-patt
;; get runs by list of criteria
;; register a test run with the db
;;
-;; Use: (db-get-value-by-header (db:get-header runinfo)(db:get-row runinfo))
+;; Use: (db-get-value-by-header (db:get-header runinfo)(db:get-rows runinfo))
;; to extract info from the structure returned
;;
(define (mt:get-runs-by-patt keys runnamepatt targpatt)
- (let loop ((runsdat (cdb:remote-run db:get-runs-by-patt #f keys runnamepatt targpatt 0 500))
+ (let loop ((runsdat (rmt:get-runs-by-patt keys runnamepatt targpatt 0 500))
(res '())
(offset 0)
(limit 500))
;; (print "runsdat: " runsdat)
(let* ((header (vector-ref runsdat 0))
@@ -51,11 +53,11 @@
(full-list (append res runslst))
(have-more (eq? (length runslst) limit)))
;; (debug:print 0 "header: " header " runslst: " runslst " have-more: " have-more)
(if have-more
(let ((new-offset (+ offset limit))
- (next-batch (cdb:remote-run db:get-runs-by-patt #f keys runnamepatt targpatt offset limit)))
+ (next-batch (rmt:get-runs-by-patt keys runnamepatt targpatt offset limit)))
(debug:print-info 4 "More than " limit " runs, have " (length full-list) " runs so far.")
(debug:print-info 0 "next-batch: " next-batch)
(loop next-batch
full-list
new-offset
@@ -65,28 +67,25 @@
;;======================================================================
;; T E S T S
;;======================================================================
(define (mt:get-tests-for-run run-id testpatt states status #!key (not-in #t) (sort-by 'event_time) (sort-order "ASC") (qryvals #f))
- (let loop ((testsdat (cdb:remote-run db:get-tests-for-run #f run-id testpatt states status 0 500 not-in sort-by sort-order qryvals: qryvals))
+ (let loop ((testsdat (rmt:get-tests-for-run run-id testpatt states status 0 500 not-in sort-by sort-order qryvals))
(res '())
(offset 0)
(limit 500))
(let* ((full-list (append res testsdat))
(have-more (eq? (length testsdat) limit)))
(if have-more
(let ((new-offset (+ offset limit)))
(debug:print-info 4 "More than " limit " tests, have " (length full-list) " tests so far.")
- (loop (cdb:remote-run db:get-tests-for-run #f run-id testpatt states status new-offset limit not-in sort-by sort-order qryvals: qryvals)
+ (loop (rmt:get-tests-for-run run-id testpatt states status new-offset limit not-in sort-by sort-order qryvals)
full-list
new-offset
limit))
full-list))))
-(define (mt:get-prereqs-not-met run-id waitons ref-item-path #!key (mode 'normal))
- (db:get-prereqs-not-met run-id waitons ref-item-path mode: mode))
-
(define (mt:lazy-get-prereqs-not-met run-id waitons ref-item-path #!key (mode 'normal))
(let* ((key (list run-id waitons ref-item-path mode))
(res (hash-table-ref/default *pre-reqs-met-cache* key #f))
(useres (let ((last-time (if (vector? res) (vector-ref res 0) #f)))
(if last-time
@@ -94,16 +93,17 @@
#f))))
(if useres
(let ((result (vector-ref res 1)))
(debug:print 4 "Using lazy value res: " result)
result)
- (let ((newres (db:get-prereqs-not-met run-id waitons ref-item-path mode: mode)))
+ (let ((newres (rmt:get-prereqs-not-met run-id waitons ref-item-path mode: mode)))
(hash-table-set! *pre-reqs-met-cache* key (vector (current-seconds) newres))
newres))))
-(define (mt:get-run-stats)
- (cdb:remote-run db:get-run-stats #f))
+(define (mt:get-run-stats dbstruct run-id)
+;; Get run stats from local access, move this ... but where?
+ (db:get-run-stats dbstruct run-id))
(define (mt:discard-blocked-tests run-id failed-test tests test-records)
(if (null? tests)
tests
(begin
@@ -125,18 +125,20 @@
;;======================================================================
;; T R I G G E R S
;;======================================================================
-(define (mt:process-triggers test-id newstate newstatus)
- (let* ((test-dat (mt:lazy-get-test-info-by-id test-id))
- (test-rundir (db:test-get-rundir test-dat))
+(define (mt:process-triggers run-id test-id newstate newstatus)
+ (let* ((test-dat (rmt:get-test-info-by-id run-id test-id))
+ (test-rundir ;; (rmt:sdb-qry 'getstr ;; (filedb:get-path *fdb*
+ (db:test-get-rundir test-dat)) ;; ) ;; )
(test-name (db:test-get-testname test-dat))
(tconfig #f)
(state (if newstate newstate (db:test-get-state test-dat)))
(status (if newstatus newstatus (db:test-get-status test-dat))))
- (if (and (file-exists? test-rundir)
+ (if (and test-rundir ;; #f means no dir set yet
+ (file-exists? test-rundir)
(directory? test-rundir))
(begin
(push-directory test-rundir)
(set! tconfig (mt:lazy-read-test-config test-name))
(pop-directory)
@@ -157,43 +159,24 @@
;;======================================================================
;; S T A T E A N D S T A T U S F O R T E S T S
;;======================================================================
-(define (mt:roll-up-pass-fail-counts run-id test-name item-path status)
- (if (and (not (equal? item-path ""))
- (member status '("PASS" "WARN" "FAIL" "WAIVED" "RUNNING" "CHECK" "SKIP")))
- (begin
- (cdb:update-pass-fail-counts *runremote* run-id test-name)
- (if (equal? status "RUNNING")
- (cdb:top-test-set-running *runremote* run-id test-name)
- (cdb:top-test-set-per-pf-counts *runremote* run-id test-name))
- #f)
- #f))
-
;; speed up for common cases with a little logic
-(define (mt:test-set-state-status-by-id test-id newstate newstatus newcomment)
+(define (mt:test-set-state-status-by-id run-id test-id newstate newstatus newcomment)
(cond
((and newstate newstatus newcomment)
- (cdb:client-call *runremote* 'state-status-msg #t *default-numtries* newstate newstatus newcomment test-id))
+ (rmt:general-call 'state-status-msg run-id newstate newstatus newcomment test-id))
((and newstate newstatus)
- (cdb:client-call *runremote* 'state-status #t *default-numtries* newstate newstatus test-id))
+ (rmt:general-call 'state-status run-id newstate newstatus test-id))
(else
- (if newstate (cdb:client-call *runremote* 'set-test-state #t *default-numtries* newstate test-id))
- (if newstatus (cdb:client-call *runremote* 'set-test-status #t *default-numtries* newstatus test-id))
- (if newcomment (cdb:client-call *runremote* 'set-test-comment #t *default-numtries* newcomment test-id))))
- (mt:process-triggers test-id newstate newstatus)
+ (if newstate (rmt:general-call 'set-test-state run-id newstate test-id))
+ (if newstatus (rmt:general-call 'set-test-status run-id newstatus test-id))
+ (if newcomment (rmt:general-call 'set-test-comment run-id newcomment test-id))))
+ (mt:process-triggers run-id test-id newstate newstatus)
#t)
-(define (mt:lazy-get-test-info-by-id test-id)
- (let* ((tdat (hash-table-ref/default *test-info* test-id #f)))
- (if (and tdat
- (< (current-seconds)(+ (vector-ref tdat 0) 10)))
- (vector-ref tdat 1)
- ;; no need to update *test-info* as that is done in cdb:get-test-info-by-id
- (cdb:get-test-info-by-id *runremote* test-id))))
-
(define (mt:lazy-read-test-config test-name)
(let ((tconf (hash-table-ref/default *testconfigs* test-name #f)))
(if tconf
tconf
(let ((test-dirs (tests:get-tests-search-path *configdat*)))
Index: newdashboard.scm
==================================================================
--- newdashboard.scm
+++ newdashboard.scm
@@ -568,13 +568,13 @@
(iup:attribute-set! tabtop "TABTITLE4" "runconfigs.config")
tabtop)))
(define *current-window-id* 0)
-(define (newdashboard)
+(define (newdashboard dbstruct)
(let* ((data (make-hash-table))
- (keys (cdb:remote-run db:get-keys #f))
+ (keys (db:get-keys dbstruct))
(runname "%")
(testpatt "%")
(keypatts (map (lambda (k)(list k "%")) keys))
(states '())
(statuses '())
ADDED oldsrc/fs-transport.scm
Index: oldsrc/fs-transport.scm
==================================================================
--- /dev/null
+++ oldsrc/fs-transport.scm
@@ -0,0 +1,44 @@
+
+;; Copyright 2006-2012, Matthew Welland.
+;;
+;; This program is made available under the GNU GPL version 2.0 or
+;; greater. See the accompanying file COPYING for details.
+;;
+;; This program is distributed WITHOUT ANY WARRANTY; without even the
+;; implied warranty of MERCHANTABILITY or FITNESS FOR A PARTICULAR
+;; PURPOSE.
+
+(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 *megatest-db*) ;; we will require that (setup-for-run) has already been called
+ (set! *megatest-db* (open-db)))
+ (debug:print-info 11 "fs:process-queue-item called with packet=" packet)
+ (db:process-queue-item *megatest-db* packet))
+
ADDED oldsrc/zmq-transport.scm
Index: oldsrc/zmq-transport.scm
==================================================================
--- /dev/null
+++ oldsrc/zmq-transport.scm
@@ -0,0 +1,494 @@
+;;======================================================================
+;; Copyright 2006-2012, Matthew Welland.
+;;
+;; This program is made available under the GNU GPL version 2.0 or
+;; greater. See the accompanying file COPYING for details.
+;;
+;; This program is distributed WITHOUT ANY WARRANTY; without even the
+;; implied warranty of MERCHANTABILITY or FITNESS FOR A PARTICULAR
+;; PURPOSE.
+;;======================================================================
+
+(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 zmq)
+
+(declare (unit zmq-transport))
+
+(declare (uses common))
+(declare (uses db))
+(declare (uses tests))
+(declare (uses tasks)) ;; tasks are where stuff is maintained about what is running.
+(declare (uses server))
+
+(include "common_records.scm")
+(include "db_records.scm")
+
+;; Transition to pub --> sub with pull <-- push
+;;
+;; 1. client sends request to server via push to the pull port
+;; 2. server puts request in queue or processes immediately as appropriate
+;; 3. server puts responses from completed requests into pub port
+;;
+;; TODO
+;;
+;; Done Tested
+;; [x] [ ] 1. Add columns pullport pubport to servers table
+;; [x] [ ] 2. Add rm of monitor.db if older than 11/12/2012
+;; [x] [ ] 3. Add create of pullport and pubport with finding of available ports
+;; [x] [ ] 4. Add client compose of request
+;; [x] [ ] - name of client: testname/itempath-test_id-hostname
+;; [x] [ ] - name of request: callname, params
+;; [x] [ ] - request key: f(clientname, callname, params)
+;; [x] [ ] 5. Add processing of subscription hits
+;; [x] [ ] - done when get key
+;; [x] [ ] - return results
+;; [x] [ ] 6. Add timeout processing
+;; [x] [ ] - after 60 seconds
+;; [ ] [ ] i. check server alive, connect to new if necessary
+;; [ ] [ ] ii. resend request
+;; [ ] [ ] 7. Turn self ping back on
+
+(define (zmq-transport:make-server-url hostport)
+ (if (not hostport)
+ #f
+ (conc "tcp://" (car hostport) ":" (cadr hostport))))
+
+(define *server-loop-heart-beat* (current-seconds))
+(define *heartbeat-mutex* (make-mutex))
+
+;;======================================================================
+;; S E R V E R
+;;======================================================================
+
+(define-inline (zmqsock:get-pub dat)(vector-ref dat 0))
+(define-inline (zmqsock:get-pull dat)(vector-ref dat 1))
+(define-inline (zmqsock:set-pub! dat s)(vector-set! dat s 0))
+(define-inline (zmqsock:set-pull! dat s)(vector-set! dat s 0))
+
+(define (zmq-transport:run hostn)
+ (debug:print 2 "Attempting to start the server ...")
+ (if (not *toppath*)
+ (if (not (setup-for-run))
+ (begin
+ (debug:print 0 "ERROR: cannot find megatest.config, cannot start server, exiting")
+ (exit))))
+ (let* ((db (open-db)) ;; here we *do not* want to be opening and closing the db
+ (zmq-sdat1 #f)
+ (zmq-sdat2 #f)
+ (pull-socket #f)
+ (pub-socket #f)
+ (p1 #f)
+ (p2 #f)
+ (zmq-sockets-dat #f)
+ (iface (if (string=? "-" hostn)
+ "*" ;; (get-host-name)
+ hostn))
+ (hostname (get-host-name))
+ (ipaddrstr (let ((ipstr (if (string=? "-" hostn)
+ (string-intersperse (map number->string (u8vector->list (hostname->ip hostname))) ".")
+ #f)))
+ (if ipstr ipstr hostname)))
+ (last-run 0))
+ (set! zmq-sockets-dat (zmq-transport:setup-ports ipaddrstr (if (args:get-arg "-port")
+ (string->number (args:get-arg "-port"))
+ (+ 5000 (random 1001)))))
+
+ (set! zmq-sdat1 (car zmq-sockets-dat))
+ (set! pull-socket (cadr zmq-sdat1)) ;; (iface s port)
+ (set! p1 (caddr zmq-sdat1))
+
+ (set! zmq-sdat2 (cadr zmq-sockets-dat))
+ (set! pub-socket (cadr zmq-sdat2))
+ (set! p2 (caddr zmq-sdat2))
+
+ (set! *cache-on* #t)
+
+ (set! *runremote* (vector pull-socket pub-socket)) ;; overloading the use of *runremote* BUG!?
+
+ ;; what to do when we quit
+ ;;
+;; (on-exit (lambda ()
+;; (if (and *toppath* *server-info*)
+;; (open-run-close tasks:server-deregister-self tasks:open-db (car *server-info*))
+;; (let loop ()
+;; (let ((queue-len 0))
+;; (thread-sleep! (random 5))
+;; (mutex-lock! *incoming-mutex*)
+;; (set! queue-len (length *incoming-data*))
+;; (mutex-unlock! *incoming-mutex*)
+;; (if (> queue-len 0)
+;; (begin
+;; (debug:print-info 0 "Queue not flushed, waiting ...")
+;; (loop))))))))
+
+ ;; The heavy lifting
+ ;;
+ ;; make-vector-record cdb packet client-sig qtype immediate query-sig params qtime
+ ;;
+ (debug:print-info 11 "Server setup complete, start listening for messages")
+ (let loop ((queue-lst '()))
+ (let* ((rawmsg (receive-message* pull-socket))
+ (packet (db:string->obj rawmsg))
+ (qtype (cdb:packet-get-qtype packet)))
+ (debug:print-info 12 "server=> received packet=" packet)
+ (if (not (member qtype '(sync ping)))
+ (begin
+ (mutex-lock! *heartbeat-mutex*)
+ (set! *last-db-access* (current-seconds))
+ (mutex-unlock! *heartbeat-mutex*)))
+ (if #t ;; (cdb:packet-get-immediate packet) ;; process immediately or put in queue
+ (begin
+ (db:process-queue-item db packet)
+ ;; (open-run-close db:process-queue #f pub-socket (cons packet queue-lst))
+
+ (loop '()))
+ (loop (cons packet queue-lst)))))))
+
+;; run zmq-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 (zmq-transport:keep-running)
+ ;; if none running or if > 20 seconds since
+ ;; server last used then start shutdown
+ ;; This thread waits for the server to come alive
+ (let* ((server-info (let loop ()
+ (let ((sdat #f))
+ (mutex-lock! *heartbeat-mutex*)
+ (set! sdat *server-info*)
+ (mutex-unlock! *heartbeat-mutex*)
+ (if sdat sdat
+ (begin
+ (debug:print 12 "WARNING: server not started yet, waiting few seconds before trying again")
+ (sleep 4)
+ (loop))))))
+ (iface (cadr server-info))
+ (pullport (caddr server-info))
+ (pubport (cadddr server-info)) ;; id interface pullport pubport)
+ ;; (zmq-sockets (zmq-transport:client-connect iface pullport pubport))
+ (last-access 0))
+ (debug:print-info 11 "heartbeat started for zmq server on " iface " " pullport " " pubport)
+ (let loop ((count 0))
+ (thread-sleep! 4) ;; no need to do this very often
+ ;; NB// sync currently does NOT return queue-length
+ ;; GET REAL QUEUE LENGTH FROM THE VARIABLE
+ (let ((queue-len 0)) ;; FOR NOW DO NOT DO THIS (cdb:client-call zmq-sockets 'sync #t 1)))
+ ;; (print "Server running, count is " count)
+ (if (< count 1) ;; 3x3 = 9 secs aprox
+ (loop (+ count 1)))
+
+ ;; NOTE: Get rid of this mechanism! It really is not needed...
+ (open-run-close tasks:server-update-heartbeat tasks:open-db (car server-info))
+
+ ;; (if ;; (or (> numrunning 0) ;; stay alive for two days after last access
+ (mutex-lock! *heartbeat-mutex*)
+ (set! last-access *last-db-access*)
+ (mutex-unlock! *heartbeat-mutex*)
+ (if (> (+ last-access
+ ;; (* 50 60 60) ;; 48 hrs
+ ;; 60 ;; one minute
+ ;; (* 60 60) ;; one hour
+ (* 45 60) ;; 45 minutes, until the db deletion bug is fixed.
+ )
+ (current-seconds))
+ (begin
+ (debug:print-info 2 "Server continuing, seconds since last db access: " (- (current-seconds) last-access))
+ (loop 0))
+ (begin
+ (debug:print-info 0 "Starting to shutdown the server.")
+ ;; need to delete only *my* server entry (future use)
+ (set! *time-to-exit* #t)
+ (open-run-close tasks:server-deregister-self tasks:open-db (get-host-name))
+ (thread-sleep! 1)
+ (debug:print-info 0 "Max cached queries was " *max-cache-size*)
+ (debug:print-info 0 "Server shutdown complete. Exiting")
+ (exit)))))))
+
+(define (zmq-transport:find-free-port-and-open iface s port stype #!key (trynum 50))
+ (let ((s (if s s (make-socket stype)))
+ (p (if (number? port) port 5555))
+ (old-handler (current-exception-handler)))
+ (handle-exceptions
+ exn
+ (begin
+ (debug:print 0 "Failed to bind to port " p ", trying next port")
+ (debug:print 0 " EXCEPTION: " ((condition-property-accessor 'exn 'message) exn))
+ ;; (old-handler)
+ ;; (print-call-chain)
+ (if (> trynum 0)
+ (zmq-transport:find-free-port-and-open iface s (+ p 1) trynum: (- trynum 1))
+ (debug:print-info 0 "Tried ports up to " p
+ " but all were in use. Please try a different port range by starting the server with parameter \" -port N\" where N is the starting port number to use"))
+ (exit)) ;; To exit or not? That is the question.
+ (let ((zmq-url (conc "tcp://" iface ":" p)))
+ (debug:print 2 "Trying to start server on " zmq-url)
+ (bind-socket s zmq-url)
+ (list iface s port)))))
+
+(define (zmq-transport:setup-ports ipaddrstr startport)
+ (let* ((s1 (zmq-transport:find-free-port-and-open ipaddrstr #f startport 'pull))
+ (p1 (caddr s1))
+ (s2 (zmq-transport:find-free-port-and-open ipaddrstr #f (+ 1 (if p1 p1 (+ startport 1))) 'pub))
+ (p2 (caddr s2)))
+ (set! *runremote* #f)
+ (debug:print 0 "Server started on " ipaddrstr " ports " p1 " and " p2)
+ (mutex-lock! *heartbeat-mutex*)
+ (set! *server-info* (open-run-close tasks:server-register
+ tasks:open-db
+ (current-process-id)
+ ipaddrstr p1
+ 0
+ 'live
+ 'zmq
+ pubport: p2))
+ (debug:print-info 11 "*server-info* set to " *server-info*)
+ (mutex-unlock! *heartbeat-mutex*)
+ (list s1 s2)))
+
+(define (zmq-transport:mk-signature)
+ (message-digest-string (md5-primitive)
+ (with-output-to-string
+ (lambda ()
+ (write (list (current-directory)
+ (argv)))))))
+
+;;======================================================================
+;; S E R V E R U T I L I T I E S
+;;======================================================================
+
+;;======================================================================
+;; C L I E N T S
+;;======================================================================
+
+;;
+(define (zmq-transport:client-socket-connect iface port #!key (context #f)(type 'req)(subscriptions '()))
+ (debug:print-info 3 "client-connect " iface ":" port ", type=" type ", subscriptions=" subscriptions)
+ (let ((connect-ok #f)
+ (zmq-socket (if context
+ (make-socket type context)
+ (make-socket type)))
+ (conurl (zmq-transport:make-server-url (list iface port))))
+ (if (socket? zmq-socket)
+ (begin
+ ;; first apply subscriptions
+ (for-each (lambda (subscription)
+ (debug:print 2 "Subscribing to " subscription)
+ (socket-option-set! zmq-socket 'subscribe subscription))
+ subscriptions)
+ (connect-socket zmq-socket conurl)
+ zmq-socket)
+ (begin
+ (debug:print 0 "ERROR: Failed to open socket to " conurl)
+ #f))))
+
+(define (zmq-transport:client-connect iface pullport pubport)
+ (let* ((push-socket (zmq-transport:client-socket-connect iface pullport type: 'push))
+ (sub-socket (zmq-transport:client-socket-connect iface pubport
+ type: 'sub
+ subscriptions: (list (client:get-signature) "all")))
+ (zmq-sockets (vector push-socket sub-socket))
+ (login-res #f))
+ (debug:print-info 11 "zmq-transport:client-connect started. Next is login")
+ (set! login-res (client:login serverdat zmq-sockets))
+ (if (and (not (null? login-res))
+ (car login-res))
+ (begin
+ (debug:print-info 2 "Logged in and connected to " iface ":" pullport "/" pubport ".")
+ (set! *runremote* zmq-sockets)
+ zmq-sockets)
+ (begin
+ (debug:print-info 2 "Failed to login or connect to " conurl)
+ (set! *runremote* #f)
+ #f))))
+
+;; run zmq-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 (zmq-transport:keep-running)
+ ;; if none running or if > 20 seconds since
+ ;; server last used then start shutdown
+ ;; This thread waits for the server to come alive
+ (let* ((server-info (let loop ()
+ (let ((sdat #f))
+ (mutex-lock! *heartbeat-mutex*)
+ (set! sdat *runremote*)
+ (mutex-unlock! *heartbeat-mutex*)
+ (if sdat sdat
+ (begin
+ (sleep 4)
+ (loop))))))
+ (iface (car server-info))
+ (port (cadr server-info))
+ (last-access 0)
+ (tdb (tasks:open-db))
+ (spid (tasks:server-get-server-id tdb #f iface port #f)))
+ (print "Keep-running got server pid " spid ", using iface " iface " and port " port)
+ (let loop ((count 0))
+ (thread-sleep! 4) ;; no need to do this very often
+ ;; NB// sync currently does NOT return queue-length
+ (let () ;; (queue-len (cdb:client-call server-info 'sync #t 1)))
+ ;; (print "Server running, count is " count)
+ (if (< count 1) ;; 3x3 = 9 secs aprox
+ (loop (+ count 1)))
+
+ ;; NOTE: Get rid of this mechanism! It really is not needed...
+ (tasks:server-update-heartbeat tdb spid)
+
+ ;; (if ;; (or (> numrunning 0) ;; stay alive for two days after last access
+ (mutex-lock! *heartbeat-mutex*)
+ (set! last-access *last-db-access*)
+ (mutex-unlock! *heartbeat-mutex*)
+ (if (> (+ last-access
+ ;; (* 50 60 60) ;; 48 hrs
+ ;; 60 ;; one minute
+ ;; (* 60 60) ;; one hour
+ (* 45 60) ;; 45 minutes, until the db deletion bug is fixed.
+ )
+ (current-seconds))
+ (begin
+ (debug:print-info 2 "Server continuing, seconds since last db access: " (- (current-seconds) last-access))
+ (loop 0))
+ (begin
+ (debug:print-info 0 "Starting to shutdown the server.")
+ ;; need to delete only *my* server entry (future use)
+ (set! *time-to-exit* #t)
+ (tasks:server-deregister-self tdb (get-host-name))
+ (thread-sleep! 1)
+ (debug:print-info 0 "Max cached queries was " *max-cache-size*)
+ (debug:print-info 0 "Server shutdown complete. Exiting")
+ (exit)))))))
+
+;; all routes though here end in exit ...
+(define (zmq-transport:launch)
+ (if (not *toppath*)
+ (if (not (setup-for-run))
+ (begin
+ (debug:print 0 "ERROR: cannot find megatest.config, exiting")
+ (exit))))
+ (debug:print-info 2 "Starting zmq server")
+ (if *toppath*
+ (let* (;; (th1 (make-thread (lambda ()
+ ;; (let ((server-info #f))
+ ;; ;; wait for the server to be online and available
+ ;; (let loop ()
+ ;; (debug:print-info 2 "Waiting for the server to come online before starting heartbeat")
+ ;; (thread-sleep! 2)
+ ;; (mutex-lock! *heartbeat-mutex*)
+ ;; (set! server-info *server-info* )
+ ;; (mutex-unlock! *heartbeat-mutex*)
+ ;; (if (not server-info)(loop)))
+ ;; (debug:print 2 "Server alive, starting self-ping")
+ ;; (zmq-transport:self-ping server-info)
+ ;; ))
+ ;; "Self ping"))
+ (th2 (make-thread (lambda ()
+ (zmq-transport:run
+ (if (args:get-arg "-server")
+ (args:get-arg "-server")
+ "-"))) "Server run"))
+ ;; (th3 (make-thread (lambda ()(zmq-transport:keep-running)) "Keep running"))
+ )
+ (set! *client-non-blocking-mode* #t)
+ ;; (thread-start! th1)
+ (thread-start! th2)
+ ;; (thread-start! th3)
+ (set! *didsomething* #t)
+ ;; (thread-join! th3)
+ (thread-join! th2)
+ )
+ (debug:print 0 "ERROR: Failed to setup for megatest")))
+
+(define (zmq-transport:client-signal-handler signum)
+ (handle-exceptions
+ exn
+ (debug:print " ... exiting ...")
+ (let ((th1 (make-thread (lambda ()
+ (if (not *received-response*)
+ (receive-message* *runremote*))) ;; flush out last call if applicable
+ "eat response"))
+ (th2 (make-thread (lambda ()
+ (debug:print 0 "ERROR: Received ^C, attempting clean exit. Please be patient and wait a few seconds before hitting ^C again.")
+ (thread-sleep! 3) ;; give the flush three seconds to do it's stuff
+ (debug:print 0 " Done.")
+ (exit 4))
+ "exit on ^C timer")))
+ (thread-start! th2)
+ (thread-start! th1)
+ (thread-join! th2))))
+
+(define (zmq-transport:client-launch)
+ (set-signal-handler! signal/int zmq-transport:client-signal-handler)
+ (if (zmq-transport:client-setup)
+ (debug:print-info 2 "connected as client")
+ (begin
+ (debug:print 0 "ERROR: Failed to connect as client")
+ (exit))))
+
+;;======================================================================
+;; Defunct functions
+;;======================================================================
+
+;; ping a server and return number of clients or #f (if no response)
+;; NOT IN USE!
+(define (zmq-transport:ping host port #!key (secs 10)(return-socket #f))
+ (cdb:use-non-blocking-mode
+ (lambda ()
+ (let* ((res #f)
+ (th1 (make-thread
+ (lambda ()
+ (let* ((zmq-context (make-context 1))
+ (zmq-socket (zmq-transport:client-connect host port context: zmq-context)))
+ (if zmq-socket
+ (if (zmq-transport:client-login zmq-socket)
+ (let ((numclients (cdb:num-clients zmq-socket)))
+ (if (not return-socket)
+ (begin
+ (zmq-transport:client-logout zmq-socket)
+ (close-socket zmq-socket)))
+ (set! res (list #t numclients (if return-socket zmq-socket #f))))
+ (begin
+ ;; (close-socket zmq-socket)
+ (set! res (list #f "CAN'T LOGIN" #f))))
+ (set! res (list #f "CAN'T CONNECT" #f)))))
+ "Ping: th1"))
+ (th2 (make-thread
+ (lambda ()
+ (let loop ((count 1))
+ (debug:print-info 1 "Ping " count " server on " host " at port " port)
+ (thread-sleep! 2)
+ (if (< count (/ secs 2))
+ (loop (+ count 1))))
+ ;; (thread-terminate! th1)
+ (set! res (list #f "TIMED OUT" #f)))
+ "Ping: th2")))
+ (thread-start! th2)
+ (thread-start! th1)
+ (handle-exceptions
+ exn
+ (set! res (list #f "TIMED OUT" #f))
+ (thread-join! th1 secs))
+ res))))
+
+;; (define (zmq-transport:self-ping server-info)
+;; ;; server-info: server-id interface pullport pubport
+;; (let ((iface (list-ref server-info 1))
+;; (pullport (list-ref server-info 2))
+;; (pubport (list-ref server-info 3)))
+;; (zmq-transport:client-connect iface pullport pubport)
+;; (let loop ()
+;; (thread-sleep! 2)
+;; (cdb:client-call *runremote* 'ping #t)
+;; (debug:print 4 "zmq-transport:self-ping - I'm alive on " iface ":" pullport "/" pubport "!")
+;; (mutex-lock! *heartbeat-mutex*)
+;; (set! *server-loop-heart-beat* (current-seconds))
+;; (mutex-unlock! *heartbeat-mutex*)
+;; (loop))))
+
+(define (zmq-transport:reply pubsock target query-sig success/fail result)
+ (debug:print-info 11 "zmq-transport:reply target=" target ", result=" result)
+ (send-message pubsock target send-more: #t)
+ (send-message pubsock (db:obj->string (vector success/fail query-sig result))))
+
ADDED rmt.scm
Index: rmt.scm
==================================================================
--- /dev/null
+++ rmt.scm
@@ -0,0 +1,369 @@
+;;======================================================================
+;; Copyright 2006-2013, Matthew Welland.
+;;
+;; This program is made available under the GNU GPL version 2.0 or
+;; greater. See the accompanying file COPYING for details.
+;;
+;; This program is distributed WITHOUT ANY WARRANTY; without even the
+;; implied warranty of MERCHANTABILITY or FITNESS FOR A PARTICULAR
+;; PURPOSE.
+;;======================================================================
+
+(use json)
+
+(declare (unit rmt))
+(declare (uses api))
+(declare (uses tdb))
+(declare (uses http-transport))
+
+;;
+;; THESE ARE ALL CALLED ON THE CLIENT SIDE!!!
+;;
+
+;; ;; For debugging add the following to ~/.megatestrc
+;;
+;; (require-library trace)
+;; (import trace)
+;; (trace
+;; rmt:send-receive
+;; api:execute-requests
+;; )
+
+
+;;======================================================================
+;; S U P P O R T F U N C T I O N S
+;;======================================================================
+
+;; cmd is a symbol
+;; vars is a json string encoding the parameters for the call
+;;
+(define (rmt:send-receive cmd rid params)
+ (let* ((run-id (if rid rid 0))
+ (connection-info (let ((cinfo (hash-table-ref/default *runremote* run-id #f)))
+ (if cinfo
+ cinfo
+ (let loop ((numtries 100))
+ (let ((res (client:setup run-id)))
+ (if res
+ (hash-table-ref/default *runremote* run-id #f) ;; client:setup filled this in (hopefully)
+ (if (> numtries 0)
+ (begin
+ (thread-sleep! 10)
+ (loop (- numtries 1)))
+ (begin
+ (debug:print 0 "ERROR: 100 tries and no server, giving up")
+ (exit 1)))))))))
+ (jparams (db:obj->string params))
+ (res (http-transport:client-api-send-receive run-id connection-info cmd jparams)))
+ (if res
+ (db:string->obj res)
+ (let ((new-connection-info (client:setup run-id)))
+ (debug:print 0 "WARNING: Communication failed, trying call to http-transport:client-api-send-receive again.")
+ (rmt:send-receive cmd run-id params)))))
+
+(define (rmt:send-receive-no-auto-client-setup connection-info cmd run-id params)
+ (let* ((run-id (if run-id run-id 0))
+ (jparams (db:obj->string params)) ;; (rmt:dat->json-str params))
+ (res (http-transport:client-api-send-receive run-id connection-info cmd jparams)))
+ (if res
+ (db:string->obj res)
+ res)))
+
+;; Wrap json library for strings (why the ports crap in the first place?)
+(define (rmt:dat->json-str dat)
+ (with-output-to-string
+ (lambda ()
+ (json-write dat))))
+
+(define (rmt:json-str->dat json-str)
+ (with-input-from-string json-str
+ (lambda ()
+ (json-read))))
+
+;;======================================================================
+;;
+;; A C T U A L A P I C A L L S
+;;
+;;======================================================================
+
+;;======================================================================
+;; S E R V E R
+;;======================================================================
+
+(define (rmt:kill-server run-id)
+ (rmt:send-receive 'kill-server run-id (list run-id)))
+
+(define (rmt:start-server run-id)
+ (rmt:send-receive 'start-server 0 (list run-id)))
+
+;;======================================================================
+;; M I S C
+;;======================================================================
+
+(define (rmt:login run-id)
+ (rmt:send-receive 'login run-id (list *toppath* megatest-version run-id *my-client-signature*)))
+
+;; This login does no retries under the hood - it acts a bit like a ping.
+;;
+(define (rmt:login-no-auto-client-setup connection-info run-id)
+ (rmt:send-receive-no-auto-client-setup connection-info 'login run-id (list *toppath* megatest-version run-id *my-client-signature*)))
+
+;; hand off a call to one of the db:queries statements
+;; added run-id to make looking up the correct db possible
+;;
+(define (rmt:general-call stmtname run-id . params)
+ (rmt:send-receive 'general-call run-id (append (list stmtname run-id) params)))
+
+(define (rmt:sync-inmem->db run-id)
+ (rmt:send-receive 'sync-inmem->db run-id '()))
+
+(define (rmt:sdb-qry qry val run-id)
+ ;; add caching if qry is 'getid or 'getstr
+ (rmt:send-receive 'sdb-qry run-id (list qry val)))
+
+;; NOT COMPLETED
+(define (rmt:runtests user run-id testpatt params)
+ (rmt:send-receive 'runtests run-id testpatt))
+
+;;======================================================================
+;; K E Y S
+;;======================================================================
+
+;; These require run-id because the values come from the run!
+;;
+(define (rmt:get-key-val-pairs run-id)
+ (rmt:send-receive 'get-key-val-pairs run-id (list run-id)))
+
+(define (rmt:get-keys)
+ (rmt:send-receive 'get-keys #f '()))
+
+;;======================================================================
+;; T E S T S
+;;======================================================================
+
+(define (rmt:get-test-id run-id testname item-path)
+ (rmt:send-receive 'get-test-id run-id (list run-id testname item-path)))
+
+(define (rmt:get-test-info-by-id run-id test-id)
+ (if (and (number? run-id)(number? test-id))
+ (rmt:send-receive 'get-test-info-by-id run-id (list run-id test-id))
+ (begin
+ (debug:print 0 "ERROR: Bad data handed to rmt:get-test-info-by-id run-id=" run-id ", test-id=" test-id)
+ (print-call-chain)
+ #f)))
+
+(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))
+ (let* ((test-path (if (string? work-area)
+ work-area
+ (rmt:test-get-rundir-from-test-id run-id test-id))))
+ (debug:print 3 "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)
+ (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)
+ (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)
+ (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))
+ (begin
+ (debug:print "ERROR: rmt:get-tests-for-run called with bad run-id=" run-id)
+ (print-call-chain)
+ '())))
+
+(define (rmt:get-tests-for-runs-mindata run-ids testpatt states status not-in)
+ (let ((run-id-list (if run-ids
+ run-ids
+ (rmt:get-all-run-ids))))
+ (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)
+ (rmt:send-receive 'delete-test-records run-id (list run-id test-id)))
+
+(define (rmt:test-set-status-state run-id test-id status state msg)
+ (rmt:send-receive 'test-set-status-state run-id (list run-id test-id status state msg)))
+
+;; (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)
+ (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)
+ (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)
+ (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)
+ (rmt:send-receive 'get-testinfo-state-status run-id (list run-id test-id)))
+
+(define (rmt:test-set-log! run-id test-id logf)
+ (if (string? logf)(rmt:general-call 'test-set-log run-id logf 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)))
+
+;; NOTE: This will open and access ALL run databases.
+;;
+(define (rmt:test-get-paths-matching-keynames-target-new keynames target res testpatt statepatt statuspatt runname)
+ (let ((run-ids (rmt:get-run-ids-matching-target keynames target res runname testpatt statepatt statuspatt)))
+ (apply append
+ (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-run-ids-matching keynames target res)
+ (rmt:send-receive #f 'get-run-ids-matching (list keynames target res)))
+
+(define (rmt:get-prereqs-not-met run-id waitons ref-item-path #!key (mode 'normal))
+ (rmt:send-receive 'get-prereqs-not-met run-id (list run-id waitons ref-item-path mode)))
+
+(define (rmt:get-count-tests-running-for-run-id run-id)
+ (rmt:send-receive 'get-count-tests-running-for-run-id run-id (list run-id)))
+
+;; Statistical queries
+
+(define (rmt:get-count-tests-running run-id)
+ (rmt:send-receive 'get-count-tests-running run-id (list run-id)))
+
+(define (rmt:get-count-tests-running-in-jobgroup run-id jobgroup)
+ (rmt:send-receive 'get-count-tests-running-in-jobgroup run-id (list run-id jobgroup)))
+
+(define (rmt:roll-up-pass-fail-counts run-id test-name item-path status)
+ (rmt:send-receive 'roll-up-pass-fail-counts run-id (list run-id test-name item-path status)))
+
+(define (rmt:update-pass-fail-counts run-id test-name)
+ (rmt:general-call 'update-fail-pass-counts run-id (list run-id test-name run-id test-name run-id test-name)))
+
+;;======================================================================
+;; R U N S
+;;======================================================================
+
+(define (rmt:get-run-info run-id)
+ (rmt:send-receive 'get-run-info run-id (list run-id)))
+
+;; Use the special run-id == #f scenario here since there is no run yet
+(define (rmt:register-run keyvals runname state status user)
+ (rmt:send-receive 'register-run #f (list keyvals runname state status user)))
+
+(define (rmt:get-run-name-from-id run-id)
+ (rmt:send-receive 'get-run-name-from-id run-id (list run-id)))
+
+(define (rmt:delete-run run-id)
+ (rmt:send-receive 'delete-run run-id (list run-id)))
+
+(define (rmt:delete-old-deleted-test-records)
+ (rmt:send-receive 'delete-old-deleted-test-records #f '()))
+
+(define (rmt:get-runs runpatt count offset keypatts)
+ (rmt:send-receive 'get-runs #f (list runpatt count offset keypatts)))
+
+(define (rmt:get-runs runpatt count offset keypatts)
+ (rmt:send-receive 'get-runs #f (list runpatt count offset keypatts)))
+
+(define (rmt:get-all-run-ids)
+ (rmt:send-receive 'get-all-run-ids #f '()))
+
+(define (rmt:get-prev-run-ids run-id)
+ (rmt:send-receive 'get-prev-run-ids #f (list run-id)))
+
+(define (rmt:lock/unlock-run run-id lock unlock user)
+ (rmt:send-receive 'lock/unlock-run #f (list run-id lock unlock user)))
+
+(define (rmt:update-run-event_time run-id)
+ (rmt:send-receive 'update-run-event_time #f (list run-id)))
+
+(define (rmt:get-runs-by-patt keys runnamepatt targpatt offset limit)
+ (rmt:send-receive 'get-runs-by-patt #f (list keys runnamepatt targpatt offset limit)))
+
+;;======================================================================
+;; M U L T I R U N Q U E R I E S
+;;======================================================================
+
+;; get the previous record for when this test was run where all keys match but runname
+;; returns #f if no such test found, returns a single test record if found
+;;
+;; Run this at the client end since we have to connect to multiple run-id dbs
+;;
+(define (rmt:get-previous-test-run-record run-id test-name item-path)
+ (let* ((keyvals (rmt:get-key-val-pairs run-id))
+ (keys (rmt:get-keys))
+ (selstr (string-intersperse keys ","))
+ (qrystr (string-intersperse (map (lambda (x)(conc x "=?")) keys) " AND ")))
+ (if (not keyvals)
+ #f
+ (let ((prev-run-ids (rmt:get-prev-run-ids run-id)))
+ ;; for each run starting with the most recent look to see if there is a matching test
+ ;; if found then return that matching test record
+ (debug:print 4 "selstr: " selstr ", qrystr: " qrystr ", keyvals: " keyvals ", previous run ids found: " prev-run-ids)
+ (if (null? prev-run-ids) #f
+ (let loop ((hed (car prev-run-ids))
+ (tal (cdr prev-run-ids)))
+ (let ((results (rmt:get-tests-for-run hed (conc test-name "/" item-path) '() '() #f #f #f #f #f #f)))
+ (debug:print 4 "Got tests for run-id " run-id ", test-name " test-name ", item-path " item-path ": " results)
+ (if (and (null? results)
+ (not (null? tal)))
+ (loop (car tal)(cdr tal))
+ (if (null? results) #f
+ (car results))))))))))
+
+;;======================================================================
+;; S T E P S
+;;======================================================================
+
+;; Getting steps is more complicated.
+;;
+;; If given work area
+;; 1. Find the testdat.db file
+;; 2. Open the testdat.db file and do the query
+;; If not given the work area
+;; 1. Do a remote call to get the test path
+;; 2. Continue as above
+;;
+(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)
+ (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 "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:get-steps-for-test run-id test-id)
+ (rmt:send-receive 'get-steps-for-test run-id (list test-id)))
+
+;;======================================================================
+;; T E S T D A T A
+;;======================================================================
+
+(define (rmt:read-test-data run-id test-id categorypatt #!key (work-area #f))
+ (let ((tdb (rmt:open-test-db-by-test-id run-id test-id work-area: work-area)))
+ (if tdb
+ (tdb:read-test-data tdb test-id categorypatt)
+ '())))
+
+(define (rmt:testmeta-add-record testname)
+ (rmt:send-receive 'testmeta-add-record #f (list testname)))
+
+(define (rmt:testmeta-get-record testname)
+ (rmt:send-receive 'testmeta-get-record #f (list testname)))
+
+(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)
+ (rmt:send-receive 'test-data-rollup run-id (list run-id test-id status)))
+
+(define (rmt:csv->test-data run-id test-id csvdata)
+ (rmt:send-receive 'csv->test-data run-id (list run-id test-id csvdata)))
ADDED rmtdb.scm
Index: rmtdb.scm
==================================================================
--- /dev/null
+++ rmtdb.scm
@@ -0,0 +1,11 @@
+;;======================================================================
+;; Copyright 2006-2013, Matthew Welland.
+;;
+;; This program is made available under the GNU GPL version 2.0 or
+;; greater. See the accompanying file COPYING for details.
+;;
+;; This program is distributed WITHOUT ANY WARRANTY; without even the
+;; implied warranty of MERCHANTABILITY or FITNESS FOR A PARTICULAR
+;; PURPOSE.
+;;======================================================================
+
Index: runconfig.scm
==================================================================
--- runconfig.scm
+++ runconfig.scm
@@ -29,11 +29,11 @@
(debug:print 4 "Using key=\"" thekey "\"")
(if change-env
(for-each ;; NB// This can be simplified with new content of keyvals having all that is needed.
(lambda (keyval)
- (setenv (car keyval)(cadr keyval)))
+ (safe-setenv (car keyval)(cadr keyval)))
keyvals))
(for-each
(lambda (section)
(let ((section-dat (hash-table-ref/default confdat section #f)))
@@ -43,11 +43,11 @@
(let ((val (cadr (assoc envvar section-dat))))
(hash-table-set! whatfound section (+ (hash-table-ref/default whatfound section 0) 1))
(if (and (string? envvar)
(string? val)
change-env)
- (setenv envvar val))
+ (safe-setenv envvar val))
(hash-table-set! finaldat envvar val)))
(map car section-dat)))))
sections)
(if already-seen
(begin
Index: runs.scm
==================================================================
--- runs.scm
+++ runs.scm
@@ -19,10 +19,11 @@
(declare (uses items))
(declare (uses runconfig))
(declare (uses tests))
(declare (uses server))
(declare (uses mt))
+;; (declare (uses filedb))
(include "common_records.scm")
(include "key_records.scm")
(include "db_records.scm")
(include "run_records.scm")
@@ -57,15 +58,10 @@
(runconfig #f)
(serverdat (if (args:get-arg "-server")
*runremote*
#f)) ;; to be used later
(transport (or (args:get-arg "-transport") 'http))
- (db (if (and mconfig
- (or (args:get-arg "-server")
- (eq? transport 'fs)))
- (open-db)
- #f))
(run-id #f))
;; Set all the environment vars we know so far, start with keys
(for-each (lambda (keyval)
(setenv (car keyval)(cadr keyval)))
keyvals)
@@ -88,44 +84,44 @@
(exit 1)))
;; Now have runconfigs data loaded, set environment vars
(for-each (lambda (section)
(for-each (lambda (varval)
(set! envdat (append envdat (list varval)))
- (setenv (car varval)(cadr varval)))
+ (safe-setenv (car varval)(cadr varval)))
(configf:get-section runconfig section)))
(list "default" target))
(vector target runname testpatt keys keyvals envdat mconfig runconfig serverdat transport db toppath run-id)))
(define (set-megatest-env-vars run-id #!key (inkeys #f)(inrunname #f)(inkeyvals #f))
(let* ((target (or (args:get-arg "-reqtarg")
(args:get-arg "-target")
(get-environment-variable "MT_TARGET")))
- (keys (if inkeys inkeys (cdb:remote-run db:get-keys #f)))
+ (keys (if inkeys inkeys (rmt:get-keys)))
(keyvals (if inkeyvals inkeyvals (keys:target->keyval keys target)))
(vals (hash-table-ref/default *env-vars-by-run-id* run-id #f)))
;; get the info from the db and put it in the cache
(if (not vals)
(let ((ht (make-hash-table)))
(hash-table-set! *env-vars-by-run-id* run-id ht)
(set! vals ht)
(for-each
(lambda (key)
- (hash-table-set! vals (car key) (cadr key))) ;; (cdb:remote-run db:get-run-key-val #f run-id (car key))))
+ (hash-table-set! vals (car key) (cadr key)))
keyvals)))
;; from the cached data set the vars
(hash-table-for-each
vals
(lambda (key val)
(debug:print 2 "setenv " key " " val)
- (if (and (string? key)
- (string? val))
- (setenv key val)
- (debug:print 0 "ERROR: Malformed environment variable definition: var=" var ", val=" val))))
+ (safe-setenv key val)))
(if (not (get-environment-variable "MT_TARGET"))(setenv "MT_TARGET" target))
(alist->env-vars (hash-table-ref/default *configdat* "env-override" '()))
;; Lets use this as an opportunity to put MT_RUNNAME in the environment
- (setenv "MT_RUNNAME" (if inrunname inrunname (cdb:remote-run db:get-run-name-from-id #f run-id)))
+ (let ((runname (if inrunname inrunname (rmt:get-run-name-from-id run-id))))
+ (if runname
+ (setenv "MT_RUNNAME" runname)
+ (debug:print 0 "ERROR: no value for runname for id " run-id)))
(setenv "MT_RUN_AREA_HOME" *toppath*)))
(define (set-item-env-vars itemdat)
(for-each (lambda (item)
(debug:print 2 "setenv " (car item) " " (cadr item))
@@ -136,19 +132,20 @@
;;
;; NOTE: We run this server-side!! Do not use this global except in the runs:can-run-more-tests routine
;;
(define *last-num-running-tests* 0)
(define *runs:can-run-more-tests-count* 0)
-(define (runs:shrink-can-run-more-tests-count) ;; the db is a dummy var so we can use cdb:remote-run
+(define (runs:shrink-can-run-more-tests-count)
(set! *runs:can-run-more-tests-count* 0)) ;; (/ *runs:can-run-more-tests-count* 2)))
;; Temporary globals. Move these into the logic or into common
;;
(define *seen-cant-run-tests* (make-hash-table)) ;; use to track tests that we suspect cannot be run
(define (runs:inc-cant-run-tests testname)
(hash-table-set! *seen-cant-run-tests* testname
(+ (hash-table-ref/default *seen-cant-run-tests* testname 0) 1)))
+
(define (runs:can-keep-running? testname n)
(< (hash-table-ref/default *seen-cant-run-tests* testname 0) n))
(define *runs:denoise* (make-hash-table)) ;; key => last-time-ran
@@ -159,16 +156,16 @@
(begin
(hash-table-set! *runs:denoise* key currtime)
#t)
#f)))
-(define (runs:can-run-more-tests jobgroup max-concurrent-jobs)
+(define (runs:can-run-more-tests run-id jobgroup max-concurrent-jobs)
(thread-sleep! (cond
((> *runs:can-run-more-tests-count* 20) 2);; obviously haven't had any work to do for a while
(else 0)))
- (let* ((num-running (cdb:remote-run db:get-count-tests-running #f))
- (num-running-in-jobgroup (cdb:remote-run db:get-count-tests-running-in-jobgroup #f jobgroup))
+ (let* ((num-running (rmt:get-count-tests-running run-id))
+ (num-running-in-jobgroup (rmt:get-count-tests-running-in-jobgroup run-id jobgroup))
(job-group-limit (let ((jobg-count (config-lookup *configdat* "jobgroups" jobgroup)))
(if (string? jobg-count)
(string->number jobg-count)
jobg-count))))
(if (> (+ num-running num-running-in-jobgroup) 0)
@@ -201,26 +198,21 @@
;; test-names: Comma separated patterns same as test-patts but used in selection
;; of tests to run. The item portions are not respected.
;; FIXME: error out if /patt specified
;;
(define (runs:run-tests target runname test-patts user flags) ;; test-names
- (common:clear-caches) ;; clear all caches
(let* ((keys (keys:config-get-fields *configdat*))
(keyvals (keys:target->keyval keys target))
- (run-id (cdb:remote-run db:register-run #f keyvals runname "new" "n/a" user)) ;; test-name)))
+ (run-id (rmt:register-run keyvals runname "new" "n/a" user)) ;; test-name)))
(deferred '()) ;; delay running these since they have a waiton clause
(runconfigf (conc *toppath* "/runconfigs.config"))
(required-tests '())
(test-records (make-hash-table))
(all-tests-registry (tests:get-all)) ;; (tests:get-valid-tests (make-hash-table) test-search-path)) ;; all valid tests to check waiton names
(all-test-names (hash-table-keys all-tests-registry))
(test-names (tests:filter-test-names all-test-names test-patts)))
- ;; Update the synchronous setting in the db based on the default or what is set by the user
- ;; This is done once here on a call to run tests rather than on every call to open-db
- (cdb:remote-run db:set-sync #f)
-
(set-megatest-env-vars run-id inkeys: keys inrunname: runname) ;; these may be needed by the launching process
(if (file-exists? runconfigf)
(setup-env-defaults runconfigf run-id *already-seen-runconfig-info* keyvals "pre-launch-env-vars")
(debug:print 0 "WARNING: You do not have a run config file: " runconfigf))
@@ -236,12 +228,12 @@
(begin
;; have to delete test records where NOT_STARTED since they can cause -keepgoing to
;; get stuck due to becoming inaccessible from a failed test. I.e. if test B depends
;; on test A but test B reached the point on being registered as NOT_STARTED and test
;; A failed for some reason then on re-run using -keepgoing the run can never complete.
- (cdb:delete-tests-in-state *runremote* run-id "NOT_STARTED")
- (cdb:remote-run db:set-tests-state-status #f run-id test-names #f "FAIL" "NOT_STARTED" "FAIL")))
+ (rmt:general-call 'delete-tests-in-state run-id "NOT_STARTED")
+ (rmt:set-tests-state-status run-id test-names #f "FAIL" "NOT_STARTED" "FAIL")))
;; Ensure all tests are registered in the test_meta table
(runs:update-all-test_meta #f)
;; now add non-directly referenced dependencies (i.e. waiton)
@@ -385,11 +377,11 @@
(define runs:nothing-left-in-queue-count 0)
(define (runs:expand-items hed tal reg reruns regfull newtal jobgroup max-concurrent-jobs run-id waitons item-path testmode test-record can-run-more items runname tconfig reglen test-registry test-records)
(let* ((loop-list (list hed tal reg reruns))
- (prereqs-not-met (mt:lazy-get-prereqs-not-met run-id waitons item-path mode: testmode))
+ (prereqs-not-met (rmt:get-prereqs-not-met run-id waitons item-path testmode))
(fails (runs:calc-fails prereqs-not-met))
(non-completed (runs:calc-not-completed prereqs-not-met)))
(debug:print-info 4 "START OF INNER COND #2 "
"\n can-run-more: " can-run-more
"\n testname: " hed
@@ -584,17 +576,17 @@
(else
(conc t))))
inlst))
(define (runs:process-expanded-tests hed tal reg reruns reglen regfull test-record runname test-name item-path jobgroup max-concurrent-jobs run-id waitons item-path testmode test-patts required-tests test-registry registry-mutex flags keyvals run-info newtal all-tests-registry)
- (let* ((run-limits-info (runs:can-run-more-tests jobgroup max-concurrent-jobs)) ;; look at the test jobgroup and tot jobs running
+ (let* ((run-limits-info (runs:can-run-more-tests run-id jobgroup max-concurrent-jobs)) ;; look at the test jobgroup and tot jobs running
(have-resources (car run-limits-info))
(num-running (list-ref run-limits-info 1))
(num-running-in-jobgroup (list-ref run-limits-info 2))
(max-concurrent-jobs (list-ref run-limits-info 3))
(job-group-limit (list-ref run-limits-info 4))
- (prereqs-not-met (mt:lazy-get-prereqs-not-met run-id waitons item-path mode: testmode))
+ (prereqs-not-met (rmt:get-prereqs-not-met run-id waitons item-path testmode))
(fails (runs:calc-fails prereqs-not-met))
(non-completed (runs:calc-not-completed prereqs-not-met))
(loop-list (list hed tal reg reruns)))
(debug:print-info 4 "have-resources: " have-resources " prereqs-not-met: ("
(string-intersperse
@@ -630,20 +622,20 @@
;;
((not (hash-table-ref/default test-registry (runs:make-full-test-name test-name item-path) #f))
(debug:print-info 4 "Pre-registering test " test-name "/" item-path " to create placeholder" )
(if (eq? *transport-type* 'fs) ;; no point in parallel registration if use fs
(begin
- (cdb:tests-register-test *runremote* run-id test-name item-path)
+ (rmt:general-call 'register-test run-id run-id test-name item-path)
(hash-table-set! test-registry (runs:make-full-test-name test-name item-path) 'done))
(let ((th (make-thread (lambda ()
(mutex-lock! registry-mutex)
(hash-table-set! test-registry (runs:make-full-test-name test-name item-path) 'start)
(mutex-unlock! registry-mutex)
;; If haven't done it before register a top level test if this is an itemized test
(if (not (eq? (hash-table-ref/default test-registry (runs:make-full-test-name test-name "") #f) 'done))
- (cdb:tests-register-test *runremote* run-id test-name ""))
- (cdb:tests-register-test *runremote* run-id test-name item-path)
+ (rmt:general-call 'register-test run-id run-id test-name ""))
+ (rmt:general-call 'register-test run-id run-id test-name item-path)
(mutex-lock! registry-mutex)
(hash-table-set! test-registry (runs:make-full-test-name test-name item-path) 'done)
(mutex-unlock! registry-mutex))
(conc test-name "/" item-path))))
(thread-start! th)))
@@ -755,11 +747,11 @@
;; Do mark-and-find clean up of db before starting runing of quue
;;
;; (cdb:remote-run db:find-and-mark-incomplete #f)
- (let ((run-info (cdb:remote-run db:get-run-info #f run-id))
+ (let ((run-info (rmt:get-run-info run-id))
(tests-info (mt:get-tests-for-run run-id #f '() '())) ;; qryvals: "id,testname,item_path"))
(sorted-test-names (tests:sort-by-priority-and-waiton test-records))
(test-registry (make-hash-table))
(registry-mutex (make-mutex))
(num-retries 0)
@@ -809,11 +801,11 @@
(items (tests:testqueue-get-items test-record))
(item-path (item-list->path itemdat))
(tfullname (runs:make-full-test-name test-name item-path))
(newtal (append tal (list hed)))
(regfull (>= (length reg) reglen))
- (num-running (cdb:remote-run db:get-count-tests-running-for-run-id #f run-id)))
+ (num-running (rmt:get-count-tests-running-for-run-id run-id)))
(if (> num-running 0)
(set! last-time-some-running (current-seconds)))
(if (> (current-seconds)(+ last-time-some-running 60))
@@ -822,11 +814,11 @@
;; Ensure all top level tests get registered. This way they show up as "NOT_STARTED" on the dashboard
;; and it is clear they *should* have run but did not.
(if (not (hash-table-ref/default test-registry (runs:make-full-test-name test-name "") #f))
(begin
- (cdb:tests-register-test *runremote* run-id test-name "")
+ (rmt:general-call 'register-test run-id run-id test-name "")
(hash-table-set! test-registry (runs:make-full-test-name test-name "") 'done)))
;; Fast skip of tests that are already "COMPLETED" - NO! Cannot do that as the items may not have been expanded yet :(
;;
(if (member (hash-table-ref/default test-registry tfullname #f)
@@ -938,11 +930,11 @@
;; if items is a proc then need to run items:get-items-from-config, get the list and loop
;; - but only do that if resources exist to kick off the job
;; EXPAND ITEMS
((or (procedure? items)(eq? items 'have-procedure))
- (let ((can-run-more (runs:can-run-more-tests jobgroup max-concurrent-jobs)))
+ (let ((can-run-more (runs:can-run-more-tests run-id jobgroup max-concurrent-jobs)))
(if (and (list? can-run-more)
(car can-run-more))
(let ((loop-list (runs:expand-items hed tal reg reruns regfull newtal jobgroup max-concurrent-jobs run-id waitons item-path testmode test-record can-run-more items runname tconfig reglen test-registry test-records)))
(if loop-list
(apply loop loop-list)))
@@ -1044,12 +1036,12 @@
(hash-table-set! *test-meta-updated* test-name #t)
(runs:update-test_meta test-name test-conf)))
;; itemdat => ((ripeness "overripe") (temperature "cool") (season "summer"))
(let* ((new-test-path (string-intersperse (cons test-path (map cadr itemdat)) "/"))
- (test-id (cdb:remote-run db:get-test-id-cached #f run-id test-name item-path))
- (testdat (if test-id (cdb:get-test-info-by-id *runremote* test-id) #f)))
+ (test-id (rmt:get-test-id run-id test-name item-path))
+ (testdat (if test-id (rmt:get-test-info-by-id run-id test-id) #f)))
(if (not testdat)
(let loop ()
;; ensure that the path exists before registering the test
;; NOPE: Cannot! Don't know yet which disk area will be assigned....
;; (system (conc "mkdir -p " new-test-path))
@@ -1056,18 +1048,18 @@
;;
;; (open-run-close tests:register-test db run-id test-name item-path)
;;
;; NB// for the above line. I want the test to be registered long before this routine gets called!
;;
- (if (not test-id)(set! test-id (cdb:remote-run db:get-test-id-cached #f run-id test-name item-path)))
+ (if (not test-id)(set! test-id (rmt:get-test-id-cached run-id test-name item-path)))
(if (not test-id)
(begin
(debug:print 2 "WARN: Test not pre-created? test-name=" test-name ", item-path=" item-path ", run-id=" run-id)
- (cdb:tests-register-test *runremote* run-id test-name item-path)
- (set! test-id (cdb:remote-run db:get-test-id-cached #f run-id test-name item-path))))
+ (rmt:general-call 'register-test run-id run-id test-name item-path)
+ (set! test-id (rmt:get-test-id run-id test-name item-path))))
(debug:print-info 4 "test-id=" test-id ", run-id=" run-id ", test-name=" test-name ", item-path=\"" item-path "\"")
- (set! testdat (cdb:get-test-info-by-id *runremote* test-id))
+ (set! testdat (rmt:get-test-info-by-id run-id test-id))
(if (not testdat)
(begin
(debug:print-info 0 "WARNING: server is overloaded, trying again in one second")
(thread-sleep! 1)
(loop)))))
@@ -1133,20 +1125,21 @@
(cond
;; Have to check for skip conditions. This one skips if there are same-named tests
;; currently running
((and skip-check
(configf:lookup test-conf "skip" "prevrunning"))
- (let ((running-tests (cdb:remote-run db:get-tests-for-runs-mindata #f #f full-test-name '("RUNNING" "REMOTEHOSTSTART" "LAUNCHED") '() #f)))
+ ;; run-ids = #f means *all* runs
+ (let ((running-tests (rmt:get-tests-for-runs-mindata #f full-test-name '("RUNNING" "REMOTEHOSTSTART" "LAUNCHED") '() #f)))
(if (not (null? running-tests)) ;; have to skip
(set! skip-test "Skipping due to previous tests running"))))
((and skip-check
(configf:lookup test-conf "skip" "fileexists"))
(if (file-exists? (configf:lookup test-conf "skip" "fileexists"))
(set! skip-test (conc "Skipping due to existance of file " (configf:lookup test-conf "skip" "fileexists"))))))
(if skip-test
(begin
- (mt:test-set-state-status-by-id test-id "COMPLETED" "SKIP" skip-test)
+ (mt:test-set-state-status-by-id run-id test-id "COMPLETED" "SKIP" skip-test)
(debug:print-info 1 "SKIPPING Test " full-test-name " due to " skip-test))
(if (not (launch-test test-id run-id run-info keyvals runname test-conf test-name test-path itemdat flags))
(begin
(print "ERROR: Failed to launch the test. Exiting as soon as possible")
(set! *globalexitstatus* 1) ;;
@@ -1158,11 +1151,11 @@
(if (> (- (current-seconds)(+ (db:test-get-event_time testdat)
(db:test-get-run_duration testdat)))
600) ;; i.e. no update for more than 600 seconds
(begin
(debug:print 0 "WARNING: Test " test-name " appears to be dead. Forcing it to state INCOMPLETE and status STUCK/DEAD")
- (tests:test-set-status! test-id "INCOMPLETE" "STUCK/DEAD" "Test is stuck or dead" #f))
+ (tests:test-set-status! run-id test-id "INCOMPLETE" "STUCK/DEAD" "Test is stuck or dead" #f))
(debug:print 2 "NOTE: " test-name " is already running")))
(else
(debug:print 0 "ERROR: Failed to launch test " full-test-name ". Unrecognised state " (test:get-state testdat))
(case (string->symbol (test:get-state testdat))
((COMPLETED INCOMPLETE)
@@ -1213,11 +1206,11 @@
;; NB// should pass in keys?
;;
(define (runs:operate-on action target runnamepatt testpatt #!key (state #f)(status #f)(new-state-status #f))
(common:clear-caches) ;; clear all caches
(let* ((db #f)
- (keys (cdb:remote-run db:get-keys db))
+ (keys (rmt:get-keys))
(rundat (mt:get-runs-by-patt keys runnamepatt target))
(header (vector-ref rundat 0))
(runs (vector-ref rundat 1))
(states (if state (string-split state ",") '()))
(statuses (if status (string-split status ",") '()))
@@ -1258,29 +1251,33 @@
action)
((run-wait)
(debug:print 1 "Waiting for run " runkey ", run=" runnamepatt " to complete"))
(else
(debug:print-info 0 "action not recognised " action)))
- (let ((sorted-tests (sort tests (lambda (a b)(let ((dira (db:test-get-rundir a))
- (dirb (db:test-get-rundir b)))
+ (let ((sorted-tests (sort tests (lambda (a b)(let ((dira ;; (rmt:sdb-qry 'getstr
+ (db:test-get-rundir a)) ;; ) ;; (filedb:get-path *fdb* (db:test-get-rundir a)))
+ (dirb ;; (rmt:sdb-qry 'getstr
+ (db:test-get-rundir b))) ;; ) ;; ((filedb:get-path *fdb* (db:test-get-rundir b))))
(if (and (string? dira)(string? dirb))
(> (string-length dira)(string-length dirb))
#f)))))
(test-retry-time (make-hash-table))
(allow-run-time 10)) ;; seconds to allow for killing tests before just brutally killing 'em
(let loop ((test (car sorted-tests))
(tal (cdr sorted-tests)))
(let* ((test-id (db:test-get-id test))
- (new-test-dat (cdb:get-test-info-by-id *runremote* test-id)))
+ (new-test-dat (rmt:get-test-info-by-id run-id test-id)))
(if (not new-test-dat)
(begin
(debug:print 0 "ERROR: We have a test-id of " test-id " but no record was found. NOTE: No locking of records is done between processes, do not simultaneously remove the same run from two processes!")
(if (not (null? tal))
(loop (car tal)(cdr tal))))
(let* ((item-path (db:test-get-item-path new-test-dat))
(test-name (db:test-get-testname new-test-dat))
- (run-dir (db:test-get-rundir new-test-dat)) ;; run dir is from the link tree
+ (run-dir ;;(filedb:get-path *fdb*
+ ;; (rmt:sdb-qry 'getid
+ (db:test-get-rundir new-test-dat)) ;; ) ;; run dir is from the link tree
(real-dir (if (file-exists? run-dir)
(resolve-pathname run-dir)
#f))
(test-state (db:test-get-state new-test-dat))
(test-fulln (db:test-get-fullname new-test-dat)))
@@ -1297,21 +1294,21 @@
;; This test is not in a correct state for cleaning up. Let's try some graceful shutdown steps first
;; Set the test to "KILLREQ" and wait five seconds then try again. Repeat up to five times then give
;; up and blow it away.
(begin
(debug:print 0 "WARNING: could not gracefully remove test " test-fulln ", tried to kill it to no avail. Forcing state to FAILEDKILL and continuing")
- (mt:test-set-state-status-by-id (db:test-get-id test) "FAILEDKILL" "n/a" #f)
+ (mt:test-set-state-status-by-id run-id (db:test-get-id test) "FAILEDKILL" "n/a" #f)
(thread-sleep! 1))
(begin
- (mt:test-set-state-status-by-id (db:test-get-id test) "KILLREQ" "n/a" #f)
+ (mt:test-set-state-status-by-id run-id (db:test-get-id test) "KILLREQ" "n/a" #f)
(thread-sleep! 1)))
;; NOTE: This is suboptimal as the testdata will be used later and the state/status may have changed ...
(if (null? tal)
(loop new-test-dat tal)
(loop (car tal)(append tal (list new-test-dat)))))
(begin
- (mt:test-set-state-status-by-id (db:test-get-id test) "REMOVING" "LOCKED" #f)
+ (mt:test-set-state-status-by-id run-id (db:test-get-id test) "REMOVING" "LOCKED" #f)
(debug:print-info 1 "Attempting to remove " (if real-dir (conc " dir " real-dir " and ") "") " link " run-dir)
(if (and real-dir
(> (string-length real-dir) 5)
(file-exists? real-dir)) ;; bad heuristic but should prevent /tmp /home etc.
(begin ;; let* ((realpath (resolve-pathname run-dir)))
@@ -1339,16 +1336,16 @@
(if run-dir
(debug:print 0 "WARNING: not removing " run-dir " as it either doesn't exist or is not a symlink")
(debug:print 0 "NOTE: the run dir for this test is undefined. Test may have already been deleted."))
))
;; Only delete the records *after* removing the directory. If things fail we have a record
- (cdb:remote-run db:delete-test-records db #f (db:test-get-id test))
+ (rmt:delete-test-records (db:test-get-run_id test)(db:test-get-id test))
(if (not (null? tal))
(loop (car tal)(cdr tal))))))
((set-state-status)
(debug:print-info 2 "new state " (car state-status) ", new status " (cadr state-status))
- (mt:test-set-state-status-by-id (db:test-get-id test) (car state-status)(cadr state-status) #f)
+ (mt:test-set-state-status-by-id run-id (db:test-get-id test) (car state-status)(cadr state-status) #f)
(if (not (null? tal))
(loop (car tal)(cdr tal))))
((run-wait)
(debug:print-info 2 "still waiting, " (length tests) " tests still running")
(thread-sleep! 10)
@@ -1364,15 +1361,13 @@
(let* ((dparts (string-split lasttpath "/"))
(runpath (conc "/" (string-intersperse
(take dparts (- (length dparts) 1))
"/"))))
(debug:print 1 "Removing run: " runkey " " (db:get-value-by-header run header "runname") " and related record")
- (cdb:remote-run db:delete-run db run-id)
- ;; This is a pretty good place to purge old DELETED tests
- (cdb:remote-run db:delete-tests-for-run db run-id)
- (cdb:remote-run db:delete-old-deleted-test-records db)
- (cdb:remote-run db:set-var db "DELETED_TESTS" (current-seconds))
+ (rmt:delete-run run-id)
+ (rmt:delete-old-deleted-test-records)
+ ;; (cdb:remote-run db:set-var db "DELETED_TESTS" (current-seconds))
;; need to figure out the path to the run dir and remove it if empty
;; (if (null? (glob (conc runpath "/*")))
;; (begin
;; (debug:print 1 "Removing run dir " runpath)
;; (system (conc "rmdir -p " runpath))))
@@ -1450,55 +1445,57 @@
(if (or lock
(and unlock
(begin
(print "Do you really wish to unlock run " run-id "?\n y/n: ")
(equal? "y" (read-line)))))
- (cdb:remote-run db:lock/unlock-run db run-id lock unlock user)
+ (rmt:lock/unlock-run run-id lock unlock user)
(debug:print-info 0 "Skipping lock/unlock on " run-id))))
runs)))
;;======================================================================
;; Rollup runs
;;======================================================================
;; Update the test_meta table for this test
(define (runs:update-test_meta test-name test-conf)
- (let ((currrecord (cdb:remote-run db:testmeta-get-record #f test-name)))
+ (let ((currrecord (rmt:testmeta-get-record test-name)))
(if (not currrecord)
(begin
(set! currrecord (make-vector 11 #f))
- (cdb:remote-run db:testmeta-add-record #f test-name)))
+ (rmt:testmeta-add-record test-name)))
(for-each
(lambda (key)
(let* ((idx (cadr key))
(fld (car key))
(val (config-lookup test-conf "test_meta" fld)))
;; (debug:print 5 "idx: " idx " fld: " fld " val: " val)
(if (and val (not (equal? (vector-ref currrecord idx) val)))
(begin
(print "Updating " test-name " " fld " to " val)
- (cdb:remote-run db:testmeta-update-field #f test-name fld val)))))
+ (rmt:testmeta-update-field test-name fld val)))))
'(("author" 2)("owner" 3)("description" 4)("reviewed" 5)("tags" 9)("jobgroup" 10)))))
;; Update test_meta for all tests
(define (runs:update-all-test_meta db)
(let ((test-names (tests:get-all))) ;; (tests:get-valid-tests)))
(for-each
(lambda (test-name)
(let* ((test-conf (mt:lazy-read-test-config test-name)))
- ;; use the cdb:remote-run instead of passing in db
(if test-conf (runs:update-test_meta test-name test-conf))))
(hash-table-keys test-names))))
;; This could probably be refactored into one complex query ...
+;; NOT PORTED - DO NOT USE YET
+;;
(define (runs:rollup-run keys runname user keyvals)
(debug:print 4 "runs:rollup-run, keys: " keys " :runname " runname " user: " user)
(let* ((db #f)
- (new-run-id (cdb:remote-run db:register-run #f keyvals runname "new" "n/a" user))
- (prev-tests (cdb:remote-run test:get-matching-previous-test-run-records db new-run-id "%" "%"))
+ ;; register run operates on the main db
+ (new-run-id (rmt:register-run keyvals runname "new" "n/a" user))
+ (prev-tests (rmt:get-matching-previous-test-run-records new-run-id "%" "%"))
(curr-tests (mt:get-tests-for-run new-run-id "%/%" '() '()))
(curr-tests-hash (make-hash-table)))
- (cdb:remote-run db:update-run-event_time db new-run-id)
+ (rmt:update-run-event_time new-run-id)
;; index the already saved tests by testname and itemdat in curr-tests-hash
(for-each
(lambda (testdat)
(let* ((testname (db:test-get-testname testdat))
(item-path (db:test-get-item-path testdat))
@@ -1512,11 +1509,11 @@
(lambda (testdat)
(let* ((testname (db:test-get-testname testdat))
(item-path (db:test-get-item-path testdat))
(full-name (conc testname "/" item-path))
(prev-test-dat (hash-table-ref/default curr-tests-hash full-name #f))
- (test-steps (cdb:remote-run db:get-steps-for-test db (db:test-get-id testdat)))
+ (test-steps (rmt:get-steps-for-test (db:test-get-id testdat)))
(new-test-record #f))
;; replace these with insert ... select
(apply sqlite3:execute
db
(conc "INSERT OR REPLACE INTO tests (run_id,testname,state,status,event_time,host,cpuload,diskfree,uname,rundir,item_path,run_duration,final_logf,comment) "
Index: sdb.scm
==================================================================
--- sdb.scm
+++ sdb.scm
@@ -20,27 +20,20 @@
(import (prefix base64 base64:))
(declare (unit sdb))
;;
-(define (sdb:open) ;; (conc *toppath* "/megatest.db") (car *configinfo*)))
- (if (not *toppath*)
- (if (not (setup-for-run))
- (begin
- (debug:print 0 "ERROR: Attempted to open db when not in megatest area. Exiting.")
- (exit))))
- (let* ((dbpath (conc *toppath* "/db/sdb.db")) ;; fname)
- (dbexists (let ((fe (file-exists? dbpath)))
+(define (sdb:open fname)
+ (let* ((dbpath (pathname-directory fname))
+ (dbexists (let ((fe (file-exists? fname)))
(if fe
fe
(begin
- (create-directory (conc *toppath* "/db") #t)
+ (create-directory dbpath #t)
#f))))
- (sdb (sqlite3:open-database dbpath))
- (handler (make-busy-timeout (if (args:get-arg "-override-timeout")
- (string->number (args:get-arg "-override-timeout"))
- 136000))))
+ (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))
@@ -48,11 +41,11 @@
(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 strindx ON strs (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))
@@ -77,26 +70,38 @@
(hash-table-set! id-cache id str))
sdb
"SELECT str FROM strs WHERE id=?;" id))
str))
-(define sdb:qry
+;; 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)
- (if (not sdb)(set! sdb (sdb:open)))
(case cmd
- ((init) (if (not sdb)(set! sdb (sdb:open))))
- ((finalize!) (if sdb (sqlite3:finalize! sdb)))
- ((getid) (let ((id (sdb:string->id sdb scache var)))
+ ((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
@@ -8,11 +8,11 @@
;; implied warranty of MERCHANTABILITY or FITNESS FOR A PARTICULAR
;; PURPOSE.
(require-extension (srfi 18) extras tcp s11n)
-(use srfi-1 posix regex regex-case srfi-69 hostinfo md5 message-digest)
+(use srfi-1 posix regex regex-case srfi-69 hostinfo md5 message-digest directory-utils)
;; (use zmq)
(use spiffy uri-common intarweb http-client spiffy-request-vars)
(declare (unit server))
@@ -42,54 +42,23 @@
;; Call this to start the actual server
;;
;; all routes though here end in exit ...
-(define (server:launch transport)
- (if (not *toppath*)
- (if (not (setup-for-run))
- (begin
- (debug:print 0 "ERROR: cannot find megatest.config, exiting")
- (exit))))
- (debug:print-info 2 "Starting server using " transport " transport")
- (set! *transport-type* transport)
- (case transport
- ((fs) (exit)) ;; there is no "fs" server transport
- ((http) (http-transport:launch))
- ((zmq) (zmq-transport:launch))
- (else
- (debug:print "WARNING: unrecognised transport " transport)
- (exit))))
+;;
+;; start_server
+;;
+(define (server:launch run-id)
+ (http-transport:launch run-id))
;;======================================================================
;; Q U E U E M A N A G E M E N T
;;======================================================================
;; We don't want to flush the queue if it was just flushed
(define *server:last-write-flush* (current-milliseconds))
-;; Flush the queue every third of a second. Can we assume that setup-for-run
-;; has already been done?
-(define (server:write-queue-handler)
- (if (setup-for-run)
- (let ((db (open-db)))
- (let loop ()
- (let ((last-write-flush-time #f))
- (mutex-lock! *incoming-mutex*)
- (set! last-write-flush-time *server:last-write-flush*)
- (mutex-unlock! *incoming-mutex*)
- (if (> (- (current-milliseconds) last-write-flush-time) 10)
- (begin
- (mutex-lock! *db:process-queue-mutex*)
- (db:process-cached-writes db)
- (mutex-unlock! *db:process-queue-mutex*)
- (thread-sleep! 0.005))))
- (loop)))
- (begin
- (debug:print 0 "ERROR: failed to setup for Megatest in server:write-queue-handler")
- (exit 1))))
-
;;======================================================================
;; S E R V E R U T I L I T I E S
;;======================================================================
;; Generate a unique signature for this server
@@ -103,45 +72,120 @@
;; When using zmq this would send the message back (two step process)
;; with spiffy or rpc this simply returns the return data to be returned
;;
(define (server:reply return-addr query-sig success/fail result)
- (debug:print-info 11 "server:reply return-addr=" return-addr ", result=" result)
- ;; (send-message pubsock target send-more: #t)
- ;; (send-message pubsock
- (case *transport-type*
- ((fs) result)
- ((http)(db:obj->string (vector success/fail query-sig result)))
- ((zmq)
- (let ((pub-socket (vector-ref *runremote* 1)))
- (send-message pub-socket return-addr send-more: #t)
- (send-message pub-socket (db:obj->string (vector success/fail query-sig result)))))
- (else
- (debug:print 0 "ERROR: unrecognised transport type: " *transport-type*)
- result)))
-
-(define (server:ensure-running)
- (let loop ((servers (open-run-close tasks:get-best-server tasks:open-db))
- (trycount 0))
- (if (or (not servers)
- (null? servers))
- (begin
- (if (even? trycount) ;; just do the server start every other time through this loop (every 8 seconds)
- (let ((cmdln (conc (if (getenv "MT_MEGATEST") (getenv "MT_MEGATEST") "megatest")
- " -server - -daemonize")))
- (debug:print 0 "INFO: Starting server (" cmdln ") as none running ...")
- ;; (server:launch (string->symbol (args:get-arg "-transport" "http"))))
- ;; no need to use fork, no need to do the list-servers trick. Just start the damn server, it will exit on it's own
- ;; if there is an existing server
- (system cmdln)
- (thread-sleep! 3)
- ;; (process-run (car (argv)) (list "-server" "-" "-daemonize" "-transport" (args:get-arg "-transport" "http")))
- )
- (begin
- (debug:print-info 0 "Waiting for server to start")
- (thread-sleep! 4)))
- (if (< trycount 10)
- (loop (open-run-close tasks:get-best-server tasks:open-db)
- (+ trycount 1))
- (debug:print 0 "WARNING: Couldn't start or find a server.")))
- (debug:print 2 "INFO: Server(s) running " servers)
- )))
+ (db:obj->string (vector success/fail query-sig result)))
+
+;; Given a run id start a server process ### NOTE ### > file 2>&1
+;; if the run-id is zero and the target-host is set
+;; try running on that host
+;;
+(define (server:run run-id)
+ (let* ((curr-host (get-host-name))
+ (curr-ip (server:get-best-guess-address curr-host))
+ (target-host (configf:lookup *configdat* "server" "homehost" ))
+ (logfile (conc *toppath* "/logs/" run-id ".log"))
+ (cmdln (conc (common:get-megatest-exe)
+ " -server " (or target-host "-") " -run-id " run-id " >> " logfile " 2>&1 &")))
+ (debug:print 0 "INFO: Starting server (" cmdln ") as none running ...")
+ (push-directory *toppath*)
+ (if (not (directory-exists? "logs"))(create-directory "logs"))
+ ;; host.domain.tld match host?
+ (if (and target-host
+ ;; look at target host, is it host.domain.tld or ip address and does it
+ ;; match current ip or hostname
+ (not (string-match (conc "("curr-host "|" curr-host"\\..*)") target-host))
+ (not (equal? curr-ip target-host)))
+ (begin
+ (debug:print-info 0 "Starting server on " target-host ", logfile is " logfile)
+ (setenv "TARGETHOST" target-host)
+ (setenv "TARGETHOST_LOGF" logfile)
+ (system (conc "nbfake " cmdln)))
+ (system cmdln))
+ (pop-directory)))
+
+;; kind start up of servers, wait 40 seconds before allowing another server for a given
+;; run-id to be launched
+(define (server:kind-run run-id)
+ (let ((last-run-time (hash-table-ref/default *server-kind-run* run-id #f)))
+ (if (or (not last-run-time)
+ (> (- (current-seconds) last-run-time) 40))
+ (begin
+ (server:run run-id)
+ (hash-table-set! *server-kind-run* run-id (current-seconds))))))
+
+;; The generic run a server command. Dispatches the call to server 0 if run-id != 0
+;;
+(define (server:try-running run-id)
+ (if (eq? run-id 0)
+ (server:run run-id)
+ (rmt:start-server run-id)))
+
+(define (server:check-if-running run-id)
+ (let loop ((server (open-run-close tasks:get-server tasks:open-db run-id))
+ (trycount 0))
+ (if server
+ ;; note: client:start will set *runremote*. this needs to be changed
+ ;; also, client:start will login to the server, also need to change that.
+ ;;
+ ;; client:start returns #t if login was successful.
+ ;;
+ (let ((res (server:ping-server run-id
+ (tasks:hostinfo-get-interface server)
+ (tasks:hostinfo-get-port server))))
+ ;; if the server didn't respond we must remove the record
+ (if res
+ #t
+ (begin
+ (debug:print-info 0 "server at " server " not responding, removing record")
+ (open-run-close tasks:server-force-clean-running-records-for-run-id tasks:open-db run-id
+ " server:check-if-running")
+ res)))
+ #f)))
+
+;; called in megatest.scm, host-port is string hostname:port
+;;
+(define (server:ping run-id host:port)
+ (let* ((host-port (let ((slst (string-split host:port ":")))
+ (if (eq? (length slst) 2)
+ (list (car slst)(string->number (cadr slst)))
+ #f)))
+ (toppath (setup-for-run))
+ (server-db-dat (if (not host-port)(open-run-close tasks:get-server tasks:open-db run-id) #f)))
+ (if (not run-id)
+ (begin
+ (debug:print 0 "ERROR: must specify run-id when doing ping, -run-id n")
+ (print "ERROR: No run-id")
+ (exit 1))
+ (if (and (not host-port)
+ (not server-db-dat))
+ (begin
+ (print "ERROR: bad host:port")
+ (exit 1))
+ (let* ((iface (if host-port (car host-port) (tasks:hostinfo-get-interface server-db-dat)))
+ (port (if host-port (cadr host-port)(tasks:hostinfo-get-port server-db-dat)))
+ (server-dat (http-transport:client-connect iface port))
+ (login-res (rmt:login-no-auto-client-setup server-dat run-id)))
+ (if (and (list? login-res)
+ (car login-res))
+ (begin
+ (print "LOGIN_OK")
+ (exit 0))
+ (begin
+ (print "LOGIN_FAILED")
+ (exit 1))))))))
+
+;; run ping in separate process, safest way in some cases
+;;
+(define (server:ping-server run-id iface port)
+ (with-input-from-pipe
+ (conc (common:get-megatest-exe) " -run-id " run-id " -ping " (conc iface ":" port))
+ (lambda ()
+ (let loop ((inl (read-line))
+ (res "NOREPLY"))
+ (if (eof-object? inl)
+ (case (string->symbol res)
+ ((NOREPLY) #f)
+ ((LOGIN_OK) #t)
+ (else #f))
+ (loop (read-line) inl))))))
Index: tasks.scm
==================================================================
--- tasks.scm
+++ tasks.scm
@@ -21,11 +21,12 @@
;;======================================================================
;; Tasks db
;;======================================================================
(define (tasks:open-db)
- (let* ((dbpath (conc *toppath* "/monitor.db"))
+ (let* ((linktree (configf:lookup *configdat* "setup" "linktree"))
+ (dbpath (conc linktree "/.db/monitor.db"))
(exists (file-exists? dbpath))
(write-access (file-write-access? dbpath))
(mdb (sqlite3:open-database dbpath)) ;; (never-give-up-open-db dbpath))
(handler (make-busy-timeout 36000)))
(if (and exists
@@ -39,12 +40,11 @@
action TEXT DEFAULT '',
owner TEXT,
state TEXT DEFAULT 'new',
target TEXT DEFAULT '',
name TEXT DEFAULT '',
- test TEXT DEFAULT '',
- item TEXT DEFAULT '',
+ testpatt TEXT DEFAULT '',
keylock TEXT,
params TEXT,
creation_time TIMESTAMP,
execution_time TIMESTAMP);")
(sqlite3:execute mdb "CREATE TABLE IF NOT EXISTS monitors (id INTEGER PRIMARY KEY,
@@ -64,11 +64,12 @@
priority INTEGER,
state TEXT,
mt_version TEXT,
heartbeat TIMESTAMP,
transport TEXT,
- CONSTRAINT servers_constraint UNIQUE (pid,hostname,port));")
+ run_id INTEGER);")
+;; CONSTRAINT servers_constraint UNIQUE (pid,hostname,port));")
(sqlite3:execute mdb "CREATE TABLE IF NOT EXISTS clients (id INTEGER PRIMARY KEY,
server_id INTEGER,
pid INTEGER,
hostname TEXT,
cmdline TEXT,
@@ -90,172 +91,172 @@
(define (tasks:hostinfo-get-pubport vec) (vector-ref vec 3))
(define (tasks:hostinfo-get-transport vec) (vector-ref vec 4))
(define (tasks:hostinfo-get-pid vec) (vector-ref vec 5))
(define (tasks:hostinfo-get-hostname vec) (vector-ref vec 6))
-;; state: 'live, 'shutting-down, 'dead
-(define (tasks:server-register mdb pid interface port priority state transport #!key (pubport -1))
- (debug:print-info 11 "tasks:server-register " pid " " interface " " port " " priority " " state)
+(define (tasks:server-lock-slot mdb run-id)
+ (tasks:server-clean-out-old-records-for-run-id mdb run-id " tasks:server-lock-slot")
+ (if (< (tasks:num-in-available-state mdb run-id) 4)
+ (begin
+ (tasks:server-set-available mdb run-id)
+ (thread-sleep! 2) ;; Try removing this. It may not be needed.
+ (tasks:server-am-i-the-server? mdb run-id))
+ #f))
+
+;; register that this server may come online (first to register goes though with the process)
+(define (tasks:server-set-available mdb run-id)
(sqlite3:execute
mdb
- "INSERT OR REPLACE INTO servers (pid,hostname,port,pubport,start_time,priority,state,mt_version,heartbeat,interface,transport)
- VALUES(?, ?, ?, ?, strftime('%s','now'), ?, ?, ?, strftime('%s','now'),?,?);"
- pid (get-host-name) port pubport priority (conc state)
- (common:version-signature)
- interface
- (conc transport))
- (vector
- (tasks:server-get-server-id mdb (get-host-name) interface port pid)
- interface
- port
- pubport
- transport
+ "INSERT INTO servers (pid,hostname,port,pubport,start_time, priority,state,mt_version,heartbeat, interface,transport,run_id)
+ VALUES(?, ?, ?, ?, strftime('%s','now'), ?, ?, ?,-1,?, ?, ?);"
+ (current-process-id) ;; pid
+ (get-host-name) ;; hostname
+ -1 ;; port
+ -1 ;; pubport
+ (random 1000) ;; priority (used a tiebreaker on get-available)
+ "available" ;; state
+ (common:version-signature) ;; mt_version
+ -1 ;; interface
+ "http" ;; transport
+ run-id
))
-;; NB// two servers with same pid on different hosts will be removed from the list if pid: is used!
-(define (tasks:server-deregister mdb hostname #!key (port #f)(pid #f)(action 'delete))
- (debug:print-info 11 "server-deregister " hostname ", port " port ", pid " pid)
- (if *db-write-access*
- (if pid
- (case action
- ((delete)(sqlite3:execute mdb "DELETE FROM servers WHERE pid=?;" pid))
- (else (sqlite3:execute mdb "UPDATE servers SET state='dead' WHERE pid=?;" pid)))
- (if port
- (case action
- ((delete)(sqlite3:execute mdb "DELETE FROM servers WHERE (interface=? or hostname=?) AND port=?;" hostname hostname port))
- (else (sqlite3:execute mdb "UPDATE servers SET state='dead' WHERE (interface=? or hostname=?) AND port=?;" hostname hostname port)))
- (debug:print 0 "ERROR: tasks:server-deregister called with neither pid nor port specified")))))
-
-(define (tasks:server-deregister-self mdb hostname)
- (tasks:server-deregister mdb hostname pid: (current-process-id)))
-
-;; need a simple call for robustly removing records given host and port
-(define (tasks:server-delete mdb hostname port)
- (tasks:server-deregister mdb hostname port: port action: 'delete))
-
-(define (tasks:server-get-server-id mdb hostname iface port pid)
- (debug:print-info 12 "tasks:server-get-server-id " mdb " " hostname " " iface " " port " " pid)
- (let ((res #f))
+(define (tasks:num-in-available-state mdb run-id)
+ (let ((res 0))
(sqlite3:for-each-row
- (lambda (id)
- (set! res id))
+ (lambda (num-in-queue)
+ (set! res num-in-queue))
mdb
- (cond
- ((and hostname pid) "SELECT id FROM servers WHERE hostname=? AND pid=?;")
- ((and iface port) "SELECT id FROM servers WHERE interface=? AND port=?;")
- ((and hostname port) "SELECT id FROM servers WHERE hostname=? AND port=?;")
- (else
- (begin
- (debug:print 0 "ERROR: tasks:server-get-server-id needs (hostname and pid) OR (iface and port) OR (hostname and port)")
- "SELECT id FROM servers WHERE pid=-999;")))
- (if hostname hostname iface)(if pid pid port))
+ "SELECT count(id) FROM servers WHERE run_id=? AND state = 'available';"
+ run-id)
res))
-(define (tasks:server-update-heartbeat mdb server-id)
- (debug:print-info 1 "Heart beat update of server id=" server-id)
- (handle-exceptions
- exn
- (begin
- (debug:print 0 "WARNING: probable timeout on monitor.db access")
- (thread-sleep! 1)
- (tasks:server-update-heartbeat mdb server-id))
- (sqlite3:execute mdb "UPDATE servers SET heartbeat=strftime('%s','now') WHERE id=?;" server-id)))
-
-;; alive servers keep the heartbeat field upto date with seconds every 6 or so seconds
-(define (tasks:server-alive? mdb server-id #!key (iface #f)(hostname #f)(port #f)(pid #f))
- (let* ((server-id (if server-id
- server-id
- (tasks:server-get-server-id mdb hostname iface port pid)))
- (heartbeat-delta 99e9))
- (sqlite3:for-each-row
- (lambda (delta)
- (set! heartbeat-delta delta))
- mdb "SELECT strftime('%s','now')-heartbeat FROM servers WHERE id=?;" server-id)
- (< heartbeat-delta 10)))
-
-(define (tasks:client-register mdb pid hostname cmdline)
- (sqlite3:execute
- mdb
- "INSERT OR REPLACE INTO clients (server_id,pid,hostname,cmdline,login_time) VALUES(?,?,?,?,strftime('%s','now'));")
- (tasks:server-get-server-id mdb hostname #f #f pid)
- pid hostname cmdline)
-
-(define (tasks:client-logout mdb pid hostname cmdline)
- (sqlite3:execute
- mdb
- "UPDATE clients SET logout_time=strftime('%s','now') WHERE pid=? AND hostname=? AND cmdline=?;"
- pid hostname cmdline))
-
-(define (tasks:get-logged-in-clients mdb server-id)
- (let ((res '()))
- (sqlite3:for-each-row
- (lambda (id server-id pid hostname cmdline login-time logout-time)
- (set! res (cons (vector id server-id pid hostname cmdline login-time lougout-time) res)))
- mdb
- "SELECT id,server_id,pid,hostname,cmdline,login_time,logout_time FROM clients WHERE server_id=?;"
- server-id)))
-
-(define (tasks:have-clients? mdb server-id)
- (null? (tasks:get-logged-in-clients mdb server-id)))
-
-;; ping each server in the db and return first found that responds.
-;; remove any others. will not necessarily remove all!
-(define (tasks:get-best-server mdb)
- (let ((res '())
- (best #f)
- (transport (if (and *transport-type*
- (not (eq? *transport-type* 'fs)))
- (conc *transport-type*)
- "%")))
+(define (tasks:server-clean-out-old-records-for-run-id mdb run-id tag)
+ (sqlite3:execute mdb "UPDATE servers SET state=?,heartbeat=strftime('%s','now') WHERE state in ('available','shutting-down') AND (strftime('%s','now') - start_time) > 50 AND run_id=?;"
+ (conc "defunct" tag) run-id))
+
+(define (tasks:server-force-clean-running-records-for-run-id mdb run-id tag)
+ (sqlite3:execute mdb "UPDATE servers SET state=?,heartbeat=strftime('%s','now') WHERE state = 'running' AND run_id=?;"
+ (conc "defunct" tag) run-id))
+
+(define (tasks:server-force-clean-run-record mdb run-id iface port tag)
+ (sqlite3:execute mdb "UPDATE servers SET state=?,heartbeat=strftime('%s','now') WHERE state = 'running' AND run_id=? AND interface=? AND port=?;"
+ (conc "defunct" tag) run-id iface port))
+
+(define (tasks:server-delete-records-for-this-pid mdb tag)
+ (sqlite3:execute mdb "UPDATE servers SET state=?,heartbeat=strftime('%s','now') WHERE hostname=? AND pid=?;"
+ (conc "defunct" tag) (get-host-name) (current-process-id)))
+
+(define (tasks:server-delete-record mdb server-id tag)
+ (sqlite3:execute mdb "UPDATE servers SET state=?,heartbeat=strftime('%s','now') WHERE id=?;"
+ (conc "defunct" tag) server-id)
+ ;; use this opportuntity to clean out records over one month old or over 10 minutes old with port = -1 (i.e. a never used placeholder)
+ (sqlite3:execute mdb "DELETE FROM servers WHERE state not in ('running','shutting-down') AND (strftime('%s','now') - start_time) > 2628000;")
+ (sqlite3:execute mdb "DELETE FROM servers WHERE state like 'defunct%' AND port=-1 AND (strftime('%s','now') - start_time) > 600;")
+ )
+
+(define (tasks:server-set-state! mdb server-id state)
+ (sqlite3:execute mdb "UPDATE servers SET state=?,heartbeat=strftime('%s','now') WHERE id=?;" state server-id))
+
+(define (tasks:server-set-interface-port mdb server-id interface port)
+ (sqlite3:execute mdb "UPDATE servers SET interface=?,port=?,heartbeat=strftime('%s','now') WHERE id=?;" interface port server-id))
+
+;; Get random port not used in long time
+;;
+(define (tasks:server-get-next-port mdb)
+ (let* ((lownum 30000)
+ (highnum 64000)
+ (used-ports '())
+ (get-rand-port (lambda ()
+ (+ lownum (random (- highnum lownum)))))
+ (port-param (if (and (args:get-arg "-port")
+ (string->number (args:get-arg "-port")))
+ (string->number (args:get-arg "-port"))
+ #f))
+ ;; (config-port (if (and (config-lookup *configdat* "server" "port")
+ ;; (string->number (config-lookup *configdat* "server" "port")))
+ ;; (string->number (config-lookup *configdat* "server" "port"))
+ ;; #f))
+ )
+ (sqlite3:for-each-row
+ (lambda (port)
+ (set! used-ports (cons port used-ports)))
+ mdb
+ "SELECT port FROM servers;")
+ (cond
+ ((and port-param res) (if (> res port-param) res port-param))
+ (port-param port-param)
+ ;; ((and config-port res) (if (> res config-port) res config-port))
+ ;; (config-port config-port)
+ (else
+ (let loop ((port (get-rand-port))
+ (remtries 100))
+ (if (member port used-ports)
+ (if (> remtries 0)
+ (loop (get-rand-port)(- remtries 1))
+ (get-rand-port))
+ port))))))
+
+(define (tasks:server-am-i-the-server? mdb run-id)
+ (let* ((all (tasks:server-get-servers-vying-for-run-id mdb run-id))
+ (first (if (null? all)
+ (begin (debug:print 0 "ERROR: no servers listed, should be at least one by now.")
+ (sqlite3:finalize! mdb)
+ (exit 1))
+ (car (db:get-rows all))))
+ (header (db:get-header all))
+ (id (db:get-value-by-header first header "id"))
+ (hostname (db:get-value-by-header first header "hostname"))
+ (pid (db:get-value-by-header first header "pid"))
+ (priority (db:get-value-by-header first header "priority")))
+ (debug:print 0 "INFO: am-i-the-server got record " first)
+ ;; for now a basic check. add tiebreaking by priority later
+ (if (and (equal? hostname (get-host-name))
+ (equal? pid (current-process-id)))
+ id
+ #f)))
+
+;; Use: (db:get-value-by-header (car (db:get-rows dat)) (db:get-header dat) "fieldname")
+;; to extract info from the structure returned
+;;
+(define (tasks:server-get-servers-vying-for-run-id mdb run-id)
+ (let* ((header (list "id" "hostname" "pid" "interface" "port" "pubport" "state" "run_id" "priority" "start_time"))
+ (selstr (string-intersperse header ","))
+ (res '()))
+ (sqlite3:for-each-row
+ (lambda (a . b)
+ (set! res (cons (apply vector a b) res)))
+ mdb
+ (conc "SELECT " selstr " FROM servers WHERE run_id=? AND state in ('available','running') ORDER BY start_time DESC;")
+ run-id)
+ (vector header res)))
+
+(define (tasks:get-server mdb run-id)
+ (let ((res #f)
+ (best #f))
(sqlite3:for-each-row
(lambda (id interface port pubport transport pid hostname)
- (set! res (cons (vector id interface port pubport transport pid hostname) res))
- ;;(debug:print-info 2 "Found existing server " hostname ":" port " registered in db"))
- )
+ (set! res (vector id interface port pubport transport pid hostname)))
mdb
-
+ ;; removed:
+ ;; strftime('%s','now')-heartbeat < 10 AND mt_version = ?
"SELECT id,interface,port,pubport,transport,pid,hostname FROM servers
- WHERE strftime('%s','now')-heartbeat < 10
- AND mt_version=? AND transport LIKE ?
- ORDER BY start_time DESC LIMIT 1;" (common:version-signature) transport)
- ;; for now we are keeping only one server registered in the db, return #f or first server found
- (if (null? res) #f (car res))))
-
-;; BUG: This logic is probably needed unless methodology changes completely...
-;;
-;; (if (null? res) #f
-;; (let loop ((hed (car res))
-;; (tal (cdr res)))
-;; ;; (print "hed=" hed ", tal=" tal)
-;; (let* ((host (list-ref hed 0))
-;; (iface (list-ref hed 1))
-;; (port (list-ref hed 2))
-;; (pid (list-ref hed 4))
-;; (alive (open-run-close tasks:server-alive? tasks:open-db #f hostname: host port: port)))
-;; (if alive
-;; (begin
-;; (debug:print-info 2 "Found an existing, alive, server " host ", " port ".")
-;; (list host iface port))
-;; (begin
-;; (debug:print-info 1 "Marking " host ":" port " as dead in server registry.")
-;; (if port
-;; (open-run-close tasks:server-deregister tasks:open-db host port: port)
-;; (open-run-close tasks:server-deregister tasks:open-db host pid: pid))
-;; (if (null? tal)
-;; #f
-;; (loop (car tal)(cdr tal))))))))))
-
-(define (tasks:remove-server-records mdb)
- (sqlite3:execute mdb "DELETE FROM servers;"))
-
-(define (tasks:mark-server hostname port pid state transport)
- (if port
- (open-run-close tasks:server-deregister tasks:open-db hostname port: port)
- (open-run-close tasks:server-deregister tasks:open-db hostname pid: pid)))
-
-
-(define (tasks:kill-server status hostname port pid transport)
+ WHERE run_id=? AND state='running'
+ ORDER BY start_time DESC LIMIT 1;" run-id) ;; (common:version-signature) run-id)
+ res))
+
+(define (tasks:get-all-servers mdb)
+ (let ((res '()))
+ (sqlite3:for-each-row
+ (lambda (id pid hostname interface port pubport start-time priority state mt-version last-update transport run-id)
+ ;; 0 1 2 3 4 5 6 7 8 9 10 11 12
+ (set! res (cons (vector id pid hostname interface port pubport start-time priority state mt-version last-update transport run-id) res)))
+ mdb
+ "SELECT id,pid,hostname,interface,port,pubport,start_time,priority,state,mt_version,strftime('%s','now')-heartbeat AS last_update,transport,run_id FROM servers WHERE state NOT LIKE 'defunct%' ORDER BY start_time DESC;")
+ res))
+
+(define (tasks:kill-server status hostname port pid)
(debug:print-info 1 "Removing defunct server record for " hostname ":" port)
(if port
(open-run-close tasks:server-deregister tasks:open-db hostname port: port)
(open-run-close tasks:server-deregister tasks:open-db hostname pid: pid))
(if status ;; #t means alive
@@ -272,13 +273,11 @@
) ;; local machine, send sig term
(begin
;;(debug:print-info 1 "Stopping remote servers not yet supported."))))
(debug:print-info 1 "Telling alive server on " hostname ":" port " to commit servercide")
(let ((serverdat (list hostname port)))
- (case (if (string? transport) (string->symbol transport) transport)
- ((http)(http-transport:client-connect hostname port))
- (else (debug:print "ERROR: remote stopping servers of type " transport " not supported yet")))
+ (hash-table-set! *runremote* run-id (http-transport:client-connect hostname port))
(cdb:kill-server serverdat pid))))) ;; remote machine, try telling server to commit suicide
(begin
(if status
(if (equal? hostname (get-host-name))
(begin
@@ -286,22 +285,10 @@
(process-signal pid signal/term) ;; local machine, send sig term
(thread-sleep! 5) ;; give it five seconds to die peacefully then do a brutal kill
(process-signal pid signal/kill))
(debug:print 0 "WARNING: Can't kill frozen server on remote host " hostname))))))
-
-
-(define (tasks:get-all-servers mdb)
- (let ((res '()))
- (sqlite3:for-each-row
- (lambda (id pid hostname interface port pubport start-time priority state mt-version last-update transport)
- (set! res (cons (vector id pid hostname interface port pubport start-time priority state mt-version last-update transport) res)))
- mdb
- "SELECT id,pid,hostname,interface,port,pubport,start_time,priority,state,mt_version,strftime('%s','now')-heartbeat AS last_update,transport FROM servers ORDER BY start_time DESC;")
- res))
-
-
;;======================================================================
;; Tasks and Task monitors
;;======================================================================
@@ -333,12 +320,12 @@
"SELECT count(id) FROM monitors WHERE last_update < (strftime('%s','now') - 300) AND username=?;"
(car (user-information (current-user-id))))
res))
;; register a task
-(define (tasks:add mdb action owner target runname test item params)
- (sqlite3:execute mdb "INSERT INTO tasks_queue (action,owner,state,target,name,test,item,params,creation_time,execution_time)
+(define (tasks:add mdb action owner target runname testpatt params)
+ (sqlite3:execute mdb "INSERT INTO tasks_queue (action,owner,state,target,name,testpatt,params,creation_time,execution_time)
VALUES (?,?,'new',?,?,?,?,?,strftime('%s','now'),0);"
action
owner
target
runname
@@ -425,11 +412,11 @@
;;
(define (tasks:start-monitor db mdb)
(if (> (tasks:get-num-alive-monitors mdb) 2) ;; have two running, no need for more
(debug:print-info 1 "Not starting monitor, already have more than two running")
(let* ((megatestdb (conc *toppath* "/megatest.db"))
- (monitordbf (conc *toppath* "/monitor.db"))
+ (monitordbf (conc (configf:lookup *configdat* "setup" "linktree") "/.db/monitor.db"))
(last-db-update 0)) ;; (file-modification-time megatestdb)))
(task:register-monitor mdb)
(let loop ((count 0)
(next-touch 0)) ;; next-touch is the time where we need to update last_update
;; if the db has been modified we'd best look at the task queue
ADDED tdb.scm
Index: tdb.scm
==================================================================
--- /dev/null
+++ tdb.scm
@@ -0,0 +1,365 @@
+;;======================================================================
+;; Copyright 2006-2013, Matthew Welland.
+;;
+;; This program is made available under the GNU GPL version 2.0 or
+;; greater. See the accompanying file COPYING for details.
+;;
+;; This program is distributed WITHOUT ANY WARRANTY; without even the
+;; implied warranty of MERCHANTABILITY or FITNESS FOR A PARTICULAR
+;; PURPOSE.
+;;======================================================================
+
+;;======================================================================
+;; Database access
+;;======================================================================
+
+(require-extension (srfi 18) extras tcp)
+(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 tdb))
+(declare (uses common))
+(declare (uses keys))
+(declare (uses ods))
+(declare (uses client))
+(declare (uses mt))
+
+(include "common_records.scm")
+(include "db_records.scm")
+(include "key_records.scm")
+(include "run_records.scm")
+
+;;======================================================================
+;;
+;; T E S T D A T A B A S E S
+;;
+;;======================================================================
+
+;;======================================================================
+;; T E S T S P E C I F I C D B
+;;======================================================================
+
+;; Create the sqlite db for the individual test(s)
+(define (open-test-db work-area)
+ (debug:print-info 11 "open-test-db " work-area)
+ (if (and work-area
+ (directory? work-area)
+ (file-read-access? work-area))
+ (let* ((dbpath (conc work-area "/testdat.db"))
+ (tdb-writeable (file-write-access? dbpath))
+ (dbexists (file-exists? dbpath))
+ (handler (make-busy-timeout (if (args:get-arg "-override-timeout")
+ (string->number (args:get-arg "-override-timeout"))
+ 136000))))
+ (handle-exceptions
+ exn
+ (begin
+ (debug:print 2 "ERROR: problem accessing test db " work-area ", you probably should clean and re-run this test"
+ ((condition-property-accessor 'exn 'message) exn))
+ (set! db (sqlite3:open-database ":memory:")) ;; open an in-memory db to allow readonly access
+ (set! dbexists #f)) ;; must force re-creation of tables, more tom-foolery
+ (set! db (sqlite3:open-database dbpath)))
+ (if *db-write-access* (sqlite3:set-busy-handler! db handler))
+ (if (not dbexists)
+ (begin
+ (sqlite3:execute db "PRAGMA synchronous = FULL;")
+ (debug:print-info 11 "Initialized test database " dbpath)
+ (tdb:testdb-initialize db)))
+ ;; (sqlite3:execute db "PRAGMA synchronous = 0;")
+ (debug:print-info 11 "open-test-db END (sucessful)" work-area)
+ ;; now let's test that everything is correct
+ (handle-exceptions
+ exn
+ (begin
+ (debug:print 0 "ERROR: problem accessing test db " work-area ", you probably should clean and re-run this test"
+ ((condition-property-accessor 'exn 'message) exn))
+ #f)
+ ;; Is there a cheaper single line operation that will check for existance of a table
+ ;; and raise an exception ?
+ (sqlite3:execute db "SELECT id FROM test_data LIMIT 1;"))
+ db)
+ (let ((baddb (sqlite3:open-database ":memory:")))
+ (debug:print-info 11 "open-test-db END (unsucessful)" work-area)
+ ;; provide an in-mem db (this is dangerous!)
+ (tdb:testdb-initialize baddb)
+ baddb)))
+
+;; find and open the testdat.db file for an existing test
+(define (tdb:open-test-db-by-test-id test-id #!key (work-area #f))
+ (let* ((test-path (if work-area
+ work-area
+ (rmt:test-get-rundir-from-test-id test-id))))
+ (debug:print 3 "TEST PATH: " test-path)
+ (open-test-db test-path)))
+
+;; find and open the testdat.db file for an existing test
+(define (tdb:open-test-db-by-test-id-local dbstruct run-id test-id #!key (work-area #f))
+ (let* ((test-path (if work-area
+ work-area
+ (db:test-get-rundir-from-test-id dbstruct run-id test-id))))
+ (debug:print 3 "TEST PATH: " test-path)
+ (open-test-db test-path)))
+
+;; find and open the testdat.db file for an existing test
+(define (tdb:open-run-close-db-by-test-id-local dbstruct run-id test-id work-area proc . params)
+ (let* ((test-path (if work-area
+ work-area
+ (db:test-get-rundir-from-test-id dbstruct run-id test-id)))
+ (tdb (open-test-db test-path)))
+ (apply proc tdb params)))
+
+(define (tdb:testdb-initialize db)
+ (debug:print 11 "db:testdb-initialize START")
+ (for-each
+ (lambda (sqlcmd)
+ (sqlite3:execute db sqlcmd))
+ (list "CREATE TABLE IF NOT EXISTS test_rundat (
+ id INTEGER PRIMARY KEY,
+ update_time TIMESTAMP,
+ cpuload INTEGER DEFAULT -1,
+ diskfree INTEGER DEFAULT -1,
+ diskusage INTGER DEFAULT -1,
+ run_duration INTEGER DEFAULT 0);"
+ "CREATE TABLE IF NOT EXISTS test_data (
+ id INTEGER PRIMARY KEY,
+ test_id INTEGER,
+ category TEXT DEFAULT '',
+ variable TEXT,
+ value REAL,
+ expected REAL,
+ tol REAL,
+ units TEXT,
+ comment TEXT DEFAULT '',
+ status TEXT DEFAULT 'n/a',
+ type TEXT DEFAULT '',
+ CONSTRAINT test_data_constraint UNIQUE (test_id,category,variable));"
+ "CREATE TABLE IF NOT EXISTS test_steps (
+ id INTEGER PRIMARY KEY,
+ test_id INTEGER,
+ stepname TEXT,
+ state TEXT DEFAULT 'NOT_STARTED',
+ status TEXT DEFAULT 'n/a',
+ event_time TIMESTAMP,
+ comment TEXT DEFAULT '',
+ logfile TEXT DEFAULT '',
+ CONSTRAINT test_steps_constraint UNIQUE (test_id,stepname,state));"
+ ;; test_meta can be used for handing commands to the test
+ ;; e.g. KILLREQ
+ ;; the ackstate is set to 1 once the command has been completed
+ "CREATE TABLE IF NOT EXISTS test_meta (
+ id INTEGER PRIMARY KEY,
+ var TEXT,
+ val TEXT,
+ ackstate INTEGER DEFAULT 0,
+ CONSTRAINT metadat_constraint UNIQUE (var));"))
+ (debug:print 11 "db:testdb-initialize END"))
+
+(define (tdb:read-test-data tdb test-id categorypatt)
+ (let ((res '()))
+ (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)))
+ tdb
+ "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)
+ (sqlite3:finalize! tdb)
+ (reverse res)))
+
+;;======================================================================
+;; T E S T D A T A
+;;======================================================================
+
+;; ;; get a list of test_data records matching categorypatt
+;; (define (tdb:read-test-data test-id categorypatt #!key (work-area #f))
+;; (let ((tdb (tdb:open-test-db-by-test-id test-id work-area: work-area)))
+;; (if (sqlite3:database? tdb)
+;; (let ((res '()))
+;; (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)))
+;; tdb
+;; "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)
+;; (sqlite3:finalize! tdb)
+;; (reverse res))
+;; '())))
+
+;; NOTE: Run this local with #f for db !!!
+(define (tdb:load-test-data run-id test-id)
+ (let loop ((lin (read-line)))
+ (if (not (eof-object? lin))
+ (begin
+ (debug:print 4 lin)
+ (rmt:csv->test-data run-id test-id lin)
+ (loop (read-line)))))
+ ;; roll up the current results.
+ ;; FIXME: Add the status too
+ (rmt:test-data-rollup run-id test-id #f))
+
+(define (tdb:get-prev-tol-for-test tdb test-id category variable)
+ ;; Finish me?
+ (values #f #f #f))
+
+;;======================================================================
+;; S T E P S
+;;======================================================================
+
+(define (tdb:step-get-time-as-string vec)
+ (seconds->time-string (tdb:step-get-event_time vec)))
+
+;; get a pretty table to summarize steps
+;;
+(define (tdb:get-steps-table steps);; organise the steps for better readability
+ (let ((res (make-hash-table)))
+ (for-each
+ (lambda (step)
+ (debug:print 6 "step=" step)
+ (let ((record (hash-table-ref/default
+ res
+ (tdb:step-get-stepname step)
+ ;; stepname start end status Duration Logfile
+ (vector (tdb:step-get-stepname step) "" "" "" "" ""))))
+ (debug:print 6 "record(before) = " record
+ "\nid: " (tdb:step-get-id step)
+ "\nstepname: " (tdb:step-get-stepname step)
+ "\nstate: " (tdb:step-get-state step)
+ "\nstatus: " (tdb:step-get-status step)
+ "\ntime: " (tdb:step-get-event_time step))
+ (case (string->symbol (tdb:step-get-state step))
+ ((start)(vector-set! record 1 (tdb:step-get-event_time step))
+ (vector-set! record 3 (if (equal? (vector-ref record 3) "")
+ (tdb:step-get-status step)))
+ (if (> (string-length (tdb:step-get-logfile step))
+ 0)
+ (vector-set! record 5 (tdb:step-get-logfile step))))
+ ((end)
+ (vector-set! record 2 (any->number (tdb:step-get-event_time step)))
+ (vector-set! record 3 (tdb:step-get-status step))
+ (vector-set! record 4 (let ((startt (any->number (vector-ref record 1)))
+ (endt (any->number (vector-ref record 2))))
+ (debug:print 4 "record[1]=" (vector-ref record 1)
+ ", startt=" startt ", endt=" endt
+ ", get-status: " (tdb:step-get-status step))
+ (if (and (number? startt)(number? endt))
+ (seconds->hr-min-sec (- endt startt)) "-1")))
+ (if (> (string-length (tdb:step-get-logfile step))
+ 0)
+ (vector-set! record 5 (tdb:step-get-logfile step))))
+ (else
+ (vector-set! record 2 (tdb:step-get-state step))
+ (vector-set! record 3 (tdb:step-get-status step))
+ (vector-set! record 4 (tdb:step-get-event_time step))))
+ (hash-table-set! res (tdb:step-get-stepname step) record)
+ (debug:print 6 "record(after) = " record
+ "\nid: " (tdb:step-get-id step)
+ "\nstepname: " (tdb:step-get-stepname step)
+ "\nstate: " (tdb:step-get-state step)
+ "\nstatus: " (tdb:step-get-status step)
+ "\ntime: " (tdb:step-get-event_time step))))
+ ;; (else (vector-set! record 1 (tdb:step-get-event_time step)))
+ (sort steps (lambda (a b)
+ (cond
+ ((< (tdb:step-get-event_time a)(tdb:step-get-event_time b)) #t)
+ ((eq? (tdb:step-get-event_time a)(tdb:step-get-event_time b))
+ (< (tdb:step-get-id a) (tdb:step-get-id b)))
+ (else #f)))))
+ res))
+
+;; Move this to steps.scm
+;;
+;; get a pretty table to summarize steps
+;;
+(define (tdb:get-steps-table-list steps)
+ ;; organise the steps for better readability
+ (let ((res (make-hash-table)))
+ (for-each
+ (lambda (step)
+ (debug:print 6 "step=" step)
+ (let ((record (hash-table-ref/default
+ res
+ (tdb:step-get-stepname step)
+ ;; stepname start end status
+ (vector (tdb:step-get-stepname step) "" "" "" "" ""))))
+ (debug:print 6 "record(before) = " record
+ "\nid: " (tdb:step-get-id step)
+ "\nstepname: " (tdb:step-get-stepname step)
+ "\nstate: " (tdb:step-get-state step)
+ "\nstatus: " (tdb:step-get-status step)
+ "\ntime: " (tdb:step-get-event_time step))
+ (case (string->symbol (tdb:step-get-state step))
+ ((start)(vector-set! record 1 (tdb:step-get-event_time step))
+ (vector-set! record 3 (if (equal? (vector-ref record 3) "")
+ (tdb:step-get-status step)))
+ (if (> (string-length (tdb:step-get-logfile step))
+ 0)
+ (vector-set! record 5 (tdb:step-get-logfile step))))
+ ((end)
+ (vector-set! record 2 (any->number (tdb:step-get-event_time step)))
+ (vector-set! record 3 (tdb:step-get-status step))
+ (vector-set! record 4 (let ((startt (any->number (vector-ref record 1)))
+ (endt (any->number (vector-ref record 2))))
+ (debug:print 4 "record[1]=" (vector-ref record 1)
+ ", startt=" startt ", endt=" endt
+ ", get-status: " (tdb:step-get-status step))
+ (if (and (number? startt)(number? endt))
+ (seconds->hr-min-sec (- endt startt)) "-1")))
+ (if (> (string-length (tdb:step-get-logfile step))
+ 0)
+ (vector-set! record 5 (tdb:step-get-logfile step))))
+ (else
+ (vector-set! record 2 (tdb:step-get-state step))
+ (vector-set! record 3 (tdb:step-get-status step))
+ (vector-set! record 4 (tdb:step-get-event_time step))))
+ (hash-table-set! res (tdb:step-get-stepname step) record)
+ (debug:print 6 "record(after) = " record
+ "\nid: " (tdb:step-get-id step)
+ "\nstepname: " (tdb:step-get-stepname step)
+ "\nstate: " (tdb:step-get-state step)
+ "\nstatus: " (tdb:step-get-status step)
+ "\ntime: " (tdb:step-get-event_time step))))
+ ;; (else (vector-set! record 1 (tdb:step-get-event_time step)))
+ (sort steps (lambda (a b)
+ (cond
+ ((< (tdb:step-get-event_time a)(tdb:step-get-event_time b)) #t)
+ ((eq? (tdb:step-get-event_time a)(tdb:step-get-event_time b))
+ (< (tdb:step-get-id a) (tdb:step-get-id b)))
+ (else #f)))))
+ res))
+
+;;
+;; Move to steps.scm
+;;
+(define (tdb:get-compressed-steps comprsteps) ;; from tdb:get-steps-table
+ (map (lambda (x)
+ ;; take advantage of the \n on time->string
+ (vector
+ (vector-ref x 0)
+ (let ((s (vector-ref x 1)))
+ (if (number? s)(seconds->time-string s) s))
+ (let ((s (vector-ref x 2)))
+ (if (number? s)(seconds->time-string s) s))
+ (vector-ref x 3) ;; status
+ (vector-ref x 4)
+ (vector-ref x 5))) ;; time delta
+ (sort (hash-table-values comprsteps)
+ (lambda (a b)
+ (let ((time-a (vector-ref a 1))
+ (time-b (vector-ref b 1)))
+ (if (and (number? time-a)(number? time-b))
+ (if (< time-a time-b)
+ #t
+ (if (eq? time-a time-b)
+ (string<? (conc (vector-ref a 2))
+ (conc (vector-ref b 2)))
+ #f))
+ (string<? (conc time-a)(conc time-b))))))))
+
+;;
+(define (tdb:remote-update-testdat-meta-info run-id test-id work-area cpuload diskfree minutes)
+ (let ((tdb (rmt:open-test-db-by-test-id run-id test-id work-area: work-area)))
+ (if (sqlite3:database? tdb)
+ (begin
+ (sqlite3:execute tdb "INSERT INTO test_rundat (update_time,cpuload,diskfree,run_duration) VALUES (strftime('%s','now'),?,?,?);"
+ cpuload diskfree minutes)
+ (sqlite3:finalize! tdb))
+ (debug:print 2 "Can't update testdat.db for test " test-id " read-only or non-existant"))))
+
Index: tests.scm
==================================================================
--- tests.scm
+++ tests.scm
@@ -17,13 +17,15 @@
(import (prefix sqlite3 sqlite3:))
(declare (unit tests))
(declare (uses lock-queue))
(declare (uses db))
+(declare (uses tdb))
(declare (uses common))
(declare (uses items))
(declare (uses runconfig))
+;; (declare (uses sdb))
(include "common_records.scm")
(include "key_records.scm")
(include "db_records.scm")
(include "run_records.scm")
@@ -127,106 +129,19 @@
(if (null? tal)
(string-intersperse (append (reverse res)(list qry)) " OR ")
(loop (car tal)(cdr tal)(cons qry res)))))))
#f))
-;; get the previous record for when this test was run where all keys match but runname
-;; returns #f if no such test found, returns a single test record if found
-;;
-;; Run this server-side
-;;
-(define (test:get-previous-test-run-record db run-id test-name item-path)
- (let* ((keys (db:get-keys db))
- (selstr (string-intersperse keys ","))
- (qrystr (string-intersperse (map (lambda (x)(conc x "=?")) keys) " AND "))
- (keyvals #f))
- ;; first look up the key values from the run selected by run-id
- (sqlite3:for-each-row
- (lambda (a . b)
- (set! keyvals (cons a b)))
- db
- (conc "SELECT " selstr " FROM runs WHERE id=? ORDER BY event_time DESC;") run-id)
- (if (not keyvals)
- #f
- (let ((prev-run-ids '()))
- (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)))
- ;; for each run starting with the most recent look to see if there is a matching test
- ;; if found then return that matching test record
- (debug:print 4 "selstr: " selstr ", qrystr: " qrystr ", keyvals: " keyvals ", previous run ids found: " prev-run-ids)
- (if (null? prev-run-ids) #f
- (let loop ((hed (car prev-run-ids))
- (tal (cdr prev-run-ids)))
- (let ((results (db:get-tests-for-run db hed (conc test-name "/" item-path)'() '() #f #f #f #f #f)))
- (debug:print 4 "Got tests for run-id " run-id ", test-name " test-name ", item-path " item-path ": " results)
- (if (and (null? results)
- (not (null? tal)))
- (loop (car tal)(cdr tal))
- (if (null? results) #f
- (car results))))))))))
-
-;; get the previous records for when these tests were run where all keys match but runname
-;; NB// Merge this with test:get-previous-test-run-records? This one looks for all matching tests
-;; can use wildcards. Also can likely be factored in with get test paths?
-;;
-;; Run this remotely!!
-;;
-(define (test:get-matching-previous-test-run-records db run-id test-name item-path)
- (let* ((keys (db:get-keys db))
- (selstr (string-intersperse (map (lambda (x)(vector-ref x 0)) keys) ","))
- (qrystr (string-intersperse (map (lambda (x)(conc (vector-ref x 0) "=?")) keys) " AND "))
- (keyvals #f)
- (tests-hash (make-hash-table)))
- ;; first look up the key values from the run selected by run-id
- (sqlite3:for-each-row
- (lambda (a . b)
- (set! keyvals (cons a b)))
- db
- (conc "SELECT " selstr " FROM runs WHERE id=? ORDER BY event_time DESC;") run-id)
- (if (not keyvals)
- '()
- (let ((prev-run-ids '()))
- (apply sqlite3:for-each-row
- (lambda (id)
- (set! prev-run-ids (cons id prev-run-ids)))
- db
- (conc "SELECT id FROM runs WHERE " qrystr " AND id != ?;") (append keyvals (list run-id)))
- ;; collect all matching tests for the runs then
- ;; extract the most recent test and return that.
- (debug:print 4 "selstr: " selstr ", qrystr: " qrystr ", keyvals: " keyvals
- ", previous run ids found: " prev-run-ids)
- (if (null? prev-run-ids) '() ;; no previous runs? return null
- (let loop ((hed (car prev-run-ids))
- (tal (cdr prev-run-ids)))
- (let ((results (db:get-tests-for-run db hed (conc test-name "/" item-path) '() '() #f #f #f #f #f)))
- (debug:print 4 "Got tests for run-id " run-id ", test-name " test-name
- ", item-path " item-path " results: " (intersperse results "\n"))
- ;; Keep only the youngest of any test/item combination
- (for-each
- (lambda (testdat)
- (let* ((full-testname (conc (db:test-get-testname testdat) "/" (db:test-get-item-path testdat)))
- (stored-test (hash-table-ref/default tests-hash full-testname #f)))
- (if (or (not stored-test)
- (and stored-test
- (> (db:test-get-event_time testdat)(db:test-get-event_time stored-test))))
- ;; this test is younger, store it in the hash
- (hash-table-set! tests-hash full-testname testdat))))
- results)
- (if (null? tal)
- (map cdr (hash-table->alist tests-hash)) ;; return a list of the most recent tests
- (loop (car tal)(cdr tal))))))))))
-
;; Check for waiver eligibility
;;
(define (tests:check-waiver-eligibility testdat prev-testdat)
(let* ((test-registry (make-hash-table))
(testconfig (tests:get-testconfig (db:test-get-testname testdat) test-registry #f))
- (test-rundir (db:test-get-rundir testdat))
- (prev-rundir (db:test-get-rundir prev-testdat))
+ (test-rundir ;; (sdb:qry 'passstr
+ (db:test-get-rundir testdat)) ;; )
+ (prev-rundir ;; (sdb:qry 'passstr
+ (db:test-get-rundir prev-testdat)) ;; )
(waivers (configf:section-vars testconfig "waivers"))
(waiver-rx (regexp "^(\\S+)\\s+(.*)$"))
(diff-rule "diff %file1% %file2%")
(logpro-rule "diff %file1% %file2% | logpro %waivername%.logpro %waivername%.html"))
(if (not (file-exists? test-rundir))
@@ -278,33 +193,30 @@
(loop (car tal)(cdr tal)))
#f))))))
(pop-directory)
result)))))
-(define (tests:test-force-state-status! test-id state status)
- (cdb:test-set-status-state *runremote* test-id status state #f)
- (mt:process-triggers test-id state status))
+(define (tests:test-force-state-status! run-id test-id state status)
+ (rmt:test-set-status-state run-id test-id status state #f)
+ (mt:process-triggers run-id test-id state status))
;; Do not rpc this one, do the underlying calls!!!
-(define (tests:test-set-status! test-id state status comment dat #!key (work-area #f))
- (debug:print-info 4 "tests:test-set-status! test-id=" test-id ", state=" state ", status=" status ", dat=" dat)
- (let* ((db #f)
- (real-status status)
+(define (tests:test-set-status! run-id test-id state status comment dat #!key (work-area #f))
+ (let* ((real-status status)
(otherdat (if dat dat (make-hash-table)))
- (testdat (cdb:get-test-info-by-id *runremote* test-id))
- (run-id (db:test-get-run_id testdat))
- (test-name (db:test-get-testname testdat))
+ (testdat (rmt:get-test-info-by-id run-id test-id))
+ (test-name (db:test-get-testname testdat))
(item-path (db:test-get-item-path testdat))
;; before proceeding we must find out if the previous test (where all keys matched except runname)
;; was WAIVED if this test is FAIL
;; NOTES:
;; 1. Is the call to test:get-previous-run-record remotified?
;; 2. Add test for testconfig waiver propagation control here
;;
(prev-test (if (equal? status "FAIL")
- (cdb:remote-run test:get-previous-test-run-record #f run-id test-name item-path)
+ (rmt:get-previous-test-run-record run-id test-name item-path)
#f))
(waived (if prev-test
(if prev-test ;; true if we found a previous test in this run series
(let ((prev-status (db:test-get-status prev-test))
(prev-state (db:test-get-state prev-test))
@@ -325,17 +237,17 @@
(debug:print 4 "real-status " real-status ", waived " waived ", status " status)
;; update the primary record IF state AND status are defined
(if (and state status)
(begin
- (cdb:test-set-status-state *runremote* test-id real-status state (if waived waived comment))
- (mt:process-triggers test-id state real-status)))
+ (rmt:test-set-status-state run-id test-id real-status state (if waived waived comment))
+ (mt:process-triggers run-id test-id state real-status)))
;; if status is "AUTO" then call rollup (note, this one modifies data in test
;; run area, it does remote calls under the hood.
(if (and test-id state status (equal? status "AUTO"))
- (db:test-data-rollup #f test-id status work-area: work-area))
+ (rmt:test-data-rollup run-id test-id status))
;; add metadata (need to do this way to avoid SQL injection issues)
;; :first_err
;; (let ((val (hash-table-ref/default otherdat ":first_err" #f)))
@@ -365,62 +277,59 @@
expected ","
tol ","
units ","
dcomment ",," ;; extra comma for status
type )))
- ;; This was run remote, don't think that makes sense.
- (db:csv->test-data #f test-id
+ ;; This was run remote, don't think that makes sense. Perhaps not, but that is the easiest path for the moment.
+ (rmt:csv->test-data run-id test-id
dat))))
;; need to update the top test record if PASS or FAIL and this is a subtest
(if (not (equal? item-path ""))
- (mt:roll-up-pass-fail-counts run-id test-name item-path status))
+ (rmt:roll-up-pass-fail-counts run-id test-name item-path status))
(if (or (and (string? comment)
(string-match (regexp "\\S+") comment))
waived)
(let ((cmt (if waived waived comment)))
- (cdb:remote-run db:test-set-comment #f test-id cmt)))
- ))
-
-
-(define (tests:test-set-toplog! db run-id test-name logf)
- (cdb:client-call *runremote* 'tests:test-set-toplog #t 2 logf run-id test-name))
-
-(define (tests:summarize-items db run-id test-id test-name force)
+ (rmt:general-call 'set-test-comment run-id cmt test-id)))))
+
+(define (tests:test-set-toplog! run-id test-name logf)
+ (rmt:general-call 'tests:test-set-toplog run-id logf run-id test-name))
+
+(define (tests:summarize-items run-id test-id test-name force)
;; if not force then only update the record if one of these is true:
;; 1. logf is "log/final.log
;; 2. logf is same as outputfilename
(let* ((outputfilename (conc "megatest-rollup-" test-name ".html"))
(orig-dir (current-directory))
- (logf-info (cdb:remote-run db:test-get-logfile-info #f run-id test-name))
+ (logf-info (rmt:test-get-logfile-info run-id test-name))
(logf (if logf-info (cadr logf-info) #f))
(path (if logf-info (car logf-info) #f)))
;; This query finds the path and changes the directory to it for the test
(if (and (string? path)
(directory? path)) ;; can get #f here under some wierd conditions. why, unknown ...
(begin
(debug:print 4 "Found path: " path)
(change-directory path))
;; (set! outputfilename (conc path "/" outputfilename)))
- (print "No such path: " path))
+ (debug:print 0 "ERROR: summarize-items for run-id=" run-id ", test-name=" test-name ", no such path: " path))
(debug:print 4 "summarize-items with logf " logf ", outputfilename " outputfilename " and force " force)
(if (or (equal? logf "logs/final.log")
(equal? logf outputfilename)
force)
(begin
- (if ;; (not (obtain-dot-lock outputfilename 1 5 7)) ;; retry every second for 20 seconds, call it dead after 30 seconds and steal the lock
- (not (lock-queue:wait-turn outputfilename test-id))
+ (if (not (lock-queue:wait-turn outputfilename test-id))
(print "Not updating " outputfilename " as another test item has signed up for the job")
(begin
(print "Obtained lock for " outputfilename)
(let ((oup (open-output-file outputfilename))
(counts (make-hash-table))
(statecounts (make-hash-table))
(outtxt "")
(tot 0)
- (testdat (cdb:remote-run db:test-get-records-for-index-file #f run-id test-name)))
+ (testdat (rmt:test-get-records-for-index-file run-id test-name)))
(with-output-to-port
oup
(lambda ()
(set! outtxt (conc outtxt "<html><title>Summary: " test-name
"</title><body><h2>Summary for " test-name "</h2>"))
@@ -467,18 +376,42 @@
(print "</td></td></tr></table>")
(print "<table cellspacing=\"0\" border=\"1\">"
"<tr><td>Item</td><td>State</td><td>Status</td><td>Comment</td>"
outtxt "</table></body></html>")
- (release-dot-lock outputfilename)))
+ ;; (release-dot-lock outputfilename)
+ ))
(close-output-port oup)
(lock-queue:release-lock outputfilename test-id)
(change-directory orig-dir)
;; NB// tests:test-set-toplog! is remote internal...
- (tests:test-set-toplog! db run-id test-name outputfilename)
+ (tests:test-set-toplog! run-id test-name outputfilename)
)))))))
+;; MUST BE CALLED local!
+;;
+(define (tests:test-get-paths-matching keynames target fnamepatt #!key (res '()))
+ ;; BUG: Move the values derived from args to parameters and push to megatest.scm
+ (let* ((testpatt (if (args:get-arg "-testpatt")(args:get-arg "-testpatt") "%"))
+ (statepatt (if (args:get-arg ":state") (args:get-arg ":state") "%"))
+ (statuspatt (if (args:get-arg ":status") (args:get-arg ":status") "%"))
+ (runname (if (args:get-arg ":runname") (args:get-arg ":runname") "%"))
+ (paths-from-db (rmt:test-get-paths-matching-keynames-target-new keynames target res
+ testpatt
+ statepatt
+ statuspatt
+ runname)))
+ (if fnamepatt
+ (apply append
+ (map (lambda (p)
+ (if (directory-exists? p)
+ (glob (conc p "/" fnamepatt))
+ '()))
+ paths-from-db))
+ paths-from-db)))
+
+
;;======================================================================
;; Gather data from test/task specifications
;;======================================================================
;; (define (tests:get-valid-tests testsdir test-patts) ;; #!key (test-names '()))
@@ -555,12 +488,12 @@
(test-name (tests:testqueue-get-testname test-record))
(itemdat (tests:testqueue-get-itemdat test-record))
(item-path (tests:testqueue-get-item_path test-record))
(waitons (tests:testqueue-get-waitons test-record))
(keep-test #t)
- (test-id (cdb:remote-run db:get-test-id-cached #f run-id test-name item-path))
- (tdat (cdb:remote-run db:get-testinfo-state-status #f test-id))) ;; (cdb:get-test-info-by-id *runremote* test-id)))
+ (test-id (rmt:get-test-id run-id test-name item-path))
+ (tdat (rmt:get-testinfo-state-status run-id test-id))) ;; (cdb:get-test-info-by-id *runremote* test-id)))
(if tdat
(begin
;; Look at the test state and status
(if (or (and (member (db:test-get-status tdat)
'("PASS" "WARN" "WAIVED" "CHECK" "SKIP"))
@@ -572,12 +505,12 @@
;; examine waitons for any fails. If it is FAIL or INCOMPLETE then eliminate this test
;; from the runnable list
(if keep-test
(for-each (lambda (waiton)
;; for now we are waiting only on the parent test
- (let* ((parent-test-id (cdb:remote-run db:get-test-id-cached #f run-id waiton ""))
- (wtdat (cdb:remote-run db:get-testinfo-state-status #f test-id))) ;; (cdb:get-test-info-by-id *runremote* test-id)))
+ (let* ((parent-test-id (rmt:get-test-id run-id waiton ""))
+ (wtdat (rmt:get-testinfo-state-status run-id test-id))) ;; (cdb:get-test-info-by-id *runremote* test-id)))
(if (or (and (equal? (db:test-get-state wtdat) "COMPLETED")
(member (db:test-get-status wtdat) '("FAIL")))
(member (db:test-get-status wtdat) '("KILLED"))
(member (db:test-get-state wtdat) '("INCOMPETE")))
;; (if (or (member (db:test-get-status wtdat)
@@ -679,12 +612,12 @@
;; test steps
;;======================================================================
;; teststep-set-status! used to be here
-(define (test-get-kill-request test-id) ;; run-id test-name itemdat)
- (let* ((testdat (cdb:remote-run db:get-testinfo-state-status #f test-id))) ;; (cdb:get-test-info-by-id *runremote* test-id))) ;; run-id test-name item-path)))
+(define (test-get-kill-request run-id test-id) ;; run-id test-name itemdat)
+ (let* ((testdat (rmt:get-test-info-by-id run-id test-id)))
(and testdat
(equal? (test:get-state testdat) "KILLREQ"))))
(define (test:tdb-get-rundat-count tdb)
(if tdb
@@ -695,61 +628,32 @@
tdb
"SELECT count(id) FROM test_rundat;")
res))
0)
-(define (tests:update-central-meta-info test-id cpuload diskfree minutes uname hostname)
- ;; This is a good candidate for threading the requests to enable
- ;; transactionized write at the server
- (cdb:tests-update-cpuload-diskfree *runremote* test-id cpuload diskfree)
+(define (tests:update-central-meta-info run-id test-id cpuload diskfree minutes uname hostname)
+ (rmt:general-call 'update-cpuload-diskfree run-id cpuload diskfree test-id)
(if minutes
- (cdb:tests-update-run-duration *runremote* test-id minutes))
+ (rmt:general-call 'update-run-duration run-id minutes test-id))
(if (and uname hostname)
- (cdb:tests-update-uname-host *runremote* test-id uname hostname)))
+ (rmt:general-call 'update-uname-host run-id uname hostname test-id)))
-(define (tests:set-full-meta-info db test-id run-id minutes work-area)
- ;; DOES cdb:remote-run under the hood!
- (let* ((num-records 0) ;; (test:tdb-get-rundat-count tdb))
+;; This one is for running with no db access (i.e. via rmt: internally)
+(define (tests:set-full-meta-info test-id run-id minutes work-area)
+ (let* ((num-records 0)
(cpuload (get-cpu-load))
(diskfree (get-df (current-directory)))
(uname (get-uname "-srvpio"))
(hostname (get-host-name)))
- (tests:update-testdat-meta-info db test-id work-area cpuload diskfree minutes)
- (tests:update-central-meta-info test-id cpuload diskfree minutes uname hostname)))
+ (tdb:remote-update-testdat-meta-info run-id test-id work-area cpuload diskfree minutes)
+ (tests:update-central-meta-info run-id test-id cpuload diskfree minutes uname hostname)))
-(define (tests:set-partial-meta-info db test-id run-id minutes work-area)
- ;; DOES cdb:remote-run under the hood!
+(define (tests:set-partial-meta-info test-id run-id minutes work-area)
(let* ((cpuload (get-cpu-load))
(diskfree (get-df (current-directory))))
- (tests:update-testdat-meta-info db test-id work-area cpuload diskfree minutes)
- ;; Update central with uname and hostname = #f
- ;; Is this one of the performance problems? This info should come from testdat-meta anyway
- ;; (tests:update-central-meta-info test-id cpuload diskfree minutes #f #f)
- ))
-
-(define (tests:update-testdat-meta-info db test-id work-area cpuload diskfree minutes)
- (let ((tdb (db:open-test-db-by-test-id db test-id work-area: work-area)))
- (if (sqlite3:database? tdb)
- (begin
- (sqlite3:execute tdb "INSERT INTO test_rundat (update_time,cpuload,diskfree,run_duration) VALUES (strftime('%s','now'),?,?,?);"
- cpuload diskfree minutes)
- (sqlite3:finalize! tdb))
- (debug:print 2 "Can't update testdat.db for test " test-id " read-only or non-existant"))))
-
-(define (tests:testdat-get-testinfo db test-id work-area)
- (let ((tdb (db:open-test-db-by-test-id db test-id work-area: work-area))
- (res '()))
- (if (sqlite3:database? tdb)
- (begin
- (sqlite3:for-each-row
- (lambda (update-time cpuload diskfree run-duration)
- (set! res (cons (vector update-time cpuload diskfree run-duration) res)))
- tdb
- "SELECT update_time,cpuload,diskfree,run_duration FROM test_rundat ORDER BY update_time ASC;")
- (sqlite3:finalize! tdb)))
- res))
-
+ (tdb:remote-update-testdat-meta-info run-id test-id work-area cpuload diskfree minutes)))
+
;;======================================================================
;; A R C H I V I N G
;;======================================================================
(define (test:archive db test-id)
Index: tests/Makefile
==================================================================
--- tests/Makefile
+++ tests/Makefile
@@ -1,17 +1,18 @@
#
# run some tests
-BINPATH=$(shell readlink -m $(PWD)/../bin)
-MEGATEST=$(BINPATH)/megatest
-PATH := $(BINPATH):$(PATH)
-RUNNAME := $(shell date +w%V.%u.%H.%M)
-IPADDR := "-"
-# Set SERVER to "-server -"
-SERVER =
-DEBUG = 1
-LOGGING =
+BINPATH = $(shell readlink -m $(PWD)/../bin)
+MEGATEST = $(BINPATH)/megatest
+DASHBOARD = $(BINPATH)/dashboard
+PATH := $(BINPATH):$(PATH)
+RUNNAME := $(shell date +w%V.%u.%H.%M)
+IPADDR := "-"
+RUNID := 1
+SERVER =
+DEBUG = 1
+LOGGING =
OS = $(shell grep ID /etc/*-release|cut -d= -f2)
FS = $(shell df -T .|tail -1|awk '{print $$2}')
VER = $(shell fsl info|grep checkout|awk '{print $$2}'|cut -c 1-5)
@@ -21,11 +22,11 @@
all : test1 test2 test3 test4 test5 test6 test7 test8 test9
server :
cd ..;make;make install
- cd fullrun;../../bin/megatest -server - -debug 22
+ cd fullrun;../../bin/megatest -server - -debug $(DEBUG) -run-id $(RUNID)
stopserver :
cd ..;make && make install
cd fullrun;$(MEGATEST) -stop-server 0
@@ -35,15 +36,10 @@
test0 : cleanprep
cd simplerun ; $(MEGATEST) -server - -debug $(DEBUG)
test1 : cleanprep
- rm -f simplerun/megatest.db
- rm -rf simplelinks/ simpleruns/
- mkdir -p simplelinks simpleruns
- cd simplerun;cp ../../*_records.scm .;perl -pi.bak -e 's/define-inline/define/' *_records.scm
- cd simplerun;echo '(load "../tests.scm")' | $(MEGATEST) -repl -debug $(DEBUG)
test2 : fullprep
cd fullrun;$(MEGATEST) -runtests ez_pass,runfirst/a/% -reqtarg ubuntu/nfs/none :runname $(RUNNAME) -debug $(DEBUG) $(LOGGING)
cd fullrun;megatest -runtests % -target ubuntu/nfs/none :runname $(RUNNAME)_01 -testpatt %/,%/ai -debug $(DEBUG)
cd fullrun;megatest -runtests %/,%/ai -target ubuntu/nfs/none :runname $(RUNAME)_02 -debug $(DEBUG)
@@ -68,15 +64,15 @@
# NOTE: Only one instance can be a server
test5 : cleanprep
@echo "WARNING: No longer running fullprep, test converage may be lessened"
cd fullrun;sleep 0;$(MEGATEST) -runtests % -target $(TARGET) :runname $(RUNNAME)_aa -debug $(DEBUG) $(LOGGING) > aa.log 2> aa.log &
- cd fullrun;sleep 0;$(MEGATEST) -runtests % -target $(TARGET) :runname $(RUNNAME)_ab -debug $(DEBUG) $(LOGGING) > ab.log 2> ab.log &
- cd fullrun;sleep 5;$(MEGATEST) -runtests % -target $(TARGET) :runname $(RUNNAME)_ac -debug $(DEBUG) $(LOGGING) > ac.log 2> ac.log &
- cd fullrun;sleep 8;$(MEGATEST) -runtests % -target $(TARGET) :runname $(RUNNAME)_ad -debug $(DEBUG) $(LOGGING) > ad.log 2> ad.log &
-# cd fullrun;sleep 0;$(MEGATEST) -runtests % -target $(TARGET) :runname $(RUNNAME)_ae -debug $(DEBUG) $(LOGGING) > ae.log 2> ae.log &
-# cd fullrun;sleep 0;$(MEGATEST) -runtests % -target $(TARGET) :runname $(RUNNAME)_af -debug $(DEBUG) $(LOGGING) > af.log 2> af.log & a
+ cd fullrun;sleep 3;$(MEGATEST) -runtests % -target $(TARGET) :runname $(RUNNAME)_ab -debug $(DEBUG) $(LOGGING) > ab.log 2> ab.log &
+ cd fullrun;sleep 6;$(MEGATEST) -runtests % -target $(TARGET) :runname $(RUNNAME)_ac -debug $(DEBUG) $(LOGGING) > ac.log 2> ac.log &
+ cd fullrun;sleep 9;$(MEGATEST) -runtests % -target $(TARGET) :runname $(RUNNAME)_ad -debug $(DEBUG) $(LOGGING) > ad.log 2> ad.log &
+ cd fullrun;sleep 12;$(MEGATEST) -runtests % -target $(TARGET) :runname $(RUNNAME)_ae -debug $(DEBUG) $(LOGGING) > ae.log 2> ae.log &
+ cd fullrun;sleep 15;$(MEGATEST) -runtests % -target $(TARGET) :runname $(RUNNAME)_af -debug $(DEBUG) $(LOGGING) > af.log 2> af.log &
# MUST ADD THIS BACK IN ASAP!!!!
# cd fullrun;sleep 10;$(MEGATEST) -run-wait -target $(TARGET) :runname % -testpatt % :state RUNNING,LAUNCHED,NOT_STARTED,REMOTEHOSTSTART;echo ALL DONE
test6: fullprep
@@ -111,27 +107,27 @@
test9 : minsetup test9a test9b test9c test9d test9e
test9a :
@echo Run super-simple mintest e, no waitons.
- cd mintest;megatest -runtests e -target $(VER) :runname `date +%H.%M.%S` -debug $(DEBUG)
+ cd mintest;$(MEGATEST) -runtests e -target $(VER) :runname `date +%H.%M.%S` -debug $(DEBUG)
test9b :
@echo Run simple mintest d with one waiton c
- cd mintest;megatest -runtests d -target $(VER) :runname `date +%H.%M.%S` -debug $(DEBUG)
+ cd mintest;$(MEGATEST) -runtests d -target $(VER) :runname `date +%H.%M.%S` -debug $(DEBUG)
test9c :
@echo Run mintest a with full waiton chain a -> b -> c -> d -> e
- cd mintest;megatest -runtests a -target $(VER) :runname `date +%H.%M.%S` -debug $(DEBUG)
+ cd mintest;$(MEGATEST) -runtests a -target $(VER) :runname `date +%H.%M.%S` -debug $(DEBUG)
test9d :
@echo Run an itemized test with no items
- cd mintest;megatest -runtests g -target $(VER) :runname `date +%H.%M.%S` -debug $(DEBUG)
+ cd mintest;$(MEGATEST) -runtests g -target $(VER) :runname `date +%H.%M.%S` -debug $(DEBUG)
test9e :
@echo Run mintest a1 with full waiton chain with d1fail: a1 -> b1 -> c1 -> d1fail -> e1
- cd mintest;megatest -runtests a1 -target $(VER) :runname `date +%H.%M.%S` -debug $(DEBUG)
+ cd mintest;$(MEGATEST) -runtests a1 -target $(VER) :runname `date +%H.%M.%S` -debug $(DEBUG)
test10 :
@echo Run a bunch of different targets simultaneously
(cd fullrun;$(MEGATEST) -server - ;sleep 2)&
for targ in mint/btrfs/mintdir sunos/sshfs/loc; do \
@@ -146,14 +142,14 @@
cd fullrun;time (for a in 1 2 3 4 5 6 7 8 9 10 1 2 3 4 5 6 7 8 9 10 1 2 3 4 5 6 7 8 9 10 1 2 3 4 5 6 7 8 9 10 ;do (megatest -test-paths -target %/%/% > /dev/null ) & done; wait; )
minsetup :
cd ..;make && make install
mkdir -p mintest/runs mintest/links
- cd mintest;megatest -stop-server 0
- cd mintest;megatest -server - -debug $(DEBUG) > server.log 2> server.log &
+ cd mintest;$(MEGATEST) -stop-server 0
+ cd mintest;$(MEGATEST) -server - -debug $(DEBUG) > server.log 2> server.log &
sleep 3
- cd mintest;dashboard -rows 18 &
+ cd mintest;$(DASHBOARD) -rows 18 &
cleanprep : ../*.scm Makefile */*.config
mkdir -p fullrun/tmp/mt_runs fullrun/tmp/mt_links
cd ..;make;make install
rm -f */logging.db
@@ -162,29 +158,26 @@
fullprep : cleanprep
cd fullrun;$(MEGATEST) -remove-runs :runname $(RUNNAME)% -target %/%/% -testpatt %/%
cd fullrun;$(BINPATH)/dashboard -rows 15 &
dashboard : cleanprep
- cd fullrun && $(BINPATH)/dashboard -transport fs -rows 20 &
-
-dashboard-http : cleanprep
- cd fullrun && $(BINPATH)/dashboard -transport http -rows 20 &
+ cd fullrun && $(BINPATH)/dashboard -rows 20 &
remove :
cd fullrun;$(MEGATEST) -remove-runs :runname $(RUN) -testpatt % -itempatt % :sysname % :fsname % :datapath %
clean :
rm cleanprep
kill :
killall -v mtest main.sh dboard || true
- rm -f */megatest.db */logging.db */monitor.db || true
+ rm -rf *run/db/* */megatest.db */logging.db */monitor.db fullrun/tmp/mt_*/* fullrun/tmp/mt_*/.db* || true
killall -v mtest dboard || true
hardkill : kill
- sleep 5;killall -v mtest main.sh dboard -9
+ sleep 2;killall -v mtest main.sh dboard -9
listservers :
cd fullrun;$(MEGATEST) -list-servers
runforever :
while(ls); do runname=`date +%F-%R:%S`;(cd fullrun;$(MEGATEST) -runall -target ubuntu/nfs/none :runname $$runname;/home/matt/data/megatest/megatest -runall -target ubuntu/nfs/none :runname $$runname;/home/matt/data/megatest/megatest -runall -target ubuntu/nfs/none :runname $$runname);done
Index: tests/fdktestqa/fdk.config
==================================================================
--- tests/fdktestqa/fdk.config
+++ tests/fdktestqa/fdk.config
@@ -2,11 +2,11 @@
SYSTEM TEXT
RELEASE TEXT
[setup]
# Adjust max_concurrent_jobs to limit how much you load your machines
-max_concurrent_jobs 150
+max_concurrent_jobs 500
# This is your link path, you can move it but it is generally better to keep it stable
linktree #{shell readlink -f #{getenv PWD}/../simplelinks}
[include testqa/configs/megatest.abc.config]
Index: tests/fdktestqa/testqa/Makefile
==================================================================
--- tests/fdktestqa/testqa/Makefile
+++ tests/fdktestqa/testqa/Makefile
@@ -5,25 +5,23 @@
all :
$(MEGATEST) -remove-runs -target a/b :runname c -testpatt %/%
$(MEGATEST) -runtests % -target a/b :runname c
bigbig :
- $(MEGATEST) -server - -daemonize ; sleep 3
for tn in a b c d;do \
($(MEGATEST) -runtests % -target a/b :runname $tn & ) ; \
done
bigrun :
- $(MEGATEST) -runtests bigrun -target a/bigrun :runname a
+ $(MEGATEST) -runtests bigrun -target a/bigrun :runname a$(shell date +%V)
bigrun2 :
- $(MEGATEST) -runtests bigrun2 -target a/bigrun2 :runname a -transport http
+ $(MEGATEST) -runtests bigrun2 -target a/bigrun2 :runname a$(shell date +%V)
dashboard :
$(DASHBOARD) -rows 20 &
compile :
- $(MEGATEST) -stop-server 0
(cd ../../..;make && make install)
clean :
- rm -rf ../simple*/*/* megatest.db
+ rm -rf ../simple*/*/* megatest.db db/*
Index: tests/fdktestqa/testqa/megatest.config
==================================================================
--- tests/fdktestqa/testqa/megatest.config
+++ tests/fdktestqa/testqa/megatest.config
@@ -1,10 +1,11 @@
[setup]
testcopycmd cp --remove-destination -rlv TEST_SRC_PATH/. TEST_TARG_PATH/. >> TEST_TARG_PATH/mt_launch.log 2>> TEST_TARG_PATH/mt_launch.log
-runqueue 20
-# transport http
launchwait no
+[jobtools]
+launcher loadrunner
+
[include ../fdk.config]
[server]
port 9080
Index: tests/fullrun/config/mt_include_1.config
==================================================================
--- tests/fullrun/config/mt_include_1.config
+++ tests/fullrun/config/mt_include_1.config
@@ -1,8 +1,8 @@
[setup]
# exectutable /path/to/megatest
-max_concurrent_jobs 500
+max_concurrent_jobs 50
linktree #{getenv MT_RUN_AREA_HOME}/tmp/mt_links
[jobtools]
useshell yes
@@ -9,14 +9,15 @@
# ## launcher launches jobs, the job is managed on the target host
## by megatest, comment out launcher to run local
# workhosts localhost hermes
# launcher exec nbfake
# launcher nbfake
+launcher loadrunner
# launcher echo
# launcher nbfind
# launcher nodanggood
-launcher nbload
+# launcher nbload
## use "xterm -e csi -- " as a launcher to examine the launch environment.
## exit with (exit)
## get a shell with (system "bash")
# launcher xterm -e csi --
Index: tests/fullrun/megatest.config
==================================================================
--- tests/fullrun/megatest.config
+++ tests/fullrun/megatest.config
@@ -23,11 +23,11 @@
# launchwait no
waivercommentpatt ^WW\d+ [a-z].*
# Use http instead of direct filesystem access
# transport http
-transport fs
+# transport fs
# If set to "default" the old code is used. Otherwise defaults to 200 or uses
# numeric value given.
#
runqueue 20
@@ -77,10 +77,15 @@
status pass fail n/a 0 1 running - 2
# These are set before all tests, override them
# in the testconfig [pre-launch-env-overrides] section
[env-override]
+
+# This variable is honored by the loadrunner script. The value is in percent
+# a value of 200 will stop new jobs from starting.
+MAX_ALLOWED_LOAD 150
+
# MT_XTERM_CMD overrides the terminal command
# MT_XTERM_CMD xterm -bg lightgreen -fg black
SPECIAL_ENV_VARS overide them here - should be seen at launch and in the runs
TESTVAR [system echo $PWD]
@@ -99,14 +104,10 @@
WRAPPEDVAR This var should have the work blah thrice: \
blah \
blah
-# Set MAX_ALLOWED_LOAD for nbload. 150 percent is a good value.
-
-MAX_ALLOWED_LOAD 150
-
# XTERM [system xterm]
# RUNDEAD [system exit 56]
[server]
@@ -114,10 +115,11 @@
# it succeeds
port 8080
# This server will keep running this number of hours after last access.
# Three minutes is 0.05 hours
+# timeout 0.025
timeout 0.025
## disks are:
## name host:/path/to/area
## -or-
@@ -130,9 +132,11 @@
[jobgroups]
# NOTE: job groups will falsely count the toplevel test as a job. If possible add N
# to your jobgroups where N is the number of parallel runs you are likely to see
+#
+sqlite3 6
+blockz 10
+# to your jobgroups where N is the number of parallel runs you are likely to see
#
-sqlite3 5
-blockz 5
Index: tests/fullrun/tests/priority_8/main.sh
==================================================================
--- tests/fullrun/tests/priority_8/main.sh
+++ tests/fullrun/tests/priority_8/main.sh
@@ -1,10 +1,14 @@
#!/bin/bash
# a bunch of steps in 2 second increments
for i in 1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17;do
+ echo "start step before $i: `date`"
$MT_MEGATEST -step step$i :state start :status running -setlog results$i.html
+ echo "start step after $i: `date`"
sleep 2
+ echo "end step before $i: `date`"
$MT_MEGATEST -step step$i :state end :status 0
+ echo "end step after $i: `date`"
done
exit 0
Index: tests/fullrun/tests/runfirst/main.sh
==================================================================
--- tests/fullrun/tests/runfirst/main.sh
+++ tests/fullrun/tests/runfirst/main.sh
@@ -30,7 +30,9 @@
if [[ `basename $PWD` == "mustfail" ]];then
$MT_MEGATEST -test-status :state COMPLETED :status FAIL
else
$MT_MEGATEST -test-status :state COMPLETED :status $loadstatus -m "This is a test level comment" :value 10e6 :expected_value 1.1e6 :tol 100e3 :category nada :variable sillyvar :units mFarks :comment "This is the value/expected comment"
fi
+
+env > envfile.txt
# $MT_MEGATEST -test-status :state COMPLETED :status FAIL
Index: tests/fullrun/tests/test_mt_vars/currentisblah.sh
==================================================================
--- tests/fullrun/tests/test_mt_vars/currentisblah.sh
+++ tests/fullrun/tests/test_mt_vars/currentisblah.sh
@@ -1,3 +1,3 @@
#!/usr/bin/env bash
-grep CURRENT megatest.sh | grep /tmp/nada
+grep -e '^export CURRENT' megatest.sh | grep /tmp/nada
Index: tests/mintest/megatest.config
==================================================================
--- tests/mintest/megatest.config
+++ tests/mintest/megatest.config
@@ -2,10 +2,11 @@
X TEXT
[setup]
max_concurrent_jobs 50
linktree #{getenv PWD}/linktree
+transport http
[server]
port 8090
[jobtools]
ADDED tests/rununittest.sh
Index: tests/rununittest.sh
==================================================================
--- /dev/null
+++ tests/rununittest.sh
@@ -0,0 +1,17 @@
+#!/bin/bash
+
+# Usage: rununittest.sh testname debuglevel
+#
+
+# Ensure all is made
+(cd ..;make && make install)
+
+# Clean setup
+#
+rm -f simplerun/megatest.db simplerun/monitor.db simplerun/db/monitor.db
+rm -rf simplelinks/ simpleruns/ simplerun/db/
+mkdir -p simplelinks simpleruns
+(cd simplerun;cp ../../*_records.scm .;perl -pi.bak -e 's/define-inline/define/' *_records.scm)
+
+# Run the test $1 is the unit test to run
+cd simplerun;echo '(load "../tests.scm")' | ../../bin/megatest -repl -debug $2 $1
Index: tests/simplerun/megatest.config
==================================================================
--- tests/simplerun/megatest.config
+++ tests/simplerun/megatest.config
@@ -3,10 +3,15 @@
RELEASE TEXT
[setup]
# Adjust max_concurrent_jobs to limit how much you load your machines
max_concurrent_jobs 50
+
+# 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
# This is your link path, you can move it but it is generally better to keep it stable
linktree #{shell readlink -f #{getenv PWD}/../simplelinks}
# Valid values for state and status for steps, NB// It is not recommended you use this
Index: tests/tests.scm
==================================================================
--- tests/tests.scm
+++ tests/tests.scm
@@ -11,12 +11,12 @@
(require-extension test)
(require-extension regex)
(require-extension srfi-18)
(import srfi-18)
-(require-extension zmq)
-(import zmq)
+;; (require-extension zmq)
+;; (import zmq)
(define test-work-dir (current-directory))
;; read in all the _record files
(let ((files (glob "*_records.scm")))
@@ -26,433 +26,11 @@
(load file))
files))
(define *runremote* #f)
-;;======================================================================
-;; P R O C E S S E S
-;;======================================================================
-
-(test "cmd-run-with-stderr->list" '("No such file or directory")
- (let ((reslst (cmd-run-with-stderr->list "ls" "/tmp/ihadbetternotexist")))
- (string-search (regexp "No such file or directory")(car reslst))))
-
-;;======================================================================
-;; T E S T M A T C H I N G
-;;======================================================================
-
-;; tests:glob-like-match
-(test #f '("abc") (tests:glob-like-match "abc" "abc"))
-(for-each
- (lambda (patt str expected)
- (test (conc patt " " str "=>" expected) expected (tests:glob-like-match patt str)))
- (list "abc" "~abc" "~abc" "a*c" "a%c")
- (list "abc" "abcd" "abc" "ABC" "ABC")
- (list '("abc") #t #f #f '("ABC"))
- )
-
-;; tests:match
-(test #f #t (tests:match "abc/def" "abc" "def"))
-(for-each
- (lambda (patterns testname itempath expected)
- (test (conc patterns " " testname "/" itempath "=>" expected)
- expected
- (tests:match patterns testname itempath)))
- (list "abc" "abc/%" "ab%/c%" "~abc/c%" "abc/~c%" "a,b/c,%/d" "%/,%/a" "%/,%/a" "%/,%/a" "%" "%" "%/" "%/")
- (list "abc" "abc" "abcd" "abc" "abc" "a" "abc" "def" "ghi" "a" "a" "a" "a")
- (list "" "" "cde" "cde" "cde" "" "" "a" "b" "" "b" "" "b")
- (list #t #t #t #f #f #t #t #t #f #t #t #t #f))
-
-;; db:patt->like
-(test #f "testname LIKE 't%'" (db:patt->like "testname" "t%" comparator: " AND "))
-(test #f "testname LIKE 't%' AND testname LIKE '%t'" (db:patt->like "testname" "t%,%t" comparator: " AND "))
-(test #f "item_path GLOB ''" (db:patt->like "item_path" ""))
-
-;; test:match->sqlqry
-(test #f "(testname GLOB 'a' AND item_path GLOB 'b') OR (testname LIKE 'a%' AND item_path LIKE '%') OR (testname GLOB '' AND item_path LIKE 'b%')"
- (tests:match->sqlqry "a/b,a%,/b%"))
-(test #f "(testname GLOB 'a' AND item_path GLOB 'b') OR (testname LIKE 'a%' AND item_path LIKE '%') OR (testname LIKE '%' AND item_path LIKE 'b%')"
- (tests:match->sqlqry "a/b,a%,%/b%"))
-
-;;======================================================================
-;; S E R V E R
-;;======================================================================
-
-(test "setup for run" #t (begin (setup-for-run)
- (string? (getenv "MT_RUN_AREA_HOME"))))
-
-(test "server-register, get-best-server" #t (let ((res #f))
- (open-run-close tasks:server-register tasks:open-db 1 "bob" 1234 100 'live 'http)
- (set! res (open-run-close tasks:get-best-server tasks:open-db))
- (number? (vector-ref res 3))))
-
-(test "de-register server" #t (let ((res #f))
- (open-run-close tasks:server-deregister tasks:open-db "bob" port: 1234)
- (vector? (open-run-close tasks:get-best-server tasks:open-db))))
-
-(define server-pid #f)
-(test "launch server" #t (let ((pid (process-fork (lambda ()
- ;; (daemon:ize)
- (server:launch 'http)))))
- (set! server-pid pid)
- (number? pid)))
-
-(thread-sleep! 3) ;; need to wait for server to start. Yes, a better way is needed.
-(test "get-best-server" #t (let ((dat (open-run-close tasks:get-best-server tasks:open-db)))
- (set! *runremote* (list (vector-ref dat 1)(vector-ref dat 2))) ;; host ip pullport pubport
- (and (string? (car *runremote*))
- (number? (cadr *runremote*)))))
-
-(test #f #t (car (cdb:login *runremote* *toppath* *my-client-signature*)))
-(test #f #t (let ((res (client:login *runremote*)))
- (car res)))
-
-
-;;======================================================================
-;; C O N F I G F I L E S
-;;======================================================================
-
-(define conffile #f)
-(test "Read a config" #t (hash-table? (read-config "test.config" #f #f)))
-(test "Read a config that doesn't exist" #t (hash-table? (read-config "nada.config" #f #f)))
-
-(set! conffile (read-config "test.config" #f #f))
-(test "Get available diskspace" #t (number? (get-df "./")))
-(test "Get best dir" #t (let ((bestdir (get-best-disk conffile)))
- (or (equal? "./" bestdir)
- (equal? "/tmp" bestdir))))
-(test "Multiline variable" 4 (length (string-split (config-lookup conffile "metadata" "description") "\n")))
-
-;; db
-(define row (vector "a" "b" "c" "blah"))
-(define header (list "col1" "col2" "col3" "col4"))
-(test "Get row by header" "blah" (db:get-value-by-header row header "col4"))
-
-;; (define *toppath* "tests")
-(define *db* #f)
-(test "open-db" #t (begin
- (set! *db* (open-db))
- (if *db* #t #f)))
-
-;; quit wasting time, I'm changing *db* to db
-(define db *db*)
-
-(test "get cpu load" #t (number? (get-cpu-load)))
-(test "get uname" #t (string? (get-uname)))
-
-(test "get validvalues as list" (list "start" "end" "completed")
- (string-split (config-lookup *configdat* "validvalues" "state")))
-
-(for-each (lambda (item)
- (test (conc "get valid items (" item ")")
- item (items:check-valid-items "state" item)))
- (list "start" "end" "completed"))
-
-(for-each (lambda (item)
- (test (conc "get valid items (" item ")")
- item (items:check-valid-items "status" item)))
- (list "pass" "fail" "n/a"))
-
-(test #f #f (items:check-valid-items "state" "blahfool"))
-
-(test "write env files" "nada.csh" (begin
- (save-environment-as-files "nada")
- (and (file-exists? "nada.sh")
- (file-exists? "nada.csh"))))
-
-(test #f #t (cdb:client-call *runremote* 'immediate #t 1 (lambda ()(display "Got here eh!?") #t)))
-
-;; (set! *verbosity* 20)
-(test #f *verbosity* (cadr (cdb:set-verbosity *runremote* *verbosity*)))
-(test #f #f (cdb:roll-up-pass-fail-counts *runremote* 1 "test1" "" "PASS"))
-;; (set! *verbosity* 1)
-;; (cdb:set-verbosity *runremote* *verbosity*)
-
-(test "get all legal tests" (list "test1" "test2") (sort (get-all-legal-tests) string<=?))
-
-
-(test "get-keys" "SYSTEM" (car (db:get-keys *db*)))
-
-(define remargs (args:get-args
- '("bar" "foo" ":runname" "bob" ":SYSTEM" "ubuntu" ":RELEASE" "v1.2" ":datapath" "blah/foo" "nada")
- (list ":runname" ":state" ":status")
- (list "-h")
- args:arg-hash
- 0))
-
-(test "register-run" #t (number?
- (db:register-run *db*
- '(("SYSTEM" "key1")("RELEASE" "key2"))
- "myrun"
- "new"
- "n/a"
- "bob")))
-
-(test #f #t (cdb:tests-register-test *runremote* 1 "nada" ""))
-(test #f 1 (cdb:remote-run db:get-test-id #f 1 "nada" ""))
-(test #f "NOT_STARTED" (vector-ref (open-run-close db:get-test-info #f 1 "nada" "") 3))
-(test #f "NOT_STARTED" (vector-ref (cdb:get-test-info *runremote* 1 "nada" "") 3))
-
-(define keys (db:get-keys *db*))
-
-;;======================================================================
-;; D B
-;;======================================================================
-
-(test #f "FOO LIKE 'abc%def'" (db:patt->like "FOO" "abc%def"))
-(test #f "key2" (vector-ref (car (vector-ref (runs:get-runs-by-patt *db* '("SYSTEM" "RELEASE") "%" "key1/key2") 1)) 1))
-
-(test #f "SYSTEM,RELEASE,id,runname,state,status,owner,event_time" (car (runs:get-std-run-fields keys '("id" "runname" "state" "status" "owner" "event_time"))))
-(test #f #t (runs:operate-on 'print "%" "%" "%"))
-
-;;(test "update-test-info" #t (test-update-meta-info *db* 1 "nada"
-(setenv "BLAHFOO" "1234")
-(unsetenv "NADAFOO")
-(test "env temp overrides" "xyz" (let ((prevvals (alist->env-vars '(("BLAHFOO" 4321)("NADAFOO" xyz))))
- (result (get-environment-variable "NADAFOO")))
- (alist->env-vars prevvals)
- result))
-
-(test "env restored" "1234" (get-environment-variable "BLAHFOO"))
-
-
-(test "Items assoc" "Elephant" (cadar (cadr (item-assoc->item-list '(("ANIMAL" "Elephant Lion")("SEASON" "Spring Fall"))))))
-(set! *verbosity* 6)
-(test "Items assoc" '()(item-assoc->item-list '(("a" "a b c d")("b" "c d e")("c" "")("d"))))
-(set! *verbosity* -1)
-(test "Items assoc empty items" '() (item-assoc->item-list '(("A"))))
-(set! *verbosity* 1)
-(test "Items table" "SEASON" (caadar (item-table->item-list '(("ANIMAL" "Elephant Lion")("SEASON" "Spring Winter")))))
-(test "Items table empty items I" '() (item-table->item-list '(("A"))))
-(test "Items table empty items II" '() (item-table->item-list '(("A" ""))))
-
-;; Test out the steps code
-
-(define test-id #f)
-
-;; force keepgoing
-; (hash-table-set! args:arg-hash "-keepgoing" #t)
-(hash-table-set! args:arg-hash "-itempatt" "%")
-(hash-table-set! args:arg-hash "-testpatt" "%")
-(hash-table-set! args:arg-hash "-target" "ubuntu/r1.2")
-(test "Setup for a run" #t (begin (setup-for-run) #t))
-
-(define *tdb* #f)
-(define keyvals #f)
-(test "target->keyval" #t (let ((kv (keys:target->keyval keys (args:get-arg "-target"))))
- (set! keyvals kv)(list? keyvals)))
-
-(define testdbpath (conc "/tmp/" (getenv "USER") "/megatest_testing"))
-(system (conc "rm -f " testdbpath "/testdat.db;mkdir -p " testdbpath))
-
-(print "Using " testdbpath " for test db")
-(test #f #t (let ((db (open-test-db testdbpath)))
- (set! *tdb* db)
- (sqlite3#database? db)))
-(sqlite3#finalize! *tdb*)
-
-;; (test "Remove the rollup run" #t (begin (remove-runs) #t))
-(define tconfig #f)
-(test "get a testconfig" #t (let ((tconf (tests:get-testconfig "test1" 'return-procs)))
- (set! tconfig tconf)
- (hash-table? tconf)))
-(db:clean-all-caches)
-
-(test "set-megatest-env-vars"
- "ubuntu"
- (begin
- (set-megatest-env-vars 1 inkeys: keys)
- (get-environment-variable "SYSTEM")))
-(test "setup-env-defaults"
- "see this variable"
- (begin
- (setup-env-defaults "runconfigs.config" 1 *already-seen-runconfig-info* keys keyvals "pre-launch-env-vars")
- (get-environment-variable "ALLTESTS")))
-
-(test #f "ubuntu" (car (keys:target-set-args keys (args:get-arg "-target") args:arg-hash)))
-
-(define rinfo #f)
-(test "get-run-info" #f (vector? (vector-ref (let ((rinf (cdb:remote-run db:get-run-info #f 1)))
- (set! rinfo rinf)
- rinf) 0)))
-(test "get-key-vals" "key1" (car (cdb:remote-run db:get-key-vals #f 1)))
-(test "tests:sort-by" '() (tests:sort-by-priority-and-waiton (make-hash-table)))
-
-(test "update-test_meta" "test1" (begin
- (runs:update-test_meta "test1" tconfig)
- (let ((dat (cdb:remote-run db:testmeta-get-record #f "test1")))
- (vector-ref dat 1))))
-
-(define test-path "tests/test1")
-(define disk-path #f)
-(test "get-best-disk" #t (string? (file-exists? (let ((d (get-best-disk *configdat*)))
- (set! disk-path d)
- d))))
-(test "create-work-area" #t (symbolic-link? (car (create-work-area 1 rinfo keyvals 1 test-path disk-path "test1" '()))))
-(test #f "" (item-list->path '()))
-
-(test "launch-test" #t (string? (file-exists? (launch-test 1 1 rinfo keyvals "run1" tconfig "test1" test-path '() (make-hash-table)))))
-
-
-(test "Run a test" #t (general-run-call
- "-runtests"
- "run a test"
- (lambda (target runname keys keyvallst)
- (let ((test-patts "test%"))
- ;; (runs:run-tests target runname test-patts user (make-hash-table))
- ;; (run:test run-id run-info key-vals runname test-record flags parent-test)
- ;; (set! *verbosity* 22) ;; (list 0 1 2))
- (run:test 1 ;; run-id
- #f ;; run-info is yet only a dream
- keyvallst ;; (keys:target->keyval keys target)
- "run1" ;; runname
- (vector ;; test_records.scm tests:testqueue
- "test1" ;; testname
- tconfig ;; testconfig
- '() ;; waitons
- 0 ;; priority
- #f ;; items
- #f ;; itemsdat
- "" ;; itempath
- )
- args:arg-hash ;; flags (e.g. -itemspatt)
- #f)
- ;; (set! *verbosity* 0)
- ))))
-
-
-
-
-
-(test "server stop" #f (let ((hostname (car *runremote*))
- (port (cadr *runremote*)))
- (tasks:kill-server #t hostname port server-pid 'http)
- (open-run-close tasks:get-best-server tasks:open-db)))
-
-(exit 1)
-;; (test "cache is coherent" #t (let ((cached-info (db:get-test-info-cached-by-id db 2))
-;; (non-cached (db:get-test-info-not-cached-by-id db 2)))
-;; (print "\nCached: " cached-info)
-;; (print "Noncached: " non-cached)
-;; (equal? cached-info non-cached)))
-
-(change-directory test-work-dir)
-(test "Add a step" #t
- (begin
- (db:teststep-set-status! db 2 "step1" "start" 0 "This is a comment" "mylogfile.html")
- (sleep 2)
- (db:teststep-set-status! db 2 "step1" "end" "pass" "This is a different comment" "finallogfile.html")
- (set! test-id (db:test-get-id (car (cdb:remote-run db:get-tests-for-run #f 1 "test1" '() '()))))
- (number? test-id)))
-
-(test "Get rundir" #t (let ((rundir (cdb:remote-run db:test-get-rundir-from-test-id #f test-id)))
- (print "Rundir " rundir)
- (system (conc "mkdir -p " rundir))
- (string? rundir)))
-(test #f #t (sqlite3#database? (open-test-db "./")))
-(test "Create a test db" "../simpleruns/key1/key2/myrun/test1/testdat.db"
- (let ((tdb (open-run-close db:open-test-db-by-test-id db test-id)))
- (if tdb (sqlite3#finalize! tdb))
- (file-exists? "../simpleruns/key1/key2/myrun/test1/testdat.db")))
-
-(test "Get steps for test" #t (let ((steps (cdb:remote-run db:get-steps-for-test #f test-id)))
- (print steps)
- (> (length steps) 0)))
-(test "Get nice table for steps" "2.0s"
- (begin
- (vector-ref (hash-table-ref (open-run-close db:get-steps-table #f test-id) "step1") 4)))
-
-;; (exit)
-
-(test #f "myrun" (cdb:remote-run db:get-run-name-from-id #f 1))
-
-(test #f #f (cdb:remote-run db:roll-up-pass-fail-counts #f 1 "nada" "" "PASS"))
-
-;;======================================================================
-;; R E M O T E C A L L S
-;;======================================================================
-
-(define start-wait (current-seconds))
-(print "Starting intensive cache and rpc test")
-(for-each (lambda (params)
- (print "Intensive: params=" params)
- (cdb:tests-register-test *runremote* 1 (conc "test" (random 20)) "")
- (apply cdb:test-set-status-state *runremote* test-id params)
- (cdb:pass-fail-counts *runremote* test-id (random 100) (random 100))
- (cdb:test-rollup-test_data-pass-fail *runremote* test-id)
- (cdb:roll-up-pass-fail-counts *runremote* 1 "test1" "" (cadr params))
- (thread-sleep! 0.01)) ;; cache ordering granularity is at the second level. Should really be at the ms level
- '(("COMPLETED" "PASS" #f)
- ("NOT_STARTED" "FAIL" "Just testing")
- ("NOT_STARTED" "FAIL" "Just testing")
- ("NOT_STARTED" "FAIL" "Just testing")
- ("COMPLETED" "PASS" #f)
- ("NOT_STARTED" "FAIL" "Just testing")
- ("KILLED" "UNKNOWN" "More testing")
- ("NOT_STARTED" "FAIL" "Just testing")
- ("NOT_STARTED" "FAIL" "Just testing")
- ("COMPLETED" "PASS" #f)
- ("NOT_STARTED" "FAIL" "Just testing")
- ("NOT_STARTED" "FAIL" "Just testing")
- ("KILLED" "UNKNOWN" "More testing")
- ("NOT_STARTED" "FAIL" "Just testing")
- ("COMPLETED" "PASS" #f)
- ("NOT_STARTED" "FAIL" "Just testing")
- ("KILLED" "UNKNOWN" "More testing")
- ("NOT_STARTED" "FAIL" "Just testing")
- ("NOT_STARTED" "FAIL" "Just testing")
- ("COMPLETED" "PASS" #f)
- ("NOT_STARTED" "FAIL" "Just testing")
- ("NOT_STARTED" "FAIL" "Just testing")
- ("KILLED" "UNKNOWN" "More testing")
- ("NOT_STARTED" "FAIL" "Just testing")
- ("COMPLETED" "PASS" #f)
- ("NOT_STARTED" "FAIL" "Just testing")
- ("NOT_STARTED" "FAIL" "Just testing")
- ("KILLED" "UNKNOWN" "More testing")
- ("NOT_STARTED" "FAIL" "Just testing")
- ("NOT_STARTED" "FAIL" "Just testing")
- ("COMPLETED" "PASS" #f)
- ("NOT_STARTED" "FAIL" "Just testing")
- ("KILLED" "UNKNOWN" "More testing")
- ("NOT_STARTED" "FAIL" "Just testing")
- ("NOT_STARTED" "FAIL" "Just testing")
- ("COMPLETED" "PASS" #f)
- ("NOT_STARTED" "FAIL" "Just testing")
- ("KILLED" "UNKNOWN" "More testing")
- ("KILLED" "UNKNOWN" "More testing")
- ))
-
-;; now set all tests to completed
-(cdb:flush-queue *runremote*)
-(let ((tests (cdb:remote-run db:get-tests-for-run #f 1 "%" '() '())))
- (print "Setting " (length tests) " to COMPLETED/PASS")
- (for-each
- (lambda (test)
- (cdb:test-set-status-state *runremote* (db:test-get-id test) "COMPLETED" "PASS" "Forced pass"))
- tests))
-
-;; (process-wait server-pid)
-;; (test "Server wait time" #t (let ((run-delta (- (current-seconds) start-wait)))
-;; (print "Server ran for " run-delta " seconds")
-;; (> run-delta 20)))
-
-(test "Rollup the run(s)" #t (begin
- (runs:rollup-run keys (keys->alist keys "na") "rollup" "matt")
- #t))
-
-(hash-table-set! args:arg-hash ":runname" "%")
-
-(test "Remove the rollup run" #t (begin (operate-on 'remove-runs)))
-
-(print "Waiting for server to be done, should be about 20 seconds")
-(test "server stop" #f (let ((hostname (car *runremote*))
- (port (cadr *runremote*)))
- (tasks:kill-server #t hostname port server-pid 'http)
- (open-run-close tasks:get-best-server tasks:open-db)))
-
-;; (cdb:kill-server *runremote*)
-
-;; (thread-join! th1 th2 th3)
-
-;; ADD ME!!!! (db:get-prereqs-not-met *db* 1 '("runfirst") "" mode: 'normal)
-;; ADD ME!!!! (rdb:get-tests-for-run *db* 1 "runfirst" #f '() '())
+(let* ((unit-test-name (list-ref (argv) 4))
+ (fname (conc "../unittests/" unit-test-name ".scm")))
+ (if (file-exists? fname)
+ (load fname)
+ (print "ERROR: Unit test " unit-test-name " not found in unittests directory")))
+
ADDED tests/unittests/basicserver.scm
Index: tests/unittests/basicserver.scm
==================================================================
--- /dev/null
+++ tests/unittests/basicserver.scm
@@ -0,0 +1,114 @@
+;;======================================================================
+;; S E R V E R
+;;======================================================================
+
+;; Run like this:
+;;
+;; (cd ..;make && make install) && ./rununittest.sh server 1;(cd simplerun;megatest -stop-server 0)
+
+(set! *transport-type* 'http)
+
+(test "setup for run" #t (begin (setup-for-run)
+ (string? (getenv "MT_RUN_AREA_HOME"))))
+
+(test "server-register, get-best-server" #t (let ((res #f))
+ (open-run-close tasks:server-register tasks:open-db 1 "bob" 1234 100 'live 'http)
+ (set! res (open-run-close tasks:get-best-server tasks:open-db))
+ (number? (vector-ref res 3))))
+
+(test "de-register server" #f (let ((res #f))
+ (open-run-close tasks:server-deregister tasks:open-db "bob" port: 1234)
+ (vector? (open-run-close tasks:get-best-server tasks:open-db))))
+
+(define server-pid #f)
+
+;; Not sure how the following should work, replacing it with system of megatest -server
+;; (test "launch server" #t (let ((pid (process-fork (lambda ()
+;; ;; (daemon:ize)
+;; (server:launch 'http)))))
+;; (set! server-pid pid)
+;; (number? pid)))
+(system "../../bin/megatest -server - -debug 22 > server.log 2> server.log &")
+
+(let loop ((n 10))
+ (thread-sleep! 1) ;; need to wait for server to start.
+ (let ((res (open-run-close tasks:get-best-server tasks:open-db)))
+ (print "tasks:get-best-server returned " res)
+ (if (and (not res)
+ (> n 0))
+ (loop (- n 1)))))
+
+(test "get-best-server" #t (begin
+ (client:launch)
+ (let ((dat (open-run-close tasks:get-best-server tasks:open-db)))
+ (vector? dat))))
+
+(define *keys* (keys:config-get-fields *configdat*))
+(define *keyvals* (keys:target->keyval *keys* "a/b/c"))
+
+(test #f #t (string? (car *runremote*)))
+(test #f '(#t "successful login") (rmt:login)) ;; *runremote* *toppath* *my-client-signature*)))
+
+(test #f #f (rmt:get-test-info-by-id 99)) ;; get non-existant test
+
+;; RUNS
+(test #f 1 (rmt:register-run *keyvals* "firstrun" "new" "n/a" (current-user-name)))
+(test "get run info" "firstrun" (let ((rinfo (rmt:get-run-info 1)))
+ (vector-ref (vector-ref rinfo 1) 3)))
+(test "get runname from id" "firstrun" (rmt:get-run-name-from-id 1))
+
+;; TESTS
+(test "get tests (no data)" '() (rmt:get-tests-for-run 1 "%" '() '() #f #f #f #f #f #f))
+(test "register test" #t (rmt:general-call 'register-test 1 "test1" ""))
+(test "get tests (some data)" 1 (length (rmt:get-tests-for-run 1 "%" '() '() #f #f #f #f #f #f)))
+(test "get test id" 1 (rmt:get-test-id 1 "test1" ""))
+(test "sync back" #t (> (rmt:sync-inmem->db) 0))
+(test "get test id from main" 1 (db:get-test-id *db* 1 "test1" ""))
+(test "get keys" #t (list? (rmt:get-keys)))
+(test "set comment" #t (begin (rmt:general-call 'set-test-comment "this is a comment" 1) #t))
+(test "get comment" "this is a comment" (let ((trec (rmt:get-test-info-by-id 1)))
+ (db:test-get-comment trec)))
+
+;; MORE RUNS
+(test "get runs" #t (let* ((runs (rmt:get-runs "%" #f #f '()))
+ (header (vector-ref runs 0))
+ (data (vector-ref runs 1)))
+ (and (list? header)
+ (list? data)
+ (vector? (car data)))))
+
+(test "get local testinfo" "test1" (vector-ref (db:get-testinfo-state-status *db* 1) 2))
+(test "get testinfo" "test1" (vector-ref (rmt:get-testinfo-state-status 1) 2))
+
+;;======================================================================
+;; D B
+;;======================================================================
+
+(test "pass fail counts" #t (rmt:general-call 'pass-fail-counts 10 9 1))
+(test "get pass fail counts" 19 (let ((dat (rmt:get-test-info-by-id 1)))
+ (+ (db:test-get-pass_count dat)
+ (db:test-get-fail_count dat))))
+
+(define testregistry (make-hash-table))
+(for-each
+ (lambda (tname)
+ (for-each
+ (lambda (itempath)
+ (let ((tkey (conc tname "/" itempath))
+ (rpass (random 10))
+ (rfail (random 10)))
+ (hash-table-set! testregistry tkey (list tname itempath))
+ (rmt:general-call 'register-test 1 tname itempath)
+ (let* ((tid (rmt:get-test-id 1 tname itempath))
+ (tdat (rmt:get-test-info-by-id tid)))
+ (rmt:general-call 'pass-fail-counts rpass rfail (db:test-get-id tdat))
+ (let* ((resdat (rmt:get-test-info-by-id tid)))
+ (test "set/get pass fail counts" (list rpass rfail)
+ (list (db:test-get-pass_count resdat)
+ (db:test-get-fail_count resdat)))))))
+ (list "" "a" "b" "c" "d" "e" "f" "g" "h" "i" "j")))
+ (list "test1" "test2" "test3" "test4" "test5"))
+
+
+(test #f '(#t "exit process started") (rmt:kill-server)) ;; *toppath* *my-client-signature* #f)))
+
ADDED tests/unittests/configfiles.scm
Index: tests/unittests/configfiles.scm
==================================================================
--- /dev/null
+++ tests/unittests/configfiles.scm
@@ -0,0 +1,52 @@
+;;======================================================================
+;; C O N F I G F I L E S
+;;======================================================================
+
+(define conffile #f)
+(test "Read a config" #t (hash-table? (read-config "test.config" #f #f)))
+(test "Read a config that doesn't exist" #t (hash-table? (read-config "nada.config" #f #f)))
+
+(set! conffile (read-config "test.config" #f #f))
+(test "Get available diskspace" #t (number? (get-df "./")))
+(test "Get best dir" #t (let ((bestdir (get-best-disk conffile)))
+ (or (equal? "./" bestdir)
+ (equal? "/tmp" bestdir))))
+(test "Multiline variable" 4 (length (string-split (config-lookup conffile "metadata" "description") "\n")))
+
+;; db
+(define row (vector "a" "b" "c" "blah"))
+(define header (list "col1" "col2" "col3" "col4"))
+(test "Get row by header" "blah" (db:get-value-by-header row header "col4"))
+
+;; (define *toppath* "tests")
+(define *db* #f)
+(test "open-db" #t (begin
+ (set! *db* (open-db))
+ (if *db* #t #f)))
+
+;; quit wasting time, I'm changing *db* to db
+(define db *db*)
+
+(test "get cpu load" #t (number? (get-cpu-load)))
+(test "get uname" #t (string? (get-uname)))
+
+(test "get validvalues as list" (list "start" "end" "completed")
+ (string-split (config-lookup *configdat* "validvalues" "state")))
+
+(for-each (lambda (item)
+ (test (conc "get valid items (" item ")")
+ item (items:check-valid-items "state" item)))
+ (list "start" "end" "completed"))
+
+(for-each (lambda (item)
+ (test (conc "get valid items (" item ")")
+ item (items:check-valid-items "status" item)))
+ (list "pass" "fail" "n/a"))
+
+(test #f #f (items:check-valid-items "state" "blahfool"))
+
+(test "write env files" "nada.csh" (begin
+ (save-environment-as-files "nada")
+ (and (file-exists? "nada.sh")
+ (file-exists? "nada.csh"))))
+
ADDED tests/unittests/dbrdbstruct.scm
Index: tests/unittests/dbrdbstruct.scm
==================================================================
--- /dev/null
+++ tests/unittests/dbrdbstruct.scm
@@ -0,0 +1,33 @@
+;;======================================================================
+;; S E R V E R
+;;======================================================================
+
+;; Run like this:
+;;
+;; (cd ..;make && make install) && ./rununittest.sh server 1;(cd simplerun;megatest -stop-server 0)
+
+(test #f #t (vector? (make-dbr:dbstruct "/tmp")))
+
+(define dbstruct (make-dbr:dbstruct "/tmp"))
+
+(test #f #t (begin (dbr:dbstruct-set-main! dbstruct "blah") #t))
+(test #f "blah" (dbr:dbstruct-get-main dbstruct))
+(for-each
+ (lambda (run-id)
+ (test #f #t (vector? (dbr:dbstruct-get-rundb-rec dbstruct run-id))))
+ (list 1 2 3 4 5 6 7 8 9 #f))
+
+(test #f 0 (dbr:dbstruct-field-name->num 'rundb))
+(test #f 1 (dbr:dbstruct-field-name->num 'inmem))
+(test #f 2 (dbr:dbstruct-field-name->num 'mtime))
+
+(test #f #f (dbr:dbstruct-get-runvec-val dbstruct 1 'rundb))
+(test #f #t (begin (dbr:dbstruct-set-runvec-val! dbstruct 1 'rundb "rundb") #t))
+(test #f "rundb" (dbr:dbstruct-get-runvec-val dbstruct 1 'rundb))
+
+(for-each
+ (lambda (k)
+ (test #f #t (begin (dbr:dbstruct-set-runvec-val! dbstruct 1 k (conc k)) #t))
+ (test #f (conc k) (dbr:dbstruct-get-runvec-val dbstruct 1 k)))
+ '(rundb inmem mtime rtime stime inuse))
+
ADDED tests/unittests/inmemdb.scm
Index: tests/unittests/inmemdb.scm
==================================================================
--- /dev/null
+++ tests/unittests/inmemdb.scm
@@ -0,0 +1,44 @@
+;;======================================================================
+;; S E R V E R
+;;======================================================================
+
+;; Run like this:
+;;
+;; (cd ..;make && make install) && ./rununittest.sh server 1;(cd simplerun;megatest -stop-server 0)
+
+(set! *transport-type* 'http)
+
+(system "cp ../fullrun/megatest.db megatest.db")
+
+(test "open inmem db" 1 (begin (open-in-mem-db) 1))
+
+(test "setup for run" #t (begin (setup-for-run)
+ (string? (getenv "MT_RUN_AREA_HOME"))))
+
+(system "megatest -server - -debug 0 &")
+
+(thread-sleep! 3) ;; need to wait for server to start. Yes, a better way is needed.
+
+(define *keys* (keys:config-get-fields *configdat*))
+(define *keyvals* (keys:target->keyval *keys* "a/b/c"))
+
+(test #f #t (string? (car *runremote*)))
+(test #f '(#t "successful login") (rmt:login)) ;; *runremote* *toppath* *my-client-signature*)))
+
+(define inmem (db:open-inmem-db))
+
+(define (inmem-test t b)
+ (test "inmem sync to" t (db:sync-to *db* inmem))
+ (test "inmem sync back" b (db:sync-to inmem *db*)))
+
+(inmem-test 0 0)
+
+(inmem-test 1 1)
+
+;;======================================================================
+;; D B
+;;======================================================================
+
+(test #f '(#t "exit process started") (rmt:kill-server)) ;; *toppath* *my-client-signature* #f)))
+
+
ADDED tests/unittests/misc.scm
Index: tests/unittests/misc.scm
==================================================================
--- /dev/null
+++ tests/unittests/misc.scm
@@ -0,0 +1,45 @@
+;;======================================================================
+;; P R O C E S S E S
+;;======================================================================
+
+(test "cmd-run-with-stderr->list" '("No such file or directory")
+ (let ((reslst (cmd-run-with-stderr->list "ls" "/tmp/ihadbetternotexist")))
+ (string-search (regexp "No such file or directory")(car reslst))))
+
+;;======================================================================
+;; T E S T M A T C H I N G
+;;======================================================================
+
+;; tests:glob-like-match
+(test #f '("abc") (tests:glob-like-match "abc" "abc"))
+(for-each
+ (lambda (patt str expected)
+ (test (conc patt " " str "=>" expected) expected (tests:glob-like-match patt str)))
+ (list "abc" "~abc" "~abc" "a*c" "a%c")
+ (list "abc" "abcd" "abc" "ABC" "ABC")
+ (list '("abc") #t #f #f '("ABC"))
+ )
+
+;; tests:match
+(test #f #t (tests:match "abc/def" "abc" "def"))
+(for-each
+ (lambda (patterns testname itempath expected)
+ (test (conc patterns " " testname "/" itempath "=>" expected)
+ expected
+ (tests:match patterns testname itempath)))
+ (list "abc" "abc/%" "ab%/c%" "~abc/c%" "abc/~c%" "a,b/c,%/d" "%/,%/a" "%/,%/a" "%/,%/a" "%" "%" "%/" "%/")
+ (list "abc" "abc" "abcd" "abc" "abc" "a" "abc" "def" "ghi" "a" "a" "a" "a")
+ (list "" "" "cde" "cde" "cde" "" "" "a" "b" "" "b" "" "b")
+ (list #t #t #t #f #f #t #t #t #f #t #t #t #f))
+
+;; db:patt->like
+(test #f "testname LIKE 't%'" (db:patt->like "testname" "t%" comparator: " AND "))
+(test #f "testname LIKE 't%' AND testname LIKE '%t'" (db:patt->like "testname" "t%,%t" comparator: " AND "))
+(test #f "item_path GLOB ''" (db:patt->like "item_path" ""))
+
+;; test:match->sqlqry
+(test #f "(testname GLOB 'a' AND item_path GLOB 'b') OR (testname LIKE 'a%' AND item_path LIKE '%') OR (testname GLOB '' AND item_path LIKE 'b%')"
+ (tests:match->sqlqry "a/b,a%,/b%"))
+(test #f "(testname GLOB 'a' AND item_path GLOB 'b') OR (testname LIKE 'a%' AND item_path LIKE '%') OR (testname LIKE '%' AND item_path LIKE 'b%')"
+ (tests:match->sqlqry "a/b,a%,%/b%"))
+
ADDED tests/unittests/runs.scm
Index: tests/unittests/runs.scm
==================================================================
--- /dev/null
+++ tests/unittests/runs.scm
@@ -0,0 +1,275 @@
+(define keys (db:get-keys *db*))
+
+(test "get all legal tests" (list "test1" "test2") (sort (get-all-legal-tests) string<=?))
+
+(test "register-run" #t (number?
+ (db:register-run *db*
+ '(("SYSTEM" "key1")("RELEASE" "key2"))
+ "myrun"
+ "new"
+ "n/a"
+ "bob")))
+
+(test #f #t (cdb:tests-register-test *runremote* 1 "nada" ""))
+(test #f 1 (cdb:remote-run db:get-test-id #f 1 "nada" ""))
+(test #f "NOT_STARTED" (vector-ref (open-run-close db:get-test-info #f 1 "nada" "") 3))
+(test #f "NOT_STARTED" (vector-ref (cdb:get-test-info *runremote* 1 "nada" "") 3))
+
+(test #f "FOO LIKE 'abc%def'" (db:patt->like "FOO" "abc%def"))
+(test #f "key2" (vector-ref (car (vector-ref (runs:get-runs-by-patt *db* '("SYSTEM" "RELEASE") "%" "key1/key2") 1)) 1))
+
+(test #f "SYSTEM,RELEASE,id,runname,state,status,owner,event_time" (car (runs:get-std-run-fields keys '("id" "runname" "state" "status" "owner" "event_time"))))
+(test #f #t (runs:operate-on 'print "%" "%" "%"))
+
+;;(test "update-test-info" #t (test-update-meta-info *db* 1 "nada"
+(setenv "BLAHFOO" "1234")
+(unsetenv "NADAFOO")
+(test "env temp overrides" "xyz" (let ((prevvals (alist->env-vars '(("BLAHFOO" 4321)("NADAFOO" xyz))))
+ (result (get-environment-variable "NADAFOO")))
+ (alist->env-vars prevvals)
+ result))
+
+(test "env restored" "1234" (get-environment-variable "BLAHFOO"))
+
+
+(test "Items assoc" "Elephant" (cadar (cadr (item-assoc->item-list '(("ANIMAL" "Elephant Lion")("SEASON" "Spring Fall"))))))
+(set! *verbosity* 6)
+(test "Items assoc" '()(item-assoc->item-list '(("a" "a b c d")("b" "c d e")("c" "")("d"))))
+(set! *verbosity* -1)
+(test "Items assoc empty items" '() (item-assoc->item-list '(("A"))))
+(set! *verbosity* 1)
+(test "Items table" "SEASON" (caadar (item-table->item-list '(("ANIMAL" "Elephant Lion")("SEASON" "Spring Winter")))))
+(test "Items table empty items I" '() (item-table->item-list '(("A"))))
+(test "Items table empty items II" '() (item-table->item-list '(("A" ""))))
+
+;; Test out the steps code
+
+(define test-id #f)
+
+;; force keepgoing
+; (hash-table-set! args:arg-hash "-keepgoing" #t)
+(hash-table-set! args:arg-hash "-itempatt" "%")
+(hash-table-set! args:arg-hash "-testpatt" "%")
+(hash-table-set! args:arg-hash "-target" "ubuntu/r1.2")
+(test "Setup for a run" #t (begin (setup-for-run) #t))
+
+(define *tdb* #f)
+(define keyvals #f)
+(test "target->keyval" #t (let ((kv (keys:target->keyval keys (args:get-arg "-target"))))
+ (set! keyvals kv)(list? keyvals)))
+
+(define testdbpath (conc "/tmp/" (getenv "USER") "/megatest_testing"))
+(system (conc "rm -f " testdbpath "/testdat.db;mkdir -p " testdbpath))
+
+(print "Using " testdbpath " for test db")
+(test #f #t (let ((db (open-test-db testdbpath)))
+ (set! *tdb* db)
+ (sqlite3#database? db)))
+(sqlite3#finalize! *tdb*)
+
+;; (test "Remove the rollup run" #t (begin (remove-runs) #t))
+(define tconfig #f)
+(test "get a testconfig" #t (let ((tconf (tests:get-testconfig "test1" 'return-procs)))
+ (set! tconfig tconf)
+ (hash-table? tconf)))
+(db:clean-all-caches)
+
+(test "set-megatest-env-vars"
+ "ubuntu"
+ (begin
+ (set-megatest-env-vars 1 inkeys: keys)
+ (get-environment-variable "SYSTEM")))
+(test "setup-env-defaults"
+ "see this variable"
+ (begin
+ (setup-env-defaults "runconfigs.config" 1 *already-seen-runconfig-info* keys keyvals "pre-launch-env-vars")
+ (get-environment-variable "ALLTESTS")))
+
+(test #f "ubuntu" (car (keys:target-set-args keys (args:get-arg "-target") args:arg-hash)))
+
+(define rinfo #f)
+(test "get-run-info" #f (vector? (vector-ref (let ((rinf (cdb:remote-run db:get-run-info #f 1)))
+ (set! rinfo rinf)
+ rinf) 0)))
+(test "get-key-vals" "key1" (car (cdb:remote-run db:get-key-vals #f 1)))
+(test "tests:sort-by" '() (tests:sort-by-priority-and-waiton (make-hash-table)))
+
+(test "update-test_meta" "test1" (begin
+ (runs:update-test_meta "test1" tconfig)
+ (let ((dat (cdb:remote-run db:testmeta-get-record #f "test1")))
+ (vector-ref dat 1))))
+
+(define test-path "tests/test1")
+(define disk-path #f)
+(test "get-best-disk" #t (string? (file-exists? (let ((d (get-best-disk *configdat*)))
+ (set! disk-path d)
+ d))))
+(test "create-work-area" #t (symbolic-link? (car (create-work-area 1 rinfo keyvals 1 test-path disk-path "test1" '()))))
+(test #f "" (item-list->path '()))
+
+(test "launch-test" #t (string? (file-exists? (launch-test 1 1 rinfo keyvals "run1" tconfig "test1" test-path '() (make-hash-table)))))
+
+
+(test "Run a test" #t (general-run-call
+ "-runtests"
+ "run a test"
+ (lambda (target runname keys keyvallst)
+ (let ((test-patts "test%"))
+ ;; (runs:run-tests target runname test-patts user (make-hash-table))
+ ;; (run:test run-id run-info key-vals runname test-record flags parent-test)
+ ;; (set! *verbosity* 22) ;; (list 0 1 2))
+ (run:test 1 ;; run-id
+ #f ;; run-info is yet only a dream
+ keyvallst ;; (keys:target->keyval keys target)
+ "run1" ;; runname
+ (vector ;; test_records.scm tests:testqueue
+ "test1" ;; testname
+ tconfig ;; testconfig
+ '() ;; waitons
+ 0 ;; priority
+ #f ;; items
+ #f ;; itemsdat
+ "" ;; itempath
+ )
+ args:arg-hash ;; flags (e.g. -itemspatt)
+ #f)
+ ;; (set! *verbosity* 0)
+ ))))
+
+
+
+
+
+(test "server stop" #f (let ((hostname (car *runremote*))
+ (port (cadr *runremote*)))
+ (tasks:kill-server #t hostname port server-pid 'http)
+ (open-run-close tasks:get-best-server tasks:open-db)))
+
+(exit 1)
+;; (test "cache is coherent" #t (let ((cached-info (db:get-test-info-cached-by-id db 2))
+;; (non-cached (db:get-test-info-not-cached-by-id db 2)))
+;; (print "\nCached: " cached-info)
+;; (print "Noncached: " non-cached)
+;; (equal? cached-info non-cached)))
+
+(change-directory test-work-dir)
+(test "Add a step" #t
+ (begin
+ (db:teststep-set-status! db 2 "step1" "start" 0 "This is a comment" "mylogfile.html")
+ (sleep 2)
+ (db:teststep-set-status! db 2 "step1" "end" "pass" "This is a different comment" "finallogfile.html")
+ (set! test-id (db:test-get-id (car (cdb:remote-run db:get-tests-for-run #f 1 "test1" '() '()))))
+ (number? test-id)))
+
+(test "Get rundir" #t (let ((rundir (cdb:remote-run db:test-get-rundir-from-test-id #f test-id)))
+ (print "Rundir " rundir)
+ (system (conc "mkdir -p " rundir))
+ (string? rundir)))
+(test #f #t (sqlite3#database? (open-test-db "./")))
+(test "Create a test db" "../simpleruns/key1/key2/myrun/test1/testdat.db"
+ (let ((tdb (open-run-close db:open-test-db-by-test-id db test-id)))
+ (if tdb (sqlite3#finalize! tdb))
+ (file-exists? "../simpleruns/key1/key2/myrun/test1/testdat.db")))
+
+(test "Get steps for test" #t (let ((steps (cdb:remote-run db:get-steps-for-test #f test-id)))
+ (print steps)
+ (> (length steps) 0)))
+(test "Get nice table for steps" "2.0s"
+ (begin
+ (vector-ref (hash-table-ref (open-run-close db:get-steps-table #f test-id) "step1") 4)))
+
+;; (exit)
+
+(test #f "myrun" (cdb:remote-run db:get-run-name-from-id #f 1))
+
+(test #f #f (cdb:remote-run db:roll-up-pass-fail-counts #f 1 "nada" "" "PASS"))
+
+;;======================================================================
+;; R E M O T E C A L L S
+;;======================================================================
+
+(define start-wait (current-seconds))
+(print "Starting intensive cache and rpc test")
+(for-each (lambda (params)
+ (print "Intensive: params=" params)
+ (cdb:tests-register-test *runremote* 1 (conc "test" (random 20)) "")
+ (apply cdb:test-set-status-state *runremote* test-id params)
+ (cdb:pass-fail-counts *runremote* test-id (random 100) (random 100))
+ (cdb:test-rollup-test_data-pass-fail *runremote* test-id)
+ (cdb:roll-up-pass-fail-counts *runremote* 1 "test1" "" (cadr params))
+ (thread-sleep! 0.01)) ;; cache ordering granularity is at the second level. Should really be at the ms level
+ '(("COMPLETED" "PASS" #f)
+ ("NOT_STARTED" "FAIL" "Just testing")
+ ("NOT_STARTED" "FAIL" "Just testing")
+ ("NOT_STARTED" "FAIL" "Just testing")
+ ("COMPLETED" "PASS" #f)
+ ("NOT_STARTED" "FAIL" "Just testing")
+ ("KILLED" "UNKNOWN" "More testing")
+ ("NOT_STARTED" "FAIL" "Just testing")
+ ("NOT_STARTED" "FAIL" "Just testing")
+ ("COMPLETED" "PASS" #f)
+ ("NOT_STARTED" "FAIL" "Just testing")
+ ("NOT_STARTED" "FAIL" "Just testing")
+ ("KILLED" "UNKNOWN" "More testing")
+ ("NOT_STARTED" "FAIL" "Just testing")
+ ("COMPLETED" "PASS" #f)
+ ("NOT_STARTED" "FAIL" "Just testing")
+ ("KILLED" "UNKNOWN" "More testing")
+ ("NOT_STARTED" "FAIL" "Just testing")
+ ("NOT_STARTED" "FAIL" "Just testing")
+ ("COMPLETED" "PASS" #f)
+ ("NOT_STARTED" "FAIL" "Just testing")
+ ("NOT_STARTED" "FAIL" "Just testing")
+ ("KILLED" "UNKNOWN" "More testing")
+ ("NOT_STARTED" "FAIL" "Just testing")
+ ("COMPLETED" "PASS" #f)
+ ("NOT_STARTED" "FAIL" "Just testing")
+ ("NOT_STARTED" "FAIL" "Just testing")
+ ("KILLED" "UNKNOWN" "More testing")
+ ("NOT_STARTED" "FAIL" "Just testing")
+ ("NOT_STARTED" "FAIL" "Just testing")
+ ("COMPLETED" "PASS" #f)
+ ("NOT_STARTED" "FAIL" "Just testing")
+ ("KILLED" "UNKNOWN" "More testing")
+ ("NOT_STARTED" "FAIL" "Just testing")
+ ("NOT_STARTED" "FAIL" "Just testing")
+ ("COMPLETED" "PASS" #f)
+ ("NOT_STARTED" "FAIL" "Just testing")
+ ("KILLED" "UNKNOWN" "More testing")
+ ("KILLED" "UNKNOWN" "More testing")
+ ))
+
+;; now set all tests to completed
+(cdb:flush-queue *runremote*)
+(let ((tests (cdb:remote-run db:get-tests-for-run #f 1 "%" '() '())))
+ (print "Setting " (length tests) " to COMPLETED/PASS")
+ (for-each
+ (lambda (test)
+ (cdb:test-set-status-state *runremote* (db:test-get-id test) "COMPLETED" "PASS" "Forced pass"))
+ tests))
+
+;; (process-wait server-pid)
+;; (test "Server wait time" #t (let ((run-delta (- (current-seconds) start-wait)))
+;; (print "Server ran for " run-delta " seconds")
+;; (> run-delta 20)))
+
+(test "Rollup the run(s)" #t (begin
+ (runs:rollup-run keys (keys->alist keys "na") "rollup" "matt")
+ #t))
+
+(hash-table-set! args:arg-hash ":runname" "%")
+
+(test "Remove the rollup run" #t (begin (operate-on 'remove-runs)))
+
+(print "Waiting for server to be done, should be about 20 seconds")
+(test "server stop" #f (let ((hostname (car *runremote*))
+ (port (cadr *runremote*)))
+ (tasks:kill-server #t hostname port server-pid 'http)
+ (open-run-close tasks:get-best-server tasks:open-db)))
+
+;; (cdb:kill-server *runremote*)
+
+;; (thread-join! th1 th2 th3)
+
+;; ADD ME!!!! (db:get-prereqs-not-met *db* 1 '("runfirst") "" mode: 'normal)
+;; ADD ME!!!! (rdb:get-tests-for-run *db* 1 "runfirst" #f '() '())
ADDED tests/unittests/server.scm
Index: tests/unittests/server.scm
==================================================================
--- /dev/null
+++ tests/unittests/server.scm
@@ -0,0 +1,116 @@
+;;======================================================================
+;; S E R V E R
+;;======================================================================
+
+;; Run like this:
+;;
+;; (cd ..;make && make install) && ./rununittest.sh server 1;(cd simplerun;megatest -stop-server 0)
+
+(set! *transport-type* 'http)
+
+(test "setup for run" #t (begin (setup-for-run)
+ (string? (getenv "MT_RUN_AREA_HOME"))))
+
+(test "server-register, get-best-server" #t (let ((res #f))
+ (open-run-close tasks:server-register tasks:open-db 1 "bob" 1234 100 'live 'http)
+ (set! res (open-run-close tasks:get-best-server tasks:open-db))
+ (number? (vector-ref res 3))))
+
+(test "de-register server" #f (let ((res #f))
+ (open-run-close tasks:server-deregister tasks:open-db "bob" port: 1234)
+ (vector? (open-run-close tasks:get-best-server tasks:open-db))))
+
+(define server-pid #f)
+
+;; Not sure how the following should work, replacing it with system of megatest -server
+;; (test "launch server" #t (let ((pid (process-fork (lambda ()
+;; ;; (daemon:ize)
+;; (server:launch 'http)))))
+;; (set! server-pid pid)
+;; (number? pid)))
+(system "../../bin/megatest -server - -debug 22 > server.log 2> server.log &")
+
+(let loop ((n 10))
+ (thread-sleep! 1) ;; need to wait for server to start.
+ (let ((res (open-run-close tasks:get-best-server tasks:open-db)))
+ (print "tasks:get-best-server returned " res)
+ (if (and (not res)
+ (> n 0))
+ (loop (- n 1)))))
+
+(test "get-best-server" #t (begin
+ (client:launch)
+ (let ((dat (open-run-close tasks:get-best-server tasks:open-db)))
+ (vector? dat))))
+
+(define *keys* (keys:config-get-fields *configdat*))
+(define *keyvals* (keys:target->keyval *keys* "a/b/c"))
+
+(test #f #t (string? (car *runremote*)))
+(test #f '(#t "successful login") (rmt:login)) ;; *runremote* *toppath* *my-client-signature*)))
+
+(test #f #f (rmt:get-test-info-by-id 1 99)) ;; get non-existant test
+
+;; RUNS
+(test #f 1 (rmt:register-run *keyvals* "firstrun" "new" "n/a" (current-user-name)))
+(test "get run info" "firstrun" (let ((rinfo (rmt:get-run-info 1)))
+ (vector-ref (vector-ref rinfo 1) 3)))
+(test "get runname from id" "firstrun" (rmt:get-run-name-from-id 1))
+
+;; TESTS
+(test "get tests (no data)" '() (rmt:get-tests-for-run 1 "%" '() '() #f #f #f #f #f #f))
+(test "register test" #t (rmt:general-call 'register-test 1 1 "test1" ""))
+(test "get tests (some data)" 1 (length (rmt:get-tests-for-run 1 "%" '() '() #f #f #f #f #f #f)))
+(test "get test id" 1 (rmt:get-test-id 1 "test1" ""))
+
+(test "sync back" #t (> (rmt:sync-inmem->db) 0))
+(test "get test id from main" 1 (db:get-test-id *db* 1 "test1" ""))
+
+(test "get keys" #t (list? (rmt:get-keys)))
+(test "set comment" #t (begin (rmt:general-call 'set-test-comment 1 "this is a comment" 1) #t))
+(test "get comment" "this is a comment" (let ((trec (rmt:get-test-info-by-id 1 1)))
+ (db:test-get-comment trec)))
+
+;; MORE RUNS
+(test "get runs" #t (let* ((runs (rmt:get-runs "%" #f #f '()))
+ (header (vector-ref runs 0))
+ (data (vector-ref runs 1)))
+ (and (list? header)
+ (list? data)
+ (vector? (car data)))))
+
+(test "get local testinfo" "test1" (vector-ref (db:get-testinfo-state-status *db* 1 1) 2))
+(test "get testinfo" "test1" (vector-ref (rmt:get-testinfo-state-status 1 1) 2))
+
+;;======================================================================
+;; D B
+;;======================================================================
+
+(test "pass fail counts" #t (rmt:general-call 'pass-fail-counts 10 9 1))
+(test "get pass fail counts" 19 (let ((dat (rmt:get-test-info-by-id 1)))
+ (+ (db:test-get-pass_count dat)
+ (db:test-get-fail_count dat))))
+
+(define testregistry (make-hash-table))
+(for-each
+ (lambda (tname)
+ (for-each
+ (lambda (itempath)
+ (let ((tkey (conc tname "/" itempath))
+ (rpass (random 10))
+ (rfail (random 10)))
+ (hash-table-set! testregistry tkey (list tname itempath))
+ (rmt:general-call 'register-test 1 tname itempath)
+ (let* ((tid (rmt:get-test-id 1 tname itempath))
+ (tdat (rmt:get-test-info-by-id tid)))
+ (rmt:general-call 'pass-fail-counts rpass rfail (db:test-get-id tdat))
+ (let* ((resdat (rmt:get-test-info-by-id tid)))
+ (test "set/get pass fail counts" (list rpass rfail)
+ (list (db:test-get-pass_count resdat)
+ (db:test-get-fail_count resdat)))))))
+ (list "" "a" "b" "c" "d" "e" "f" "g" "h" "i" "j")))
+ (list "test1" "test2" "test3" "test4" "test5"))
+
+
+(test #f '(#t "exit process started") (rmt:kill-server)) ;; *toppath* *my-client-signature* #f)))
+
ADDED tests/unittests/tests.scm
Index: tests/unittests/tests.scm
==================================================================
--- /dev/null
+++ tests/unittests/tests.scm
ADDED tests/watch-monitor.sh
Index: tests/watch-monitor.sh
==================================================================
--- /dev/null
+++ tests/watch-monitor.sh
@@ -0,0 +1,10 @@
+#!/bin/bash
+
+if [ -e fullrun/db/monitor.db ];then
+sqlite3 fullrun/db/monitor.db << EOF
+.header on
+.mode column
+select * from servers order by start_time desc;
+.q
+EOF
+fi
ADDED utils/loadrunner
Index: utils/loadrunner
==================================================================
--- /dev/null
+++ utils/loadrunner
@@ -0,0 +1,29 @@
+#!/bin/bash
+
+# load=`uptime|awk '{print $10}'|cut -d, -f1`
+load=`uptime|perl -pe 's/.*: (\d+.\d+),.*/$1/'`
+if which cpucheck > /dev/null;then
+ numcpu=`cpucheck|tail -1|awk '{print $6}'`
+elif which lscpu > /dev/null;then
+ numcpu=`lscpu|grep "CPU.s.:"|awk '{print $2}'`
+else
+ numcpu=2
+fi
+
+# NB// max_load is in units of percent.
+#
+lperc=`echo "100 * $load / $numcpu"|bc`
+if [[ "x$MAX_ALLOWED_LOAD" == "x" ]]; then
+ max_load=100
+else
+ max_load=$MAX_ALLOWED_LOAD
+fi
+
+if [[ $lperc -lt $max_load ]];then
+ echo "Load acceptable: lperc=$lperc %, max_load=$max_load %, load=$load, numcpu=$numcpu, MAX_ALLOWED_LOAD=$MAX_ALLOWED_LOAD %"
+ echo "Starting command: \"$@\""
+ nbfake "$@"
+else
+ # echo "Load too high: lperc=$lperc, max_load=$max_load, waiting two minutes before trying to run command: \"$@\""
+ echo "loadrunner $@" | at now + 2 minutes 2> /dev/null
+fi
Index: utils/nbfake
==================================================================
--- utils/nbfake
+++ utils/nbfake
@@ -1,12 +1,17 @@
#!/bin/bash
-# ssh localhost "nohup $* > nbfake.log 2> nbfake.err < /dev/null"
-
# Can't always trust $PWD
CURRWD=`pwd`
+if [[ $TARGETHOST_LOGF == "" ]]; then
+ TARGETHOST_LOGF=NBFAKE-`date +%GWW%V.%u_%T`
+fi
+echo "#======================================================================"
+echo "# NBFAKE Running command:"
+echo "# \"$*\""
+echo "#======================================================================"
if [[ $TARGETHOST == "" ]]; then
- sh -c "cd $CURRWD;export DISPLAY=$DISPLAY; export PATH=$PATH; nohup $* > NBFAKE-`date +%GWW%V.%u_%T` 2>&1 &"
+ sh -c "cd $CURRWD;export DISPLAY=$DISPLAY; export PATH=$PATH; nohup $* > $TARGETHOST_LOGF 2>&1 &"
else
- ssh -n -f $TARGETHOST "sh -c \"cd $CURRWD;export DISPLAY=$DISPLAY; export PATH=$PATH; nohup $* > NBFAKE-`date +%GWW%V.%u_%T` 2>&1 &\""
+ ssh -n -f $TARGETHOST "sh -c \"cd $CURRWD;export DISPLAY=$DISPLAY; export PATH=$PATH; nohup $* > $TARGETHOST_LOGF 2>&1 &\""
fi
DELETED utils/nbload
Index: utils/nbload
==================================================================
--- utils/nbload
+++ /dev/null
@@ -1,29 +0,0 @@
-#!/bin/bash
-
-# load=`uptime|awk '{print $10}'|cut -d, -f1`
-load=`uptime|perl -pe 's/.*: (\d+.\d+),.*/$1/'`
-if which cpucheck > /dev/null;then
- numcpu=`cpucheck|tail -1|awk '{print $6}'`
-elif which lscpu > /dev/null;then
- numcpu=`lscpu|grep "CPU.s.:"|awk '{print $2}'`
-else
- numcpu=2
-fi
-
-# NB// max_load is in units of percent.
-#
-lperc=`echo "100 * $load / $numcpu"|bc`
-if [[ "x$MAX_ALLOWED_LOAD" == "x" ]]; then
- max_load=100
-else
- max_load=$MAX_ALLOWED_LOAD
-fi
-
-if [[ $lperc -lt $max_load ]];then
- echo "Load acceptable: lperc=$lperc %, max_load=$max_load %, load=$load, numcpu=$numcpu, MAX_ALLOWED_LOAD=$MAX_ALLOWED_LOAD %"
- echo "Starting command: \"$@\""
- nbfake "$@"
-else
- # echo "Load too high: lperc=$lperc, max_load=$max_load, waiting two minutes before trying to run command: \"$@\""
- echo "nbload $@" | at now + 2 minutes 2> /dev/null
-fi
ADDED utils/plot-code.scm
Index: utils/plot-code.scm
==================================================================
--- /dev/null
+++ utils/plot-code.scm
@@ -0,0 +1,148 @@
+#!/mfs/pkgs/chicken/4.8.0.5/bin/csi -nbq
+
+(use regex srfi-69 srfi-13)
+
+(define targs #f)
+(define files (cddddr (argv)))
+
+(let ((targdat (cadddr (argv))))
+ (if (equal? targdat "-")
+ (set! targs files)
+ (set! targs (string-split targdat ","))))
+
+(define filedat-defns (make-hash-table))
+(define filedat-usages (make-hash-table))
+
+(define defn-rx (regexp "^\\s*\\(define\\s+\\(([^\\s\\)]+).*"))
+(define all-regexs (make-hash-table))
+
+(define all-fns '())
+
+(define (print-err . data)
+ (with-output-to-port (current-error-port)
+ (lambda ()
+ (apply print data))))
+
+(print-err "Making graph for files: " (string-intersperse targs ", "))
+(print-err "Looking at files: " (string-intersperse files ", "))
+
+;; Gather the functions
+;;
+(for-each
+ (lambda (fname)
+ (print-err "Processing file " fname)
+ (with-input-from-file fname
+ (lambda ()
+ (let loop ((inl (read-line)))
+ (if (not (eof-object? inl))
+ (let ((match (string-match defn-rx inl)))
+ (if match
+ (let ((fnname (cadr match)))
+ ;; (print " " fnname)
+ (set! all-fns (cons fnname all-fns))
+ (hash-table-set!
+ filedat-defns
+ fname
+ (cons fnname (hash-table-ref/default filedat-defns fname '())))
+ ))
+ (loop (read-line))))))))
+ files)
+
+;; fill up the regex hash
+(print-err "Make the huge regex hash")
+(for-each
+ (lambda (fnname)
+ (hash-table-set! all-regexs fnname (regexp (conc "^(|.*[^a-zA-Z]+)" fnname "([^a-zA-Z]+|)$"))))
+ (cons "toplevel" all-fns))
+
+(define breadcrumbs (make-hash-table))
+
+(define (have-function inl)
+ (let loop ((hed (car all-fns))
+ (tal (cdr all-fns)))
+ (if (string-contains inl hed)
+ #t
+ (if (null? tal)
+ #f
+ (loop (car tal)(cdr tal))))))
+
+(define (look-for-all-calls inl fnname)
+ (if (have-function inl) ;; (string-search have-function-rx inl)
+ (let loop ((hed (car all-fns))
+ (tal (cdr all-fns))
+ (res '()))
+ (let ((match (string-match (hash-table-ref all-regexs hed) inl)))
+ (if match
+ (let ((newres (cons hed res)))
+ (if (null? tal)
+ newres
+ (loop (car tal)
+ (cdr tal)
+ newres)))
+ (if (null? tal)
+ res
+ (loop (car tal)(cdr tal) res)))))
+ '()))
+
+;; Gather the usages
+(print "digraph G {")
+(define curr-cluster-num 0)
+(define function-calls '())
+
+(for-each
+ (lambda (fname)
+ (let ((last-func #f))
+ (print-err "Processing file " fname)
+ (print "subgraph cluster_" curr-cluster-num " {")
+ (set! curr-cluster-num (+ curr-cluster-num 1))
+ (with-input-from-file fname
+ (lambda ()
+ (with-output-to-port (current-error-port)
+ (lambda ()
+ (print "Analyzing file " fname)))
+ (print "label=\"" fname "\";")
+ (let loop ((inl (read-line))
+ (fnname "toplevel")
+ (allcalls '()))
+ (if (eof-object? inl)
+ (begin
+ (set! function-calls (cons (list fnname allcalls) function-calls))
+ (for-each
+ (lambda (call-name)
+ (hash-table-set! breadcrumbs call-name #t))
+ allcalls)
+ (print-err "function: " fnname " allcalls: " allcalls))
+ (let ((match (string-match defn-rx inl)))
+ (if match
+ (let ((func-name (cadr match)))
+ (if last-func
+ (print "\"" func-name "\" -> \"" last-func "\";")
+ (print "\"" func-name "\";"))
+ (set! last-func func-name)
+ (hash-table-set! breadcrumbs func-name #t)
+ (loop (read-line)
+ func-name
+ allcalls))
+ (let ((calls (look-for-all-calls inl fnname)))
+ (loop (read-line) fnname (append allcalls calls)))))))))
+ (print "}")))
+ targs)
+
+(print-err "breadcrumbs: " (hash-table-keys breadcrumbs))
+(print-err "function-calls: " function-calls)
+
+(for-each
+ (lambda (function-call)
+ (print-err "function-call: " function-call)
+ (let ((fnname (car function-call))
+ (calls (cadr function-call)))
+ (for-each
+ (lambda (callname)
+ (print (if (hash-table-ref/default breadcrumbs callname #f) "" "// ")
+ "\"" fnname "\" -> \"" callname "\";"))
+ calls)))
+ function-calls)
+
+(print "}")
+
+(exit)
DELETED zmq-transport.scm
Index: zmq-transport.scm
==================================================================
--- zmq-transport.scm
+++ /dev/null
@@ -1,493 +0,0 @@
-
-;; Copyright 2006-2012, Matthew Welland.
-;;
-;; This program is made available under the GNU GPL version 2.0 or
-;; greater. See the accompanying file COPYING for details.
-;;
-;; This program is distributed WITHOUT ANY WARRANTY; without even the
-;; implied warranty of MERCHANTABILITY or FITNESS FOR A PARTICULAR
-;; PURPOSE.
-
-(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 zmq)
-
-(declare (unit zmq-transport))
-
-(declare (uses common))
-(declare (uses db))
-(declare (uses tests))
-(declare (uses tasks)) ;; tasks are where stuff is maintained about what is running.
-(declare (uses server))
-
-(include "common_records.scm")
-(include "db_records.scm")
-
-;; Transition to pub --> sub with pull <-- push
-;;
-;; 1. client sends request to server via push to the pull port
-;; 2. server puts request in queue or processes immediately as appropriate
-;; 3. server puts responses from completed requests into pub port
-;;
-;; TODO
-;;
-;; Done Tested
-;; [x] [ ] 1. Add columns pullport pubport to servers table
-;; [x] [ ] 2. Add rm of monitor.db if older than 11/12/2012
-;; [x] [ ] 3. Add create of pullport and pubport with finding of available ports
-;; [x] [ ] 4. Add client compose of request
-;; [x] [ ] - name of client: testname/itempath-test_id-hostname
-;; [x] [ ] - name of request: callname, params
-;; [x] [ ] - request key: f(clientname, callname, params)
-;; [x] [ ] 5. Add processing of subscription hits
-;; [x] [ ] - done when get key
-;; [x] [ ] - return results
-;; [x] [ ] 6. Add timeout processing
-;; [x] [ ] - after 60 seconds
-;; [ ] [ ] i. check server alive, connect to new if necessary
-;; [ ] [ ] ii. resend request
-;; [ ] [ ] 7. Turn self ping back on
-
-(define (zmq-transport:make-server-url hostport)
- (if (not hostport)
- #f
- (conc "tcp://" (car hostport) ":" (cadr hostport))))
-
-(define *server-loop-heart-beat* (current-seconds))
-(define *heartbeat-mutex* (make-mutex))
-
-;;======================================================================
-;; S E R V E R
-;;======================================================================
-
-(define-inline (zmqsock:get-pub dat)(vector-ref dat 0))
-(define-inline (zmqsock:get-pull dat)(vector-ref dat 1))
-(define-inline (zmqsock:set-pub! dat s)(vector-set! dat s 0))
-(define-inline (zmqsock:set-pull! dat s)(vector-set! dat s 0))
-
-(define (zmq-transport:run hostn)
- (debug:print 2 "Attempting to start the server ...")
- (if (not *toppath*)
- (if (not (setup-for-run))
- (begin
- (debug:print 0 "ERROR: cannot find megatest.config, cannot start server, exiting")
- (exit))))
- (let* ((db (open-db)) ;; here we *do not* want to be opening and closing the db
- (zmq-sdat1 #f)
- (zmq-sdat2 #f)
- (pull-socket #f)
- (pub-socket #f)
- (p1 #f)
- (p2 #f)
- (zmq-sockets-dat #f)
- (iface (if (string=? "-" hostn)
- "*" ;; (get-host-name)
- hostn))
- (hostname (get-host-name))
- (ipaddrstr (let ((ipstr (if (string=? "-" hostn)
- (string-intersperse (map number->string (u8vector->list (hostname->ip hostname))) ".")
- #f)))
- (if ipstr ipstr hostname)))
- (last-run 0))
- (set! zmq-sockets-dat (zmq-transport:setup-ports ipaddrstr (if (args:get-arg "-port")
- (string->number (args:get-arg "-port"))
- (+ 5000 (random 1001)))))
-
- (set! zmq-sdat1 (car zmq-sockets-dat))
- (set! pull-socket (cadr zmq-sdat1)) ;; (iface s port)
- (set! p1 (caddr zmq-sdat1))
-
- (set! zmq-sdat2 (cadr zmq-sockets-dat))
- (set! pub-socket (cadr zmq-sdat2))
- (set! p2 (caddr zmq-sdat2))
-
- (set! *cache-on* #t)
-
- (set! *runremote* (vector pull-socket pub-socket)) ;; overloading the use of *runremote* BUG!?
-
- ;; what to do when we quit
- ;;
-;; (on-exit (lambda ()
-;; (if (and *toppath* *server-info*)
-;; (open-run-close tasks:server-deregister-self tasks:open-db (car *server-info*))
-;; (let loop ()
-;; (let ((queue-len 0))
-;; (thread-sleep! (random 5))
-;; (mutex-lock! *incoming-mutex*)
-;; (set! queue-len (length *incoming-data*))
-;; (mutex-unlock! *incoming-mutex*)
-;; (if (> queue-len 0)
-;; (begin
-;; (debug:print-info 0 "Queue not flushed, waiting ...")
-;; (loop))))))))
-
- ;; The heavy lifting
- ;;
- ;; make-vector-record cdb packet client-sig qtype immediate query-sig params qtime
- ;;
- (debug:print-info 11 "Server setup complete, start listening for messages")
- (let loop ((queue-lst '()))
- (let* ((rawmsg (receive-message* pull-socket))
- (packet (db:string->obj rawmsg))
- (qtype (cdb:packet-get-qtype packet)))
- (debug:print-info 12 "server=> received packet=" packet)
- (if (not (member qtype '(sync ping)))
- (begin
- (mutex-lock! *heartbeat-mutex*)
- (set! *last-db-access* (current-seconds))
- (mutex-unlock! *heartbeat-mutex*)))
- (if #t ;; (cdb:packet-get-immediate packet) ;; process immediately or put in queue
- (begin
- (db:process-queue-item db packet)
- ;; (open-run-close db:process-queue #f pub-socket (cons packet queue-lst))
-
- (loop '()))
- (loop (cons packet queue-lst)))))))
-
-;; run zmq-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 (zmq-transport:keep-running)
- ;; if none running or if > 20 seconds since
- ;; server last used then start shutdown
- ;; This thread waits for the server to come alive
- (let* ((server-info (let loop ()
- (let ((sdat #f))
- (mutex-lock! *heartbeat-mutex*)
- (set! sdat *server-info*)
- (mutex-unlock! *heartbeat-mutex*)
- (if sdat sdat
- (begin
- (debug:print 12 "WARNING: server not started yet, waiting few seconds before trying again")
- (sleep 4)
- (loop))))))
- (iface (cadr server-info))
- (pullport (caddr server-info))
- (pubport (cadddr server-info)) ;; id interface pullport pubport)
- ;; (zmq-sockets (zmq-transport:client-connect iface pullport pubport))
- (last-access 0))
- (debug:print-info 11 "heartbeat started for zmq server on " iface " " pullport " " pubport)
- (let loop ((count 0))
- (thread-sleep! 4) ;; no need to do this very often
- ;; NB// sync currently does NOT return queue-length
- ;; GET REAL QUEUE LENGTH FROM THE VARIABLE
- (let ((queue-len 0)) ;; FOR NOW DO NOT DO THIS (cdb:client-call zmq-sockets 'sync #t 1)))
- ;; (print "Server running, count is " count)
- (if (< count 1) ;; 3x3 = 9 secs aprox
- (loop (+ count 1)))
-
- ;; NOTE: Get rid of this mechanism! It really is not needed...
- (open-run-close tasks:server-update-heartbeat tasks:open-db (car server-info))
-
- ;; (if ;; (or (> numrunning 0) ;; stay alive for two days after last access
- (mutex-lock! *heartbeat-mutex*)
- (set! last-access *last-db-access*)
- (mutex-unlock! *heartbeat-mutex*)
- (if (> (+ last-access
- ;; (* 50 60 60) ;; 48 hrs
- ;; 60 ;; one minute
- ;; (* 60 60) ;; one hour
- (* 45 60) ;; 45 minutes, until the db deletion bug is fixed.
- )
- (current-seconds))
- (begin
- (debug:print-info 2 "Server continuing, seconds since last db access: " (- (current-seconds) last-access))
- (loop 0))
- (begin
- (debug:print-info 0 "Starting to shutdown the server.")
- ;; need to delete only *my* server entry (future use)
- (set! *time-to-exit* #t)
- (open-run-close tasks:server-deregister-self tasks:open-db (get-host-name))
- (thread-sleep! 1)
- (debug:print-info 0 "Max cached queries was " *max-cache-size*)
- (debug:print-info 0 "Server shutdown complete. Exiting")
- (exit)))))))
-
-(define (zmq-transport:find-free-port-and-open iface s port stype #!key (trynum 50))
- (let ((s (if s s (make-socket stype)))
- (p (if (number? port) port 5555))
- (old-handler (current-exception-handler)))
- (handle-exceptions
- exn
- (begin
- (debug:print 0 "Failed to bind to port " p ", trying next port")
- (debug:print 0 " EXCEPTION: " ((condition-property-accessor 'exn 'message) exn))
- ;; (old-handler)
- ;; (print-call-chain)
- (if (> trynum 0)
- (zmq-transport:find-free-port-and-open iface s (+ p 1) trynum: (- trynum 1))
- (debug:print-info 0 "Tried ports up to " p
- " but all were in use. Please try a different port range by starting the server with parameter \" -port N\" where N is the starting port number to use"))
- (exit)) ;; To exit or not? That is the question.
- (let ((zmq-url (conc "tcp://" iface ":" p)))
- (debug:print 2 "Trying to start server on " zmq-url)
- (bind-socket s zmq-url)
- (list iface s port)))))
-
-(define (zmq-transport:setup-ports ipaddrstr startport)
- (let* ((s1 (zmq-transport:find-free-port-and-open ipaddrstr #f startport 'pull))
- (p1 (caddr s1))
- (s2 (zmq-transport:find-free-port-and-open ipaddrstr #f (+ 1 (if p1 p1 (+ startport 1))) 'pub))
- (p2 (caddr s2)))
- (set! *runremote* #f)
- (debug:print 0 "Server started on " ipaddrstr " ports " p1 " and " p2)
- (mutex-lock! *heartbeat-mutex*)
- (set! *server-info* (open-run-close tasks:server-register
- tasks:open-db
- (current-process-id)
- ipaddrstr p1
- 0
- 'live
- 'zmq
- pubport: p2))
- (debug:print-info 11 "*server-info* set to " *server-info*)
- (mutex-unlock! *heartbeat-mutex*)
- (list s1 s2)))
-
-(define (zmq-transport:mk-signature)
- (message-digest-string (md5-primitive)
- (with-output-to-string
- (lambda ()
- (write (list (current-directory)
- (argv)))))))
-
-;;======================================================================
-;; S E R V E R U T I L I T I E S
-;;======================================================================
-
-;;======================================================================
-;; C L I E N T S
-;;======================================================================
-
-;;
-(define (zmq-transport:client-socket-connect iface port #!key (context #f)(type 'req)(subscriptions '()))
- (debug:print-info 3 "client-connect " iface ":" port ", type=" type ", subscriptions=" subscriptions)
- (let ((connect-ok #f)
- (zmq-socket (if context
- (make-socket type context)
- (make-socket type)))
- (conurl (zmq-transport:make-server-url (list iface port))))
- (if (socket? zmq-socket)
- (begin
- ;; first apply subscriptions
- (for-each (lambda (subscription)
- (debug:print 2 "Subscribing to " subscription)
- (socket-option-set! zmq-socket 'subscribe subscription))
- subscriptions)
- (connect-socket zmq-socket conurl)
- zmq-socket)
- (begin
- (debug:print 0 "ERROR: Failed to open socket to " conurl)
- #f))))
-
-(define (zmq-transport:client-connect iface pullport pubport)
- (let* ((push-socket (zmq-transport:client-socket-connect iface pullport type: 'push))
- (sub-socket (zmq-transport:client-socket-connect iface pubport
- type: 'sub
- subscriptions: (list (client:get-signature) "all")))
- (zmq-sockets (vector push-socket sub-socket))
- (login-res #f))
- (debug:print-info 11 "zmq-transport:client-connect started. Next is login")
- (set! login-res (client:login serverdat zmq-sockets))
- (if (and (not (null? login-res))
- (car login-res))
- (begin
- (debug:print-info 2 "Logged in and connected to " iface ":" pullport "/" pubport ".")
- (set! *runremote* zmq-sockets)
- zmq-sockets)
- (begin
- (debug:print-info 2 "Failed to login or connect to " conurl)
- (set! *runremote* #f)
- #f))))
-
-;; run zmq-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 (zmq-transport:keep-running)
- ;; if none running or if > 20 seconds since
- ;; server last used then start shutdown
- ;; This thread waits for the server to come alive
- (let* ((server-info (let loop ()
- (let ((sdat #f))
- (mutex-lock! *heartbeat-mutex*)
- (set! sdat *runremote*)
- (mutex-unlock! *heartbeat-mutex*)
- (if sdat sdat
- (begin
- (sleep 4)
- (loop))))))
- (iface (car server-info))
- (port (cadr server-info))
- (last-access 0)
- (tdb (tasks:open-db))
- (spid (tasks:server-get-server-id tdb #f iface port #f)))
- (print "Keep-running got server pid " spid ", using iface " iface " and port " port)
- (let loop ((count 0))
- (thread-sleep! 4) ;; no need to do this very often
- ;; NB// sync currently does NOT return queue-length
- (let () ;; (queue-len (cdb:client-call server-info 'sync #t 1)))
- ;; (print "Server running, count is " count)
- (if (< count 1) ;; 3x3 = 9 secs aprox
- (loop (+ count 1)))
-
- ;; NOTE: Get rid of this mechanism! It really is not needed...
- (tasks:server-update-heartbeat tdb spid)
-
- ;; (if ;; (or (> numrunning 0) ;; stay alive for two days after last access
- (mutex-lock! *heartbeat-mutex*)
- (set! last-access *last-db-access*)
- (mutex-unlock! *heartbeat-mutex*)
- (if (> (+ last-access
- ;; (* 50 60 60) ;; 48 hrs
- ;; 60 ;; one minute
- ;; (* 60 60) ;; one hour
- (* 45 60) ;; 45 minutes, until the db deletion bug is fixed.
- )
- (current-seconds))
- (begin
- (debug:print-info 2 "Server continuing, seconds since last db access: " (- (current-seconds) last-access))
- (loop 0))
- (begin
- (debug:print-info 0 "Starting to shutdown the server.")
- ;; need to delete only *my* server entry (future use)
- (set! *time-to-exit* #t)
- (tasks:server-deregister-self tdb (get-host-name))
- (thread-sleep! 1)
- (debug:print-info 0 "Max cached queries was " *max-cache-size*)
- (debug:print-info 0 "Server shutdown complete. Exiting")
- (exit)))))))
-
-;; all routes though here end in exit ...
-(define (zmq-transport:launch)
- (if (not *toppath*)
- (if (not (setup-for-run))
- (begin
- (debug:print 0 "ERROR: cannot find megatest.config, exiting")
- (exit))))
- (debug:print-info 2 "Starting zmq server")
- (if *toppath*
- (let* (;; (th1 (make-thread (lambda ()
- ;; (let ((server-info #f))
- ;; ;; wait for the server to be online and available
- ;; (let loop ()
- ;; (debug:print-info 2 "Waiting for the server to come online before starting heartbeat")
- ;; (thread-sleep! 2)
- ;; (mutex-lock! *heartbeat-mutex*)
- ;; (set! server-info *server-info* )
- ;; (mutex-unlock! *heartbeat-mutex*)
- ;; (if (not server-info)(loop)))
- ;; (debug:print 2 "Server alive, starting self-ping")
- ;; (zmq-transport:self-ping server-info)
- ;; ))
- ;; "Self ping"))
- (th2 (make-thread (lambda ()
- (zmq-transport:run
- (if (args:get-arg "-server")
- (args:get-arg "-server")
- "-"))) "Server run"))
- ;; (th3 (make-thread (lambda ()(zmq-transport:keep-running)) "Keep running"))
- )
- (set! *client-non-blocking-mode* #t)
- ;; (thread-start! th1)
- (thread-start! th2)
- ;; (thread-start! th3)
- (set! *didsomething* #t)
- ;; (thread-join! th3)
- (thread-join! th2)
- )
- (debug:print 0 "ERROR: Failed to setup for megatest")))
-
-(define (zmq-transport:client-signal-handler signum)
- (handle-exceptions
- exn
- (debug:print " ... exiting ...")
- (let ((th1 (make-thread (lambda ()
- (if (not *received-response*)
- (receive-message* *runremote*))) ;; flush out last call if applicable
- "eat response"))
- (th2 (make-thread (lambda ()
- (debug:print 0 "ERROR: Received ^C, attempting clean exit. Please be patient and wait a few seconds before hitting ^C again.")
- (thread-sleep! 3) ;; give the flush three seconds to do it's stuff
- (debug:print 0 " Done.")
- (exit 4))
- "exit on ^C timer")))
- (thread-start! th2)
- (thread-start! th1)
- (thread-join! th2))))
-
-(define (zmq-transport:client-launch)
- (set-signal-handler! signal/int zmq-transport:client-signal-handler)
- (if (zmq-transport:client-setup)
- (debug:print-info 2 "connected as client")
- (begin
- (debug:print 0 "ERROR: Failed to connect as client")
- (exit))))
-
-;;======================================================================
-;; Defunct functions
-;;======================================================================
-
-;; ping a server and return number of clients or #f (if no response)
-;; NOT IN USE!
-(define (zmq-transport:ping host port #!key (secs 10)(return-socket #f))
- (cdb:use-non-blocking-mode
- (lambda ()
- (let* ((res #f)
- (th1 (make-thread
- (lambda ()
- (let* ((zmq-context (make-context 1))
- (zmq-socket (zmq-transport:client-connect host port context: zmq-context)))
- (if zmq-socket
- (if (zmq-transport:client-login zmq-socket)
- (let ((numclients (cdb:num-clients zmq-socket)))
- (if (not return-socket)
- (begin
- (zmq-transport:client-logout zmq-socket)
- (close-socket zmq-socket)))
- (set! res (list #t numclients (if return-socket zmq-socket #f))))
- (begin
- ;; (close-socket zmq-socket)
- (set! res (list #f "CAN'T LOGIN" #f))))
- (set! res (list #f "CAN'T CONNECT" #f)))))
- "Ping: th1"))
- (th2 (make-thread
- (lambda ()
- (let loop ((count 1))
- (debug:print-info 1 "Ping " count " server on " host " at port " port)
- (thread-sleep! 2)
- (if (< count (/ secs 2))
- (loop (+ count 1))))
- ;; (thread-terminate! th1)
- (set! res (list #f "TIMED OUT" #f)))
- "Ping: th2")))
- (thread-start! th2)
- (thread-start! th1)
- (handle-exceptions
- exn
- (set! res (list #f "TIMED OUT" #f))
- (thread-join! th1 secs))
- res))))
-
-;; (define (zmq-transport:self-ping server-info)
-;; ;; server-info: server-id interface pullport pubport
-;; (let ((iface (list-ref server-info 1))
-;; (pullport (list-ref server-info 2))
-;; (pubport (list-ref server-info 3)))
-;; (zmq-transport:client-connect iface pullport pubport)
-;; (let loop ()
-;; (thread-sleep! 2)
-;; (cdb:client-call *runremote* 'ping #t)
-;; (debug:print 4 "zmq-transport:self-ping - I'm alive on " iface ":" pullport "/" pubport "!")
-;; (mutex-lock! *heartbeat-mutex*)
-;; (set! *server-loop-heart-beat* (current-seconds))
-;; (mutex-unlock! *heartbeat-mutex*)
-;; (loop))))
-
-(define (zmq-transport:reply pubsock target query-sig success/fail result)
- (debug:print-info 11 "zmq-transport:reply target=" target ", result=" result)
- (send-message pubsock target send-more: #t)
- (send-message pubsock (db:obj->string (vector success/fail query-sig result))))
-