Index: Makefile
==================================================================
--- Makefile
+++ Makefile
@@ -163,10 +163,15 @@
chmod a+x $@
deploytarg/nbfind : utils/nbfind
$(INSTALL) $< $@
chmod a+x $@
+
+$(PREFIX)/bin/mtest-reaper: helpers/mtest-reaper.scm helpers/ducttape-lib.scm helpers/inteldate.scm helpers/mimetypes.scm
+ make -C helpers $@ PREFIX=$(PREFIX) INSTALL=$(INSTALL) ARCHSTR=$(ARCHSTR)
+
+mtest-reaper: $(PREFIX)/bin/mtest-reaper
# install dashboard as dboard so wrapper script can be called dashboard
$(PREFIX)/bin/.$(ARCHSTR)/dboard : dboard $(FILES) utils/mk_wrapper
utils/mk_wrapper $(PREFIX) dboard $(PREFIX)/bin/dashboard
chmod a+x $(PREFIX)/bin/dashboard
@@ -177,10 +182,11 @@
$(PREFIX)/bin/nbfind $(PREFIX)/bin/loadrunner $(PREFIX)/bin/viewscreen $(PREFIX)/bin/mt_xterm \
$(PREFIX)/share/docs/megatest_manual.html $(PREFIX)/bin/remrun
$(PREFIX)/bin/.$(ARCHSTR) :
mkdir -p $(PREFIX)/bin/.$(ARCHSTR)
+ mkdir -p $(PREFIX)/bin/.$(ARCHSTR)/lib
test: tests/tests.scm
cd tests;csi -I .. -b -n tests.scm
ext-tests/.fslckout : $(MTQA_FOSSIL)
@@ -282,5 +288,6 @@
echo "(use postgresql)(hash-table-set! *available-db* 'postgresql #t)" >> altdb.scm;\
fi
portlogger-example : portlogger-example.scm api.o archive.o client.o common.o configf.o daemon.o dashboard-tests.o db.o dcommon.o ezsteps.o filedb.o genexample.o gutils.o http-transport.o items.o keys.o launch.o lock-queue.o margs.o megatest-version.o mt.o ods.o portlogger.o process.o rmt.o rpc-transport.o runconfig.o runs.o sdb.o server.o synchash.o tasks.o tdb.o tests.o tree.o
csc $(CSCOPTS) portlogger-example.scm api.o archive.o client.o common.o configf.o daemon.o dashboard-tests.o db.o dcommon.o ezsteps.o filedb.o genexample.o gutils.o http-transport.o items.o keys.o launch.o lock-queue.o margs.o megatest-version.o mt.o ods.o portlogger.o process.o rmt.o rpc-transport.o runconfig.o runs.o sdb.o server.o synchash.o tasks.o tdb.o tests.o tree.o
+
Index: api.scm
==================================================================
--- api.scm
+++ api.scm
@@ -6,10 +6,12 @@
;;
;; This program is distributed WITHOUT ANY WARRANTY; without even the
;; implied warranty of MERCHANTABILITY or FITNESS FOR A PARTICULAR
;; PURPOSE.
;;======================================================================
+
+(use srfi-69 posix)
(declare (unit api))
(declare (uses rmt))
(declare (uses db))
(declare (uses tasks))
@@ -39,10 +41,11 @@
get-run-status
get-run-stats
get-targets
get-target
;; register-run
+ get-tests-tags
get-tests-for-run
get-test-id
get-tests-for-runs-mindata
get-run-name-from-id
get-runs
@@ -61,21 +64,23 @@
synchash-get
))
(define api:write-queries
'(
+ get-keys-write ;; dummy "write" query to force server start
+
;; SERVERS
start-server
kill-server
;; TESTS
test-set-state-status-by-id
delete-test-records
delete-old-deleted-test-records
- test-set-status-state
+ test-set-state-status
test-set-top-process-pid
- roll-up-pass-fail-counts
+ set-state-status-and-roll-up-items
update-pass-fail-counts
top-test-set-per-pf-counts ;; (db:top-test-set-per-pf-counts (db:get-db *db* 5) 5 "runfirst")
;; RUNS
register-run
@@ -111,169 +116,179 @@
;;
(define (api:execute-requests dbstruct dat)
(handle-exceptions
exn
(let ((call-chain (get-call-chain)))
+ (debug:print 0 *default-log-port* "WARNING: api:execute-requests received an exception from peer")
(print-call-chain (current-error-port))
(debug:print 0 *default-log-port* " message: " ((condition-property-accessor 'exn 'message) exn))
(vector #f (vector exn call-chain dat))) ;; return some stuff for debug if an exception happens
(if (not (vector? dat)) ;; it is an error to not receive a vector
(vector #f #f "remote must be called with a vector")
(vector ;; return a vector + the returned data structure
#t
- (let ((cmd (vector-ref dat 0))
- (params (vector-ref dat 1)))
- (case (if (symbol? cmd)
- cmd
- (string->symbol cmd))
-
- ;;===============================================
- ;; READ/WRITE QUERIES
- ;;===============================================
-
- ;; SERVERS
- ((start-server) (apply server:kind-run params))
- ((kill-server) (set! *server-run* #f))
-
- ;; TESTS
- ((test-set-state-status-by-id) (apply db:test-set-state-status-by-id 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))
- ((test-set-top-process-pid) (apply db:test-set-top-process-pid dbstruct params))
- ((roll-up-pass-fail-counts) (apply db:roll-up-pass-fail-counts dbstruct params))
- ;; ((update-pass-fail-counts) (apply db:general-call dbstruct 'update-pass-fail-counts params))
- ((top-test-set-per-pf-counts) (apply db:top-test-set-per-pf-counts dbstruct params))
- ((test-set-archive-block-id) (apply db:test-set-archive-block-id dbstruct params))
-
- ;; RUNS
- ((register-run) (apply db:register-run dbstruct params))
- ((set-tests-state-status) (apply db:set-tests-state-status dbstruct params))
- ((delete-run) (apply db:delete-run dbstruct params))
- ((lock/unlock-run) (apply db:lock/unlock-run dbstruct params))
- ((update-run-event_time) (apply db:update-run-event_time dbstruct params))
- ((update-run-stats) (apply db:update-run-stats dbstruct params))
- ((set-var) (apply db:set-var 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))
-
- ;; MISC
- ((sync-inmem->db) (let ((run-id (car params)))
- (db:sync-touched dbstruct run-id force-sync: #t)))
- ((mark-incomplete) (apply db:find-and-mark-incomplete dbstruct params))
-
- ;; TESTMETA
- ((testmeta-add-record) (apply db:testmeta-add-record dbstruct params))
- ((testmeta-update-field) (apply db:testmeta-update-field dbstruct params))
-
- ;; TASKS
- ((tasks-add) (apply tasks:add dbstruct params))
- ((tasks-set-state-given-param-key) (apply tasks:set-state-given-param-key dbstruct params))
- ((tasks-get-last) (apply tasks:get-last dbstruct params))
-
- ;; ARCHIVES
- ;; ((archive-get-allocations)
- ((archive-register-disk) (apply db:archive-register-disk dbstruct params))
- ((archive-register-block-name)(apply db:archive-register-block-name dbstruct params))
- ((archive-allocate-testsuite/area-to-block)(apply db:archive-allocate-testsuite/area-to-block dbstruct block-id testsuite-name areakey))
-
- ;;======================================================================
- ;; READ ONLY QUERIES
- ;;======================================================================
-
- ;; KEYS
- ((get-key-val-pairs) (apply db:get-key-val-pairs dbstruct params))
- ((get-keys) (db:get-keys dbstruct))
- ((get-key-vals) (apply db:get-key-vals dbstruct params))
- ((get-target) (apply db:get-target dbstruct params))
- ((get-targets) (db:get-targets dbstruct))
-
- ;; ARCHIVES
- ((test-get-archive-block-info) (apply db:test-get-archive-block-info dbstruct params))
-
- ;; TESTS
- ((test-toplevel-num-items) (apply db:test-toplevel-num-items dbstruct params))
- ((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))
- ((get-count-tests-running-for-testname) (apply db:get-count-tests-running-for-testname 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-step-records) (apply db:delete-test-step-records 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-top-process-pid) (apply db:test-get-top-process-pid 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))
- ((get-count-tests-running-for-run-id) (apply db:get-count-tests-running-for-run-id dbstruct params))
- ((synchash-get) (apply synchash:server-get dbstruct params))
- ((get-raw-run-stats) (apply db:get-raw-run-stats dbstruct params))
-
- ;; RUNS
- ((get-run-info) (apply db:get-run-info dbstruct params))
- ((get-run-status) (apply db:get-run-status dbstruct params))
- ((set-run-status) (apply db:set-run-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-run-mindata) (apply db:get-tests-for-run-mindata dbstruct params))
- ((get-runs) (apply db:get-runs dbstruct params))
- ((get-num-runs) (apply db:get-num-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))
- ((get-run-name-from-id) (apply db:get-run-name-from-id dbstruct params))
- ((get-main-run-stats) (apply db:get-main-run-stats dbstruct params))
- ((get-var) (apply db:get-var dbstruct params))
- ((get-run-stats) (apply db:get-run-stats dbstruct params))
-
- ;; STEPS
- ((get-steps-data) (apply db:get-steps-data dbstruct params))
- ((get-steps-for-test) (apply db:get-steps-for-test dbstruct params))
-
- ;; TEST DATA
- ((read-test-data) (apply db:read-test-data dbstruct params))
-
- ;; MISC
- ((have-incompletes?) (apply db:have-incompletes? dbstruct params))
- ((login) (apply db:login dbstruct params))
- ((general-call) (let ((stmtname (car params))
- (run-id (cadr params))
- (realparams (cddr params)))
- (db:with-db dbstruct run-id #t ;; these are all for modifying the db
- (lambda (db)
- (db:general-call db stmtname realparams)))))
- ((sdb-qry) (apply sdb:qry params))
- ((ping) (current-process-id))
-
- ;; TESTMETA
- ((testmeta-get-record) (apply db:testmeta-get-record dbstruct params))
-
- ;; TASKS
- ((find-task-queue-records) (apply tasks:find-task-queue-records dbstruct params))))))))
-
+ (let* ((cmd-in (vector-ref dat 0))
+ (cmd (if (symbol? cmd-in)
+ cmd-in
+ (string->symbol cmd-in)))
+ (params (vector-ref dat 1))
+ (start-t (current-milliseconds))
+ (res
+ (case cmd
+ ;;===============================================
+ ;; READ/WRITE QUERIES
+ ;;===============================================
+
+ ;; SERVERS
+ ((start-server) (apply server:kind-run params))
+ ((kill-server) (set! *server-run* #f))
+
+ ;; TESTS
+ ((test-set-state-status-by-id) (apply db:test-set-state-status-by-id 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-state-status) (apply db:test-set-state-status dbstruct params))
+ ((test-set-top-process-pid) (apply db:test-set-top-process-pid dbstruct params))
+ ((set-state-status-and-roll-up-items) (apply db:set-state-status-and-roll-up-items dbstruct params))
+ ((top-test-set-per-pf-counts) (apply db:top-test-set-per-pf-counts dbstruct params))
+ ((test-set-archive-block-id) (apply db:test-set-archive-block-id dbstruct params))
+
+ ;; RUNS
+ ((register-run) (apply db:register-run dbstruct params))
+ ((set-tests-state-status) (apply db:set-tests-state-status dbstruct params))
+ ((delete-run) (apply db:delete-run dbstruct params))
+ ((lock/unlock-run) (apply db:lock/unlock-run dbstruct params))
+ ((update-run-event_time) (apply db:update-run-event_time dbstruct params))
+ ((update-run-stats) (apply db:update-run-stats dbstruct params))
+ ((set-var) (apply db:set-var 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))
+
+ ;; MISC
+ ((sync-inmem->db) (let ((run-id (car params)))
+ (db:sync-touched dbstruct run-id force-sync: #t)))
+ ((mark-incomplete) (apply db:find-and-mark-incomplete dbstruct params))
+
+ ;; TESTMETA
+ ((testmeta-add-record) (apply db:testmeta-add-record dbstruct params))
+ ((testmeta-update-field) (apply db:testmeta-update-field dbstruct params))
+ ((get-tests-tags) (db:get-tests-tags dbstruct))
+
+ ;; TASKS
+ ((tasks-add) (apply tasks:add dbstruct params))
+ ((tasks-set-state-given-param-key) (apply tasks:set-state-given-param-key dbstruct params))
+ ((tasks-get-last) (apply tasks:get-last dbstruct params))
+
+ ;; ARCHIVES
+ ;; ((archive-get-allocations)
+ ((archive-register-disk) (apply db:archive-register-disk dbstruct params))
+ ((archive-register-block-name)(apply db:archive-register-block-name dbstruct params))
+ ((archive-allocate-testsuite/area-to-block)(apply db:archive-allocate-testsuite/area-to-block dbstruct block-id testsuite-name areakey))
+
+ ;;======================================================================
+ ;; READ ONLY QUERIES
+ ;;======================================================================
+
+ ;; KEYS
+ ((get-key-val-pairs) (apply db:get-key-val-pairs dbstruct params))
+ ((get-keys) (db:get-keys dbstruct))
+ ((get-keys-write) (db:get-keys dbstruct)) ;; force a dummy "write" query to force server
+ ((get-key-vals) (apply db:get-key-vals dbstruct params))
+ ((get-target) (apply db:get-target dbstruct params))
+ ((get-targets) (db:get-targets dbstruct))
+
+ ;; ARCHIVES
+ ((test-get-archive-block-info) (apply db:test-get-archive-block-info dbstruct params))
+
+ ;; TESTS
+ ((test-toplevel-num-items) (apply db:test-toplevel-num-items dbstruct params))
+ ((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))
+ ((get-count-tests-running-for-testname) (apply db:get-count-tests-running-for-testname 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-step-records) (apply db:delete-test-step-records 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-top-process-pid) (apply db:test-get-top-process-pid 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))
+ ((get-count-tests-running-for-run-id) (apply db:get-count-tests-running-for-run-id dbstruct params))
+ ((synchash-get) (apply synchash:server-get dbstruct params))
+ ((get-raw-run-stats) (apply db:get-raw-run-stats dbstruct params))
+
+ ;; RUNS
+ ((get-run-info) (apply db:get-run-info dbstruct params))
+ ((get-run-status) (apply db:get-run-status dbstruct params))
+ ((set-run-status) (apply db:set-run-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-run-mindata) (apply db:get-tests-for-run-mindata dbstruct params))
+ ((get-runs) (apply db:get-runs dbstruct params))
+ ((get-num-runs) (apply db:get-num-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))
+ ((get-run-name-from-id) (apply db:get-run-name-from-id dbstruct params))
+ ((get-main-run-stats) (apply db:get-main-run-stats dbstruct params))
+ ((get-var) (apply db:get-var dbstruct params))
+ ((get-run-stats) (apply db:get-run-stats dbstruct params))
+
+ ;; STEPS
+ ((get-steps-data) (apply db:get-steps-data dbstruct params))
+ ((get-steps-for-test) (apply db:get-steps-for-test dbstruct params))
+
+ ;; TEST DATA
+ ((read-test-data) (apply db:read-test-data dbstruct params))
+
+ ;; MISC
+ ((get-latest-host-load) (apply db:get-latest-host-load dbstruct params))
+ ((have-incompletes?) (apply db:have-incompletes? dbstruct params))
+ ((login) (apply db:login dbstruct params))
+ ((general-call) (let ((stmtname (car params))
+ (run-id (cadr params))
+ (realparams (cddr params)))
+ (db:general-call dbstruct stmtname realparams)))
+ ((sdb-qry) (apply sdb:qry params))
+ ((ping) (current-process-id))
+
+ ;; TESTMETA
+ ((testmeta-get-record) (apply db:testmeta-get-record dbstruct params))
+
+ ;; TASKS
+ ((find-task-queue-records) (apply tasks:find-task-queue-records dbstruct params)))))
+ (let ((delta-t (- (current-milliseconds)
+ start-t)))
+ (hash-table-set! *db-api-call-time* cmd
+ (cons delta-t (hash-table-ref/default *db-api-call-time* cmd '()))))
+ res)))))
;; 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
+ (set! *api-process-request-count* (+ *api-process-request-count* 1))
(let* ((cmd ($ 'cmd))
(paramsj ($ 'params))
(params (db:string->obj paramsj transport: 'http)) ;; (rmt:json-str->dat paramsj))
(resdat (api:execute-requests dbstruct (vector cmd params))) ;; #( flag result )
(res (vector-ref resdat 1)))
-
+ (if (> *api-process-request-count* *max-api-process-requests*)
+ (set! *max-api-process-requests* *api-process-request-count*))
+ (set! *api-process-request-count* (- *api-process-request-count* 1))
;; 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)
Index: client.scm
==================================================================
--- client.scm
+++ client.scm
@@ -197,19 +197,19 @@
(tasks:hostinfo-get-port server-dat)
" client:setup (server-dat = #t)")
(if (> remaining-tries 8)
(thread-sleep! (+ 1 (random 5))) ;; spread out the starts a little
(thread-sleep! (+ 15 (random 20)))) ;; it isn't going well. give it plenty of time
- (server:try-running run-id)
+ (server:try-running *toppath*)
(thread-sleep! 5) ;; give server a little time to start up
(client:setup run-id remaining-tries: (- remaining-tries 1))
)))
(begin ;; no server registered
(let ((num-available (tasks:num-in-available-state (db:dbdat-get-db tdbdat) run-id)))
(debug:print-info 0 *default-log-port* "client:setup, no server registered, remaining-tries=" remaining-tries " num-available=" num-available)
(if (< num-available 2)
- (server:try-running run-id))
+ (server:try-running *toppath*))
(thread-sleep! (+ 5 (random (- 20 remaining-tries)))) ;; give server a little time to start up, randomize a little to avoid start storms.
(client:setup run-id remaining-tries: (- remaining-tries 1)))))))))
;; keep this as a function to ease future
(define (client:start run-id server-info)
Index: common.scm
==================================================================
--- common.scm
+++ common.scm
@@ -7,11 +7,11 @@
;; This program is distributed WITHOUT ANY WARRANTY; without even the
;; implied warranty of MERCHANTABILITY or FITNESS FOR A PARTICULAR
;; PURPOSE.
;;======================================================================
-(use srfi-1 posix regex-case base64 format dot-locking csv-xml z3 sql-de-lite hostinfo md5 message-digest typed-records directory-utils)
+(use srfi-1 posix regex-case base64 format dot-locking csv-xml z3 sql-de-lite hostinfo md5 message-digest typed-records directory-utils stack)
(require-extension regex posix)
(require-extension (srfi 18) extras tcp rpc)
(import (prefix sqlite3 sqlite3:))
@@ -90,19 +90,21 @@
(define *db-stats-mutex* (make-mutex))
;; db access
(define *db-last-access* (current-seconds)) ;; last db access, used in server
(define *db-write-access* #t)
;; db sync
-(define *db-last-write* 0) ;; used to record last touch of db
(define *db-last-sync* 0) ;; last time the sync to megatest.db happened
(define *db-sync-in-progress* #f) ;; if there is a sync in progress do not try to start another
-(define *db-multi-sync-mutex* (make-mutex)) ;; protect access to *db-sync-in-progress*, *db-last-sync* and *db-last-write*
+(define *db-multi-sync-mutex* (make-mutex)) ;; protect access to *db-sync-in-progress*, *db-last-sync*
;; task db
(define *task-db* #f) ;; (vector db path-to-db)
(define *db-access-allowed* #t) ;; flag to allow access
(define *db-access-mutex* (make-mutex))
+(define *db-transaction-mutex* (make-mutex))
(define *db-cache-path* #f)
+(define *db-with-db-mutex* (make-mutex))
+(define *db-api-call-time* (make-hash-table)) ;; hash of command => (list of times)
;; SERVER
(define *my-client-signature* #f)
(define *transport-type* 'http) ;; override with [server] transport http|rpc|nmsg
(define *runremote* #f) ;; if set up for server communication this will hold <host port>
@@ -115,10 +117,12 @@
(define *run-id* #f)
(define *server-kind-run* (make-hash-table))
(define *home-host* #f)
(define *total-non-write-delay* 0)
(define *heartbeat-mutex* (make-mutex))
+(define *api-process-request-count* 0)
+(define *max-api-process-requests* 0)
;; client
(define *rmt-mutex* (make-mutex)) ;; remote access calls mutex
;; RPC transport
@@ -135,10 +139,18 @@
(define *run-info-cache* (make-hash-table)) ;; run info is stable, no need to reget
(define *launch-setup-mutex* (make-mutex)) ;; need to be able to call launch:setup often so mutex it and re-call the real deal only if *toppath* not set
(define *homehost-mutex* (make-mutex))
+(defstruct remote
+ (hh-dat (common:get-homehost)) ;; homehost record ( addr . hhflag )
+ (server-url (if *toppath* (server:read-dotserver->url *toppath*))) ;; (server:check-if-running *toppath*) #f))
+ (last-server-check 0) ;; last time we checked to see if the server was alive
+ (conndat #f)
+ (transport *transport-type*)
+ (server-timeout (or (server:get-timeout) 100))) ;; default to 100 seconds
+
;; launching and hosts
(defstruct host
(reachable #f)
(last-update 0)
(last-used 0)
@@ -531,47 +543,59 @@
;;======================================================================
;; E X I T H A N D L I N G
;;======================================================================
(define (common:run-sync?)
- (let ((ohh (common:on-homehost?))
- (srv (args:get-arg "-server")))
- ;; (debug:print-info 0 *default-log-port* "common:run-sync? ohh=" ohh ", srv=" srv)
(and (common:on-homehost?)
- (args:get-arg "-server"))))
+ (args:get-arg "-server")))
+
+;; (let ((ohh (common:on-homehost?))
+;; (srv (args:get-arg "-server")))
+;; (and ohh srv)))
+ ;; (debug:print-info 0 *default-log-port* "common:run-sync? ohh=" ohh ", srv=" srv)
;;;; run-ids
;; if #f use *db-local-sync* : or 'local-sync-flags
;; if #t use timestamps : or 'timestamps
(define (common:sync-to-megatest.db dbstruct)
(let ((start-time (current-seconds))
(res (db:multi-db-sync dbstruct 'new2old)))
(let ((sync-time (- (current-seconds) start-time)))
- (debug:print-info 3 *default-log-port* "Sync of newdb to olddb completed in " sync-time " seconds")
+ (debug:print-info 3 *default-log-port* "Sync of newdb to olddb completed in " sync-time " seconds pid="(current-process-id))
(if (common:low-noise-print 30 "sync new to old")
- (debug:print-info 0 *default-log-port* "Sync of newdb to olddb completed in " sync-time " seconds")))
+ (debug:print-info 0 *default-log-port* "Sync of newdb to olddb completed in " sync-time " seconds pid="(current-process-id))))
res))
+
+
+
+(define *wdnum* 0)
+(define *wdnum*mutex (make-mutex))
;; currently the primary job of the watchdog is to run the sync back to megatest.db from the db in /tmp
;; if we are on the homehost and we are a server (by definition we are on the homehost if we are a server)
;;
(define (common:watchdog)
+
(thread-sleep! 0.05) ;; delay for startup
(let ((legacy-sync (common:run-sync?))
(debug-mode (debug:debug-mode 1))
- (last-time (current-seconds)))
- (debug:print-info 0 *default-log-port* "watchdog starting. legacy-sync is " legacy-sync)
- (if legacy-sync
+ (last-time (current-seconds))
+ (this-wd-num (begin (mutex-lock! *wdnum*mutex) (let ((x *wdnum*)) (set! *wdnum* (add1 *wdnum*)) (mutex-unlock! *wdnum*mutex) x)))
+ )
+ (debug:print-info 0 *default-log-port* "watchdog starting. legacy-sync is " legacy-sync" pid="(current-process-id)" this-wd-num="this-wd-num)
+ (if (and legacy-sync (not *time-to-exit*))
(let ((dbstruct (db:setup)))
(debug:print-info 0 *default-log-port* "Server running, periodic sync started.")
(let loop ()
+ ;;(BB> "watchdog loop. pid="(current-process-id)" this-wd-num="this-wd-num" *time-to-exit*="*time-to-exit*)
;; sync for filesystem local db writes
;;
(mutex-lock! *db-multi-sync-mutex*)
- (let* ((need-sync (>= *db-last-write* *db-last-sync*)) ;; no sync since last write
+ (let* ((need-sync (>= *db-last-access* *db-last-sync*)) ;; no sync since last write
(sync-in-progress *db-sync-in-progress*)
- (should-sync (> (- (current-seconds) *db-last-sync*) 5)) ;; sync every five seconds minimum
+ (should-sync (and (not *time-to-exit*)
+ (> (- (current-seconds) *db-last-sync*) 5))) ;; sync every five seconds minimum
(will-sync (and (or need-sync should-sync)
(not sync-in-progress)))
(start-time (current-seconds)))
;; (debug:print-info 0 *default-log-port* "need-sync: " need-sync " sync-in-progress: " sync-in-progress " should-sync: " should-sync " will-sync: " will-sync)
(if will-sync (set! *db-sync-in-progress* #t))
@@ -599,55 +623,71 @@
;; keep going unless time to exit
;;
(if (not *time-to-exit*)
(let delay-loop ((count 0))
+ ;;(BB> "delay-loop top; count="count" pid="(current-process-id)" this-wd-num="this-wd-num" *time-to-exit*="*time-to-exit*)
+
(if (and (not *time-to-exit*)
(< count 4)) ;; was 11, changing to 4.
(begin
(thread-sleep! 1)
(delay-loop (+ count 1))))
- (loop)))
+ (if (not *time-to-exit*) (loop))))
(if (common:low-noise-print 30)
- (debug:print-info 0 *default-log-port* "Exiting watchdog timer, *time-to-exit* = " *time-to-exit*)))))))
+ (debug:print-info 0 *default-log-port* "Exiting watchdog timer, *time-to-exit* = " *time-to-exit*" pid="(current-process-id)" this-wd-num="this-wd-num)))))))
(define (std-exit-procedure)
+ (on-exit (lambda () 0))
+ ;;(BB> "std-exit-procedure called; *time-to-exit*="*time-to-exit*)
(let ((no-hurry (if *time-to-exit* ;; hurry up
#f
(begin
(set! *time-to-exit* #t)
#t))))
(debug:print-info 4 *default-log-port* "starting exit process, finalizing databases.")
(if (and no-hurry (debug:debug-mode 18))
(rmt:print-db-stats))
(let ((th1 (make-thread (lambda () ;; thread for cleaning up, give it five seconds
- (if *dbstruct-db* (db:close-all *dbstruct-db*)) ;; one second allocated
+ (if *dbstruct-db* (db:close-all *dbstruct-db*)) ;; one second allocated
(if *task-db*
(let ((db (cdr *task-db*)))
(if (sqlite3:database? db)
(begin
(sqlite3:interrupt! db)
(sqlite3:finalize! db #t)
;; (vector-set! *task-db* 0 #f)
(set! *task-db* #f)))))
- (close-output-port *default-log-port*)
+ (if (and *runremote*
+ (remote-conndat *runremote*))
+ (begin
+ (http-client#close-all-connections!))) ;; for http-client
+ (if (not (eq? *default-log-port* (current-error-port)))
+ (close-output-port *default-log-port*))
(set! *default-log-port* (current-error-port))) "Cleanup db exit thread"))
(th2 (make-thread (lambda ()
(debug:print 4 *default-log-port* "Attempting clean exit. Please be patient and wait a few seconds...")
(if no-hurry
- (thread-sleep! 5) ;; give the clean up few seconds to do it's stuff
- (thread-sleep! 2))
- (debug:print 4 *default-log-port* " ... done")
- )
+ (begin
+ (thread-sleep! 5)) ;; give the clean up few seconds to do it's stuff
+ (begin
+ (thread-sleep! 2)))
+ (debug:print 4 *default-log-port* " ... done")
+ )
"clean exit")))
(thread-start! th1)
(thread-start! th2)
- (thread-join! th1))))
+ (thread-join! th1)
+ )
+ )
+
+ 0)
(define (std-signal-handler signum)
;; (signal-mask! signum)
(set! *time-to-exit* #t)
+ ;;(BB> "got signal "signum)
(debug:print-error 0 *default-log-port* "Received signal " signum " exiting promptly")
;; (std-exit-procedure) ;; shouldn't need this since we are exiting and it will be called anyway
(exit))
(set-signal-handler! signal/int std-signal-handler) ;; ^C
@@ -779,20 +819,24 @@
(define (common:args-get-status)
(or (args:get-arg "-status")(args:get-arg ":status")))
(define (common:args-get-testpatt rconf)
- (let* ((rtestpatt (if rconf (runconfigs-get rconf "TESTPATT") #f))
- (args-testpatt (or (args:get-arg "-testpatt")
- (args:get-arg "-runtests")
- "%"))
- (testpatt (or (and (equal? args-testpatt "%")
- rtestpatt)
- args-testpatt)))
- (if rtestpatt (debug:print-info 0 *default-log-port* "TESTPATT from runconfigs: " rtestpatt))
- testpatt))
-
+ (let* ((tagexpr (args:get-arg "-tagexpr"))
+ (tags-testpatt (if tagexpr (string-join (runs:get-tests-matching-tags tagexpr) ",") #f))
+ (testpatt-key (if (args:get-arg "-mode") (args:get-arg "-mode") "TESTPATT"))
+ (args-testpatt (or (args:get-arg "-testpatt") (args:get-arg "-runtests") "%"))
+ (rtestpatt (if rconf (runconfigs-get rconf testpatt-key) #f)))
+ (cond
+ (tags-testpatt
+ (debug:print-info 0 *default-log-port* "-tagexpr "tagexpr" selects testpatt "tags-testpatt)
+ tags-testpatt)
+ ((and (equal? args-testpatt "%") rtestpatt)
+ (debug:print-info 0 *default-log-port* "testpatt defined in "testpatt-key" from runconfigs: " rtestpatt)
+ rtestpatt)
+ (else args-testpatt))))
+
(define (common:get-linktree)
(or (getenv "MT_LINKTREE")
(if *configdat*
(configf:lookup *configdat* "setup" "linktree"))))
@@ -921,10 +965,20 @@
#f ;; better than an exception for my needs
(fold (lambda (a b)
(if (comp a b) a b))
(car lst)
lst)))
+
+;; get min or max, use > for max and < for min, this works around the limits on apply
+;;
+(define (common:sum lst)
+ (if (null? lst)
+ 0
+ (fold (lambda (a b)
+ (+ a b))
+ (car lst)
+ lst)))
;; path list to hash-table tree
;; ((a b c)(a b d)(e b c)) => ((a (b (d) (c))) (e (b (c))))
;;
(define (common:list->htree lst)
@@ -1084,11 +1138,12 @@
(lambda ()(list (read)(read)(read)))))
(with-input-from-file "/proc/loadavg"
(lambda ()(list (read)(read)(read))))))
;; get normalized cpu load by reading from /proc/loadavg and /proc/cpuinfo return all three values and the number of real cpus and the number of threads
-;; returns list (normalized-proc-load normalized-core-load 1m 5m 15m ncores nthreads)
+;; returns alist '((adj-cpu-load . normalized-proc-load) ... etc.
+;; keys: adj-proc-load, adj-core-load, 1m-load, 5m-load, 15m-load
;;
(define (common:get-normalized-cpu-load remote-host)
(let ((data (if remote-host
(with-input-from-pipe
(conc "ssh " remote-host " cat /proc/loadavg;cat /proc/cpuinfo;echo end")
@@ -1143,51 +1198,89 @@
(let ((res (system (conc "ping -c 1 " hostname " > /dev/null"))))
(eq? res 0)))
;; ideally put all this info into the db, no need to preserve it across moving homehost
;;
-(define (common:get-least-loaded-host hosts-raw)
+;; return list of
+;; ( reachable? cpuload update-time )
+(define (common:get-host-info hostname)
+ (let* ((loadinfo (rmt:get-latest-host-load hostname))
+ (load (car loadinfo))
+ (load-sample-time (cdr loadinfo))
+ (load-sample-age (- (current-seconds) load-sample-time))
+ (loadinfo-timeout-seconds 20)
+ (host-last-update-timeout-seconds 10)
+ (host-rec (hash-table-ref/default *host-loads* hostname #f))
+ )
+ (cond
+ ((< load-sample-age loadinfo-timeout-seconds)
+ (list #t
+ load-sample-time
+ load))
+ ((and host-rec
+ (< (current-seconds) (+ (host-last-update host-rec) host-last-update-timeout-seconds)))
+ (list #t
+ (host-last-update host-rec)
+ (host-last-cpuload host-rec )))
+ ((common:unix-ping hostname)
+ (list #t
+ (current-seconds)
+ (alist-ref 'adj-core-load (common:get-normalized-cpu-load hostname))))
+ (else
+ (list #f 0 -1)))))
+
+(define (common:update-host-loads-table hosts-raw)
(let* ((hosts (filter (lambda (x)
(string-match (regexp "^\\S+$") x))
hosts-raw)))
- (if (null? hosts)
- #f
- ;;
- ;; stategy:
- ;; sort by last-used and normalized-load
- ;; if last-updated > 15 seconds then re-update
- ;; take the host with the lowest load with the lowest last-used (i.e. not used for longest time)
- ;;
- (let ((best-host #f)
- (curr-time (current-seconds)))
- (for-each
- (lambda (hostname)
- (let* ((rec (let ((h (hash-table-ref/default *host-loads* hostname #f)))
- (if h
- h
- (let ((h (make-host)))
- (hash-table-set! *host-loads* hostname h)
- h))))
- ;; if host hasn't been pinged in 15 sec update it's data
- (ping-good (if (< (- curr-time (host-last-update rec)) 15)
- (host-reachable rec)
- (or (host-reachable rec)
- (begin
- (host-reachable-set! rec (common:unix-ping hostname))
- (host-last-update-set! rec curr-time)
- (host-last-cpuload-set! rec (common:get-normalized-cpu-load hostname))
- (host-reachable rec))))))
- (cond
- ((not best-host)
- (set! best-host hostname))
- ((and ping-good
- (< (alist-ref 'adj-core-load (host-last-cpuload rec))
- (alist-ref 'adj-core-load
- (host-last-cpuload (hash-table-ref *host-loads* best-host)))))
- (set! best-host hostname)))))
- hosts)
- best-host))))
+ (for-each
+ (lambda (hostname)
+ (let* ((rec (let ((h (hash-table-ref/default *host-loads* hostname #f)))
+ (if h
+ h
+ (let ((h (make-host)))
+ (hash-table-set! *host-loads* hostname h)
+ h))))
+ (host-info (common:get-host-info hostname))
+ (is-reachable (car host-info))
+ (last-reached-time (cadr host-info))
+ (load (caddr host-info)))
+ (host-reachable-set! rec is-reachable)
+ (host-last-update-set! rec last-reached-time)
+ (host-last-cpuload-set! rec load)))
+ hosts)))
+
+(define (common:get-least-loaded-host hosts-raw)
+ (let* ((hosts (filter (lambda (x)
+ (string-match (regexp "^\\S+$") x))
+ hosts-raw))
+ (best-host #f)
+ (best-load 99999)
+ (curr-time (current-seconds)))
+ (common:update-host-loads-table hosts)
+ (for-each
+ (lambda (hostname)
+ (let* ((rec
+ (let ((h (hash-table-ref/default *host-loads* hostname #f)))
+ (if h
+ h
+ (let ((h (make-host)))
+ (hash-table-set! *host-loads* hostname h)
+ h))))
+ (reachable (host-reachable rec))
+ (load (host-last-cpuload rec)))
+ (cond
+ ((not reachable) #f)
+ ((< (+ load (/ (random 250) 1000)) ;; add a random factor to keep from getting in a rut
+ (+ best-load (/ (random 250) 1000)) )
+ (set! best-load load)
+ (set! best-host hostname)))))
+ hosts)
+ best-host))
+
+
+
(define (common:wait-for-cpuload maxload numcpus waitdelay #!key (count 1000) (msg #f)(remote-host #f))
(let* ((loadavg (common:get-cpu-load remote-host))
(first (car loadavg))
(next (cadr loadavg))
Index: common_records.scm
==================================================================
--- common_records.scm
+++ common_records.scm
@@ -121,10 +121,11 @@
(db:log-event (apply conc params))
(apply print params)
)))))
;; Brandon's debug printer shortcut (indulge me :)
+(define *BB-process-starttime* (current-milliseconds))
(define (BB> . in-args)
(let* ((stack (get-call-chain))
(location #f))
(for-each
(lambda (frame)
@@ -131,12 +132,59 @@
(let* ((this-loc (vector-ref frame 0))
(this-func (cadr (string-split this-loc " "))))
(if (equal? this-func "BB>")
(set! location this-loc))))
stack)
- (let ((dp-args (append (list 0 *default-log-port* location" " ) in-args)))
+ (let ((dp-args (append (list 0 *default-log-port* (conc location "@"(/ (- (current-milliseconds) *BB-process-starttime*) 1000)" ") ) in-args)))
(apply debug:print dp-args))))
+
+(define *BBpp_custom_expanders_list* (make-hash-table))
+
+
+
+;; register hash tables with BBpp.
+(hash-table-set! *BBpp_custom_expanders_list* HASH_TABLE:
+ (cons hash-table? hash-table->alist))
+
+;; test name converter
+(define (BBpp_custom_converter arg)
+ (let ((res #f))
+ (for-each
+ (lambda (custom-type-name)
+ (let* ((custom-type-info (hash-table-ref *BBpp_custom_expanders_list* custom-type-name))
+ (custom-type-test (car custom-type-info))
+ (custom-type-converter (cdr custom-type-info)))
+ (when (and (not res) (custom-type-test arg))
+ (set! res (custom-type-converter arg)))))
+ (hash-table-keys *BBpp_custom_expanders_list*))
+ (if res (BBpp_ res) arg)))
+
+(define (BBpp_ arg)
+ (cond
+ ;;((SOMESTRUCT? arg) (cons SOMESTRUCT: (SOMESTRUCT->alist arg)))
+ ;;((dboard:tabdat? arg) (cons dboard:tabdat: (dboard:tabdat->alist arg)))
+ ((hash-table? arg)
+ (let ((al (hash-table->alist arg)))
+ (BBpp_ (cons HASH_TABLE: al))))
+ ((null? arg) '())
+ ;;((list? arg) (cons (BBpp_ (car arg)) (BBpp_ (cdr arg))))
+ ((pair? arg) (cons (BBpp_ (car arg)) (BBpp_ (cdr arg))))
+ (else (BBpp_custom_converter arg))))
+
+;; Brandon's pretty printer. It expands hashes and custom types in addition to regular pp
+(define (BBpp arg)
+ (pp (BBpp_ arg)))
+
+;(use define-macro)
+(define-syntax inspect
+ (syntax-rules ()
+ [(_ x)
+ ;; (with-output-to-port (current-error-port)
+ (printf "~a is: ~a\n" 'x (with-output-to-string (lambda () (BBpp x))))
+ ;; )
+ ]
+ [(_ x y ...) (begin (inspect x) (inspect y ...))]))
(define (debug:print-error n e . params)
;; normal print
(if (debug:debug-mode n)
(with-output-to-port (or e (current-error-port))
Index: dashboard-tests.scm
==================================================================
--- dashboard-tests.scm
+++ dashboard-tests.scm
@@ -271,13 +271,14 @@
(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)
+ ;; (rmt:test-set-state-status-by-id run-id test-id #f #f b)
+ (rmt:test-set-state-status run-id test-id #f #f b)
;; IDEA: Just set a variable with the proc to call?
- (rmt:test-set-state-status-by-id run-id 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))
@@ -287,11 +288,11 @@
(let* ((btns (map (lambda (state)
(let ((btn (iup:button state
#:expand "HORIZONTAL" #:size "50x" #:font "Courier New, -10"
#:action (lambda (x)
;; (rmt:test-set-state-status-by-id run-id test-id state #f #f)
- (rmt:roll-up-pass-fail-counts run-id test-id #f state #f #f) ;; test-name passed in as test-id is respected
+ (rmt:set-state-status-and-roll-up-items run-id test-id #f state #f #f) ;; test-name passed in as test-id is respected
(db:test-set-state! testdat state)))))
btn))
(map cadr *common:std-states*)))) ;; (list "COMPLETED" "NOT_STARTED" "RUNNING" "REMOTEHOSTSTART" "LAUNCHED" "KILLED" "KILLREQ"))))
(vector-set! *state-status* 0
(lambda (state color)
@@ -321,11 +322,11 @@
(if (not *dashboard-comment-share-slot*)
(set! *dashboard-comment-share-slot* wtxtbox)))
))))
(begin
;; (rmt:test-set-state-status-by-id run-id test-id #f status #f)
- (rmt:roll-up-pass-fail-counts run-id test-id #f #f status #f) ;; test-name passed in as test-id is respected
+ (rmt:set-state-status-and-roll-up-items run-id test-id #f #f status #f) ;; test-name passed in as test-id is respected
(db:test-set-status! testdat status))))))))
btn))
(map cadr *common:std-statuses*)))) ;; (list "PASS" "WARN" "FAIL" "CHECK" "n/a" "WAIVED" "SKIP"))))
(vector-set! *state-status* 1
(lambda (status color)
@@ -402,11 +403,12 @@
(let ((comment (iup:attribute comnt "VALUE"))
(test-id (db:test-get-id testdat)))
(if (or (not wpatt)
(string-match wregx comment))
(begin
- (rmt:test-set-state-status-by-id run-id test-id #f "WAIVED" comment)
+ ;; (rmt:test-set-state-status-by-id run-id test-id #f "WAIVED" comment)
+ (rmt:test-set-state-status-by run-id test-id #f "WAIVED" comment)
(db:test-set-status! testdat "WAIVED")
(cmtcmd comment)
(iup:destroy! dlog))))))
(iup:button "Cancel"
#:expand "HORIZONTAL"
@@ -473,11 +475,11 @@
(testconfig (begin
;; (runs:set-megatest-env-vars run-id inrunname: runname testname: test-name itempath: item-path)
(runs:set-megatest-env-vars run-id inkeyvals: keydat inrunname: runname intarget: keystring testname: testname itempath: item-path) ;; these may be needed by the launching process
(handle-exceptions
exn
- (tests:get-testconfig (db:test-get-testname testdat) test-registry #f)
+ (tests:get-testconfig (db:test-get-testname testdat) (db:test-get-item-path testdat) test-registry #f)
(tests:get-testconfig (db:test-get-testname testdat) test-registry #t))))
(viewlog (lambda (x)
(if (file-exists? logfile)
;(system (conc "firefox " logfile "&"))
(dashboard-tests:run-html-viewer logfile)
Index: dashboard.scm
==================================================================
--- dashboard.scm
+++ dashboard.scm
@@ -290,10 +290,21 @@
;; runs summary view
tests-tree ;; used in newdashboard
)
+;; register tabdat with BBpp
+;; this is used by BBpp (Brandon's pretty printer) to convert dboard:tabdat into a composition of lists that pp will handle
+(hash-table-set! *BBpp_custom_expanders_list* TABDAT:
+ (cons dboard:tabdat?
+ (lambda (tabdat-item)
+ (filter
+ (lambda (alist-entry)
+ (member (car alist-entry)
+ '(allruns-by-id allruns))) ;; FIELDS OF INTEREST
+ (dboard:tabdat->alist tabdat-item)))))
+
(define (dboard:tabdat-target-string vec)
(let ((targ (dboard:tabdat-target vec)))
(if (list? targ)(string-intersperse targ "/") "no-target-specified")))
(define (dboard:tabdat-test-patts-use vec)
@@ -360,10 +371,24 @@
((last-update 0) : fixnum) ;; last query to db got records from before last-update
((data-changed #f) : boolean)
((run-data-offset 0) : number) ;; get only 100 items per call, set back to zero when received less that 100 items
(db-path #f)
)
+
+;; register dboard:rundat with BBpp
+;; this is used by BBpp (Brandon's pretty printer) to convert dboard:rundat into a composition of lists that pp will handle
+(hash-table-set! *BBpp_custom_expanders_list* RUNDAT:
+ (cons dboard:rundat?
+ (lambda (tabdat-item)
+ (filter
+ (lambda (alist-entry)
+ (member (car alist-entry)
+ '(run run-data-offset ))) ;; FIELDS OF INTEREST
+ (dboard:rundat->alist tabdat-item)))))
+
+
+
(define (dboard:rundat-make-init #!key (run #f)(key-vals #f)(tests #f));; -100 is before time began
(make-dboard:rundat
run: run
tests: (or tests (make-hash-table))
@@ -623,10 +648,12 @@
(for-each (lambda (run)
(hash-table-set! ht (db:get-value-by-header run header "id") run))
runs-tree) ;; (vector-ref runs-dat 1))
ht))
(tb (dboard:tabdat-runs-tree tabdat)))
+ ;;(BB> "In update-rundat")
+ ;;(inspect allruns runs-hash)
(dboard:tabdat-last-runs-update-set! tabdat (- (current-seconds) 2))
(dboard:tabdat-header-set! tabdat header)
;;
;; trim runs to only those that are changing often here
;;
@@ -740,11 +767,17 @@
(run-struct (or run-struct
(dboard:rundat-make-init
run: run
tests: tests-ht
key-vals: key-vals)))
- (new-res (if (null? all-test-ids) res (cons run-struct res)))
+ (new-res (if (null? all-test-ids)
+ res
+ (delete-duplicates
+ (cons run-struct res)
+ (lambda (a b)
+ (eq? (db:get-value-by-header (dboard:rundat-run a) header "id")
+ (db:get-value-by-header (dboard:rundat-run b) header "id"))))))
(elapsed-time (- (current-seconds) start-time)))
(if (null? all-test-ids)
(hash-table-delete! (dboard:tabdat-allruns-by-id tabdat) run-id)
(hash-table-set! (dboard:tabdat-allruns-by-id tabdat) run-id run-struct))
(if (or (null? tal)
@@ -3391,10 +3424,13 @@
;;(print "RA => calling runs-tab-updater with commondat " commondat " tab-num " tab-num)
;;(tabdat-values tabdat) ;;RA added
;; (pp (dboard:tabdat->alist tabdat))
;; (if (dashboard:database-changed? commondat tabdat context-key: 'runs-rundat)
(dashboard:do-update-rundat tabdat)
+ ;;(BB> "dashboard:runs-tab-updater")
+ ;;(inspect tabdat)
+
(let ((uidat (dboard:commondat-uidat commondat)))
;;(print "RA => Calling update-buttons with tabdat : " tabdat " uidat " uidat)
(update-buttons tabdat uidat (dboard:tabdat-numruns tabdat) (dboard:tabdat-num-tests tabdat)))
))
"dashboard:runs-tab-updater"))
Index: db.scm
==================================================================
--- db.scm
+++ db.scm
@@ -13,11 +13,11 @@
;; Database access
;;======================================================================
;; dbstruct vector containing all the relevant dbs like main.db, megatest.db, run.db etc
-(require-extension (srfi 18) extras tcp) ;; RADT => use of require-extension?
+(use (srfi 18) extras tcp stack) ;; RADT => use of require-extension?
(use sqlite3 srfi-1 posix regex regex-case srfi-69 csv-xml s11n md5 message-digest base64 format dot-locking z3 typed-records)
(import (prefix sqlite3 sqlite3:))
(import (prefix base64 base64:)) ;; RADT => prefix??
(declare (unit db))
@@ -42,11 +42,12 @@
;; each db entry is a pair ( db . dbfilepath )
;; I propose this record evolves into the area record
;;
(defstruct dbr:dbstruct
- (tmpdb #f)
+ ;; (tmpdb #f)
+ (dbstack #f) ;; stack for tmp db handles, do not initialize with a stack
(mtdb #f)
(refndb #f)
(homehost #f) ;; not used yet
(on-homehost #f) ;; not used yet
) ;; goal is to converge on one struct for an area but for now it is too confusing
@@ -91,12 +92,17 @@
;; 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 . blah) ;; run-id)
- (or (dbr:dbstruct-tmpdb dbstruct)
+(define (db:get-db dbstruct) ;; run-id)
+ (if (stack? (dbr:dbstruct-dbstack dbstruct))
+ (if (stack-empty? (dbr:dbstruct-dbstack dbstruct))
+ (let ((newdb (db:open-megatest-db path: (db:dbfile-path))))
+ ;; (stack-push! (dbr:dbstruct-dbstack dbstruct) newdb)
+ newdb)
+ (stack-pop! (dbr:dbstruct-dbstack dbstruct)))
(db:open-db dbstruct)))
;; ;; legacy handling of structure for managing db's. Refactor this into dbr:?
(define (db:dbdat-get-db dbdat)
(if (pair? dbdat)
@@ -125,24 +131,35 @@
;; (db:with-db dbstruct run-id sqlite3:exec "select blah fgrom blaz;")
;; r/w is a flag to indicate if the db is modified by this query #t = yes, #f = no
;;
(define (db:with-db dbstruct run-id r/w proc . params)
- (let* ((dbdat (if (dbr:dbstruct? dbstruct)
- (db:get-db dbstruct run-id)
- (begin
- (print-call-chain)
- (print "db:with-db called with dbdat instead of dbstruct, FIXME!!")
- dbstruct))) ;; cheat, allow for passing in a dbdat
- (db (db:dbdat-get-db dbdat)))
+ (let* ((have-struct (dbr:dbstruct? dbstruct))
+ (dbdat (if have-struct
+ (db:get-db dbstruct)
+ #f))
+ (db (if have-struct
+ (db:dbdat-get-db dbdat)
+ dbstruct))
+ (use-mutex (> *api-process-request-count* 25)))
+ (if (and use-mutex
+ (common:low-noise-print 120 "over-50-parallel-api-requests"))
+ (debug:print-info 0 *default-log-port* *api-process-request-count* " parallel api requests being processed in process " (current-process-id) ", throttling access"))
+ (if (common:low-noise-print 120 (conc "parallel-api-requests" *max-api-process-requests*))
+ (debug:print-info 0 *default-log-port* "Parallel api request count: " *api-process-request-count* " max parallel requests: " *max-api-process-requests*))
(handle-exceptions
exn
(begin
+ (print-call-chain (current-error-port))
(debug:print-error 0 *default-log-port* "sqlite3 issue in db:with-db, dbstruct=" dbstruct ", run-id=" run-id ", proc=" proc ", params=" params " error: " ((condition-property-accessor 'exn 'message) exn))
- (print-call-chain (current-error-port)))
+ ;; there is no recovering at this time. exit
+ (exit 50))
+ (if use-mutex (mutex-lock! *db-with-db-mutex*))
(let ((res (apply proc db params)))
+ (if use-mutex (mutex-unlock! *db-with-db-mutex*))
;; (if (vector? dbstruct)(db:done-with dbstruct run-id r/w))
+ (if dbdat (stack-push! (dbr:dbstruct-dbstack dbstruct) dbdat))
res))))
;;======================================================================
;; K E E P F I L E D B I N dbstruct
;;======================================================================
@@ -171,30 +188,19 @@
;; (was planned to be; zeroth db with name=main.db)
;;
;; If run-id is #f return to create and retrieve the path where the db will live.
;;
(define (db:dbfile-path . junk) ;; run-id)
- (let* ((dbdir (common:get-db-tmp-area))) ;; (db:get-dbdir))
-;; (fname (if run-id
-;; (if (eq? run-id 0) "main.db" (conc run-id ".db"))
-;; #f)))
+ (let* ((dbdir (common:get-db-tmp-area)))
(handle-exceptions
exn
(begin
(debug:print-error 0 *default-log-port* "Couldn't create path to " dbdir)
(exit 1))
(if (not (directory? dbdir))(create-directory dbdir #t)))
- dbdir)) ;; (if fname
-;; (conc dbdir "/" fname)
-;; dbdir)))
-
-;; Returns the database location as specified in config file
-;;
-;; (define db:get-dbdir common:get-db-tmp-area)
-;; (or (configf:lookup *configdat* "setup" "dbdir")
-;; (conc (configf:lookup *configdat* "setup" "linktree") "/.db")))
-
+ dbdir))
+
(define (db:set-sync db)
(let ((syncprag (configf:lookup *configdat* "setup" "sychronous")))
(sqlite3:execute db (conc "PRAGMA synchronous = " (or syncprag 0) ";"))))
;; open an sql database inside a file lock
@@ -264,14 +270,13 @@
;; db))
;; This routine creates the db if not already present. It is only called if the db is not already opened
;;
(define (db:open-db dbstruct #!key (areapath #f))
- (let ((tmpdb (dbr:dbstruct-tmpdb dbstruct))) ;; RA => Returns the first reference in dbstruct
- (if tmpdb
- tmpdb
- ;; (mutex-lock! *rundb-mutex*)
+ (let ((tmpdb-stack (dbr:dbstruct-dbstack dbstruct))) ;; RA => Returns the first reference in dbstruct
+ (if (stack? tmpdb-stack)
+ (db:get-db tmpdb-stack) ;; get previously opened db (will create new db handle if all in the stack are already used
(let* ((dbpath (db:dbfile-path)) ;; 0))
(dbexists (file-exists? dbpath))
(dbfexists (file-exists? (conc dbpath "/megatest.db")))
(tmpdb (db:open-megatest-db path: dbpath)) ;; lock-create-open dbpath db:initialize-main-db))
(mtdb (db:open-megatest-db))
@@ -278,11 +283,12 @@
(refndb (db:open-megatest-db path: dbpath name: "megatest_ref.db"))
(write-access (file-write-access? dbpath)))
(if (and dbexists (not write-access))
(set! *db-write-access* #f))
(dbr:dbstruct-mtdb-set! dbstruct mtdb)
- (dbr:dbstruct-tmpdb-set! dbstruct tmpdb) ;; olddb is already a (cons db path)
+ (dbr:dbstruct-dbstack-set! dbstruct (make-stack))
+ (stack-push! (dbr:dbstruct-dbstack dbstruct) tmpdb) ;; olddb is already a (cons db path)
(dbr:dbstruct-refndb-set! dbstruct refndb)
;; (mutex-unlock! *rundb-mutex*)
(if (and (not dbfexists)
write-access) ;; *db-write-access*) ;; did not have a prior db and do have write access
(begin
@@ -324,11 +330,11 @@
(cons db dbpath)))
;; sync run to disk if touched
;;
(define (db:sync-touched dbstruct run-id #!key (force-sync #f))
- (let ((tmpdb (dbr:dbstruct-tmpdb dbstruct))
+ (let ((tmpdb (db:get-db dbstruct))
(mtdb (dbr:dbstruct-mtdb dbstruct))
(refndb (dbr:dbstruct-refndb dbstruct))
(start-t (current-seconds)))
(debug:print-info 4 *default-log-port* "Syncing for run-id: " run-id)
(mutex-lock! *db-multi-sync-mutex*)
@@ -335,21 +341,24 @@
(let ((update_info (cons (if force-sync 0 *db-last-sync*) "last_update")))
(mutex-unlock! *db-multi-sync-mutex*)
(db:sync-tables (db:sync-all-tables-list dbstruct) update_info tmpdb refndb mtdb))
(mutex-lock! *db-multi-sync-mutex*)
(set! *db-last-sync* start-t)
- (mutex-unlock! *db-multi-sync-mutex*)))
+ (set! *db-last-access* start-t)
+ (mutex-unlock! *db-multi-sync-mutex*)
+ (stack-push! (dbr:dbstruct-dbstack dbstruct) tmpdb)))
;; close all opened run-id dbs
(define (db:close-all dbstruct)
(if (dbr:dbstruct? dbstruct)
(begin
;; (db:sync-touched dbstruct 0 force-sync: #t) ;; NO. Do not do this here. Instead we rely on a server to be started when there are writes, even if the server itself is not going to be used as a server.
- (let ((tdb (db:dbdat-get-db (dbr:dbstruct-tmpdb dbstruct)))
+ (let ((tdbs (map db:dbdat-get-db
+ (stack->list (dbr:dbstruct-dbstack dbstruct))))
(mdb (db:dbdat-get-db (dbr:dbstruct-mtdb dbstruct)))
(rdb (db:dbdat-get-db (dbr:dbstruct-refndb dbstruct))))
- (if tdb (sqlite3:finalize! tdb))
+ (map sqlite3:finalize! tdbs)
(if mdb (sqlite3:finalize! mdb))
(if rdb (sqlite3:finalize! rdb))))))
;; (let ((locdbs (dbr:dbstruct-locdbs dbstruct)))
;; (if (hash-table? locdbs)
@@ -625,11 +634,11 @@
;; first pass implementation, just insert all changed rows
(for-each
(lambda (targdb)
(let* ((db (db:dbdat-get-db targdb))
(stmth (sqlite3:prepare db full-ins)))
- ;; (db:delay-if-busy targdb) ;; NO WAITING
+ (db:delay-if-busy targdb) ;; NO WAITING
(for-each
(lambda (fromdat-lst)
(sqlite3:with-transaction
db
(lambda ()
@@ -813,11 +822,11 @@
;;
(define (db:multi-db-sync dbstruct . options)
(if (not (launch:setup))
(debug:print 0 *default-log-port* "ERROR: not able to setup up for megatest.")
(let* ((mtdb (dbr:dbstruct-mtdb dbstruct))
- (tmpdb (dbr:dbstruct-tmpdb dbstruct))
+ (tmpdb (db:get-db dbstruct))
(refndb (dbr:dbstruct-refndb dbstruct))
(allow-cleanup #t) ;; (if run-ids #f #t))
(tdbdat (tasks:open-db))
(servers (tasks:get-all-servers (db:delay-if-busy tdbdat)))
(data-synced 0)) ;; count of changed records (I hope)
@@ -942,10 +951,11 @@
;; (delete-file fullname)))))
;; dead-runs))))
;;
;; (db:close-all dbstruct)
;; (sqlite3:finalize! mdb)
+ (stack-push! (dbr:dbstruct-dbstack dbstruct) tmpdb)
data-synced)))
;; keeping it around for debugging purposes only
(define (open-run-close-no-exception-handling proc idb . params)
(debug:print-info 11 *default-log-port* "open-run-close-no-exception-handling START given a db=" (if idb "yes " "no ") ", params=" params)
@@ -1138,11 +1148,11 @@
fail_count INTEGER DEFAULT 0,
pass_count INTEGER DEFAULT 0,
archived INTEGER DEFAULT 0, -- 0=no, > 1=archive block id where test data can be found
last_update INTEGER DEFAULT (strftime('%s','now')),
CONSTRAINT testsconstraint UNIQUE (run_id, testname, item_path));")
- (sqlite3:execute db "CREATE INDEX IF NOT EXISTS tests_index ON tests (run_id, testname, item_path);")
+ (sqlite3:execute db "CREATE INDEX IF NOT EXISTS tests_index ON tests (run_id, testname, item_path, uname);")
(sqlite3:execute db "CREATE TRIGGER IF NOT EXISTS update_tests_trigger AFTER UPDATE ON tests
FOR EACH ROW
BEGIN
UPDATE tests SET last_update=(strftime('%s','now'))
WHERE id=old.id;
@@ -1210,11 +1220,11 @@
;; dneeded is minimum space needed, scan for existing archives that
;; are on disks with adequate space and already have this test/itempath
;; archived
;;
(define (db:archive-get-allocations dbstruct testname itempath dneeded)
- (let* ((dbdat (db:get-db dbstruct #f)) ;; archive tables are in main.db
+ (let* ((dbdat (db:get-db dbstruct)) ;; archive tables are in main.db
(db (db:dbdat-get-db dbdat))
(res '())
(blocks '())) ;; a block is an archive chunck that can be added too if there is space
(sqlite3:for-each-row
(lambda (id archive-disk-id disk-path last-du last-du-time)
@@ -1241,11 +1251,11 @@
;; returns id of the record, register a disk allocated to archiving and record it's last known
;; available space
;;
(define (db:archive-register-disk dbstruct bdisk-name bdisk-path df)
- (let* ((dbdat (db:get-db dbstruct #f)) ;; archive tables are in main.db
+ (let* ((dbdat (db:get-db dbstruct)) ;; archive tables are in main.db
(db (db:dbdat-get-db dbdat))
(res #f))
(sqlite3:for-each-row
(lambda (id)
(set! res id))
@@ -1255,25 +1265,27 @@
(if res ;; record exists, update df and return id
(begin
(sqlite3:execute db "UPDATE archive_disks SET last_df=?,last_df_time=(strftime('%s','now'))
WHERE archive_area_name=? AND disk_path=?;"
df bdisk-name bdisk-path)
+ (stack-push! (dbr:dbstruct-dbstack dbstruct) dbdat)
res)
(begin
(sqlite3:execute
db
"INSERT OR REPLACE INTO archive_disks (archive_area_name,disk_path,last_df)
VALUES (?,?,?);"
bdisk-name bdisk-path df)
+ (stack-push! (dbr:dbstruct-dbstack dbstruct) dbdat)
(db:archive-register-disk dbstruct bdisk-name bdisk-path df)))))
;; record an archive path created on a given archive disk (identified by it's bdisk-id)
;; if path starts with / then it is full, otherwise it is relative to the archive disk
;; preference is to store the relative path.
;;
(define (db:archive-register-block-name dbstruct bdisk-id archive-path #!key (du #f))
- (let* ((dbdat (db:get-db dbstruct #f)) ;; archive tables are in main.db
+ (let* ((dbdat (db:get-db dbstruct)) ;; archive tables are in main.db
(db (db:dbdat-get-db dbdat))
(res #f))
;; first look to see if this path is already registered
(sqlite3:for-each-row
(lambda (id)
@@ -1370,62 +1382,63 @@
;;======================================================================
;; M A I N T E N A N C E
;;======================================================================
(define (db:have-incompletes? dbstruct run-id ovr-deadtime)
- (let* ((dbdat (db:get-db dbstruct run-id))
- (db (db:dbdat-get-db dbdat))
- (incompleted '())
+ (let* ((incompleted '())
(oldlaunched '())
(toplevels '())
(deadtime-str (configf:lookup *configdat* "setup" "deadtime"))
(deadtime (if (and deadtime-str
(string->number deadtime-str))
(string->number deadtime-str)
7200))) ;; two hours
- (if (number? ovr-deadtime)(set! deadtime ovr-deadtime))
-
- ;; in RUNNING or REMOTEHOSTSTART for more than 10 minutes
- ;;
- ;; HOWEVER: this code in run:test seems to work fine
- ;; (> (- (current-seconds)(+ (db:test-get-event_time testdat)
- ;; (db:test-get-run_duration testdat)))
- ;; 600)
- ;; (db:delay-if-busy dbdat)
- (sqlite3:for-each-row
- (lambda (test-id run-dir uname testname item-path)
- (if (and (equal? uname "n/a")
- (equal? item-path "")) ;; this is a toplevel test
- ;; what to do with toplevel? call rollup?
- (begin
- (set! toplevels (cons (list test-id run-dir uname testname item-path run-id) toplevels))
- (debug:print-info 0 *default-log-port* "Found old toplevel test in RUNNING state, test-id=" test-id))
- (set! incompleted (cons (list test-id run-dir uname testname item-path run-id) incompleted))))
- db
- "SELECT id,rundir,uname,testname,item_path FROM tests WHERE run_id=? AND (strftime('%s','now') - event_time) > (run_duration + ?) AND state IN ('RUNNING','REMOTEHOSTSTART');"
- run-id deadtime)
-
- ;; in LAUNCHED for more than one day. Could be long due to job queues TODO/BUG: Need override for this in config
- ;;
- ;; (db:delay-if-busy dbdat)
- (sqlite3:for-each-row
- (lambda (test-id run-dir uname testname item-path)
- (if (and (equal? uname "n/a")
- (equal? item-path "")) ;; this is a toplevel test
- ;; what to do with toplevel? call rollup?
- (set! toplevels (cons (list test-id run-dir uname testname item-path run-id) toplevels))
- (set! oldlaunched (cons (list test-id run-dir uname testname item-path run-id) oldlaunched))))
- db
- "SELECT id,rundir,uname,testname,item_path FROM tests WHERE run_id=? AND (strftime('%s','now') - event_time) > 86400 AND state IN ('LAUNCHED');"
- run-id)
-
- (debug:print-info 18 *default-log-port* "Found " (length oldlaunched) " old LAUNCHED items, " (length toplevels) " old LAUNCHED toplevel tests and " (length incompleted) " tests marked RUNNING but apparently dead.")
- (if (and (null? incompleted)
- (null? oldlaunched)
- (null? toplevels))
- #f
- #t)))
+ (db:with-db
+ dbstruct #f #f
+ (lambda (db)
+ (if (number? ovr-deadtime)(set! deadtime ovr-deadtime))
+
+ ;; in RUNNING or REMOTEHOSTSTART for more than 10 minutes
+ ;;
+ ;; HOWEVER: this code in run:test seems to work fine
+ ;; (> (- (current-seconds)(+ (db:test-get-event_time testdat)
+ ;; (db:test-get-run_duration testdat)))
+ ;; 600)
+ ;; (db:delay-if-busy dbdat)
+ (sqlite3:for-each-row
+ (lambda (test-id run-dir uname testname item-path)
+ (if (and (equal? uname "n/a")
+ (equal? item-path "")) ;; this is a toplevel test
+ ;; what to do with toplevel? call rollup?
+ (begin
+ (set! toplevels (cons (list test-id run-dir uname testname item-path run-id) toplevels))
+ (debug:print-info 0 *default-log-port* "Found old toplevel test in RUNNING state, test-id=" test-id))
+ (set! incompleted (cons (list test-id run-dir uname testname item-path run-id) incompleted))))
+ db
+ "SELECT id,rundir,uname,testname,item_path FROM tests WHERE run_id=? AND (strftime('%s','now') - event_time) > (run_duration + ?) AND state IN ('RUNNING','REMOTEHOSTSTART');"
+ run-id deadtime)
+
+ ;; in LAUNCHED for more than one day. Could be long due to job queues TODO/BUG: Need override for this in config
+ ;;
+ ;; (db:delay-if-busy dbdat)
+ (sqlite3:for-each-row
+ (lambda (test-id run-dir uname testname item-path)
+ (if (and (equal? uname "n/a")
+ (equal? item-path "")) ;; this is a toplevel test
+ ;; what to do with toplevel? call rollup?
+ (set! toplevels (cons (list test-id run-dir uname testname item-path run-id) toplevels))
+ (set! oldlaunched (cons (list test-id run-dir uname testname item-path run-id) oldlaunched))))
+ db
+ "SELECT id,rundir,uname,testname,item_path FROM tests WHERE run_id=? AND (strftime('%s','now') - event_time) > 86400 AND state IN ('LAUNCHED');"
+ run-id)
+
+ (debug:print-info 18 *default-log-port* "Found " (length oldlaunched) " old LAUNCHED items, " (length toplevels) " old LAUNCHED toplevel tests and " (length incompleted) " tests marked RUNNING but apparently dead.")
+ (if (and (null? incompleted)
+ (null? oldlaunched)
+ (null? toplevels))
+ #f
+ #t)))))
;; given a launch delay (minimum time from last launch) return amount of time to wait
;;
;; (define (db:launch-delay-left dbstruct run-id launch-delay)
@@ -1434,96 +1447,103 @@
;; (select testname,item_path,event_time+run_duration as
;; end_time,strftime('%s','now') as now from tests where state in
;; ('RUNNING','REMOTEHOSTSTART','LAUNCED'));
(define (db:find-and-mark-incomplete dbstruct run-id ovr-deadtime)
- (let* ((dbdat (db:get-db dbstruct run-id))
- (db (db:dbdat-get-db dbdat))
- (incompleted '())
+ (let* ((incompleted '())
(oldlaunched '())
(toplevels '())
(deadtime-str (configf:lookup *configdat* "setup" "deadtime"))
(deadtime (if (and deadtime-str
(string->number deadtime-str))
(string->number deadtime-str)
7200))) ;; two hours
- (if (number? ovr-deadtime)(set! deadtime ovr-deadtime))
-
- ;; in RUNNING or REMOTEHOSTSTART for more than 10 minutes
- ;;
- ;; HOWEVER: this code in run:test seems to work fine
- ;; (> (- (current-seconds)(+ (db:test-get-event_time testdat)
- ;; (db:test-get-run_duration testdat)))
- ;; 600)
- ;; (db:delay-if-busy dbdat)
- (sqlite3:for-each-row
- (lambda (test-id run-dir uname testname item-path)
- (if (and (equal? uname "n/a")
- (equal? item-path "")) ;; this is a toplevel test
- ;; what to do with toplevel? call rollup?
- (begin
- (set! toplevels (cons (list test-id run-dir uname testname item-path run-id) toplevels))
- (debug:print-info 0 *default-log-port* "Found old toplevel test in RUNNING state, test-id=" test-id))
- (set! incompleted (cons (list test-id run-dir uname testname item-path run-id) incompleted))))
- db
- "SELECT id,rundir,uname,testname,item_path FROM tests WHERE run_id=? AND (strftime('%s','now') - event_time) > (run_duration + ?) AND state IN ('RUNNING','REMOTEHOSTSTART');"
- run-id deadtime)
-
- ;; in LAUNCHED for more than one day. Could be long due to job queues TODO/BUG: Need override for this in config
- ;;
- ;; (db:delay-if-busy dbdat)
- (sqlite3:for-each-row
- (lambda (test-id run-dir uname testname item-path)
- (if (and (equal? uname "n/a")
- (equal? item-path "")) ;; this is a toplevel test
- ;; what to do with toplevel? call rollup?
- (set! toplevels (cons (list test-id run-dir uname testname item-path run-id) toplevels))
- (set! oldlaunched (cons (list test-id run-dir uname testname item-path run-id) oldlaunched))))
- db
- "SELECT id,rundir,uname,testname,item_path FROM tests WHERE run_id=? AND (strftime('%s','now') - event_time) > 86400 AND state IN ('LAUNCHED');"
- run-id)
-
- (debug:print-info 18 *default-log-port* "Found " (length oldlaunched) " old LAUNCHED items, " (length toplevels) " old LAUNCHED toplevel tests and " (length incompleted) " tests marked RUNNING but apparently dead.")
-
- ;; These are defunct tests, do not do all the overhead of set-state-status. Force them to INCOMPLETE.
- ;;
- ;; (db:delay-if-busy dbdat)
- (let* (;; (min-incompleted (filter (lambda (x)
- ;; (let* ((testpath (cadr x))
- ;; (tdatpath (conc testpath "/testdat.db"))
- ;; (dbexists (file-exists? tdatpath)))
- ;; (or (not dbexists) ;; if no file then something wrong - mark as incomplete
- ;; (> (- (current-seconds)(file-modification-time tdatpath)) 600)))) ;; no change in 10 minutes to testdat.db - she's dead Jim
- ;; incompleted))
- (min-incompleted-ids (map car incompleted)) ;; do 'em all
- (all-ids (append min-incompleted-ids (map car oldlaunched))))
- (if (> (length all-ids) 0)
- (begin
- (debug:print 0 *default-log-port* "WARNING: Marking test(s); " (string-intersperse (map conc all-ids) ", ") " as INCOMPLETE")
- (sqlite3:execute
- db
- (conc "UPDATE tests SET state='INCOMPLETE' WHERE run_id=? AND id IN ("
- (string-intersperse (map conc all-ids) ",")
- ");")
- run-id))))
-
- ;; Now do rollups for the toplevel tests
- ;;
- ;; (db:delay-if-busy dbdat)
- (for-each
- (lambda (toptest)
- (let ((test-name (list-ref toptest 3)))
-;; (run-id (list-ref toptest 5)))
- (db:top-test-set-per-pf-counts dbstruct run-id test-name)))
- toplevels)))
+ (db:with-db
+ dbstruct #f #f
+ (lambda (db)
+ (if (number? ovr-deadtime)(set! deadtime ovr-deadtime))
+
+ ;; in RUNNING or REMOTEHOSTSTART for more than 10 minutes
+ ;;
+ ;; HOWEVER: this code in run:test seems to work fine
+ ;; (> (- (current-seconds)(+ (db:test-get-event_time testdat)
+ ;; (db:test-get-run_duration testdat)))
+ ;; 600)
+ ;; (db:delay-if-busy dbdat)
+ (sqlite3:for-each-row
+ (lambda (test-id run-dir uname testname item-path)
+ (if (and (equal? uname "n/a")
+ (equal? item-path "")) ;; this is a toplevel test
+ ;; what to do with toplevel? call rollup?
+ (begin
+ (set! toplevels (cons (list test-id run-dir uname testname item-path run-id) toplevels))
+ (debug:print-info 0 *default-log-port* "Found old toplevel test in RUNNING state, test-id=" test-id))
+ (set! incompleted (cons (list test-id run-dir uname testname item-path run-id) incompleted))))
+ db
+ "SELECT id,rundir,uname,testname,item_path FROM tests WHERE run_id=? AND (strftime('%s','now') - event_time) > (run_duration + ?) AND state IN ('RUNNING','REMOTEHOSTSTART');"
+ run-id deadtime)
+
+ ;; in LAUNCHED for more than one day. Could be long due to job queues TODO/BUG: Need override for this in config
+ ;;
+ ;; (db:delay-if-busy dbdat)
+ (sqlite3:for-each-row
+ (lambda (test-id run-dir uname testname item-path)
+ (if (and (equal? uname "n/a")
+ (equal? item-path "")) ;; this is a toplevel test
+ ;; what to do with toplevel? call rollup?
+ (set! toplevels (cons (list test-id run-dir uname testname item-path run-id) toplevels))
+ (set! oldlaunched (cons (list test-id run-dir uname testname item-path run-id) oldlaunched))))
+ db
+ "SELECT id,rundir,uname,testname,item_path FROM tests WHERE run_id=? AND (strftime('%s','now') - event_time) > 86400 AND state IN ('LAUNCHED');"
+ run-id)
+
+ (debug:print-info 18 *default-log-port* "Found " (length oldlaunched) " old LAUNCHED items, " (length toplevels) " old LAUNCHED toplevel tests and " (length incompleted) " tests marked RUNNING but apparently dead.")
+
+ ;; These are defunct tests, do not do all the overhead of set-state-status. Force them to INCOMPLETE.
+ ;;
+ ;; (db:delay-if-busy dbdat)
+ (let* (;; (min-incompleted (filter (lambda (x)
+ ;; (let* ((testpath (cadr x))
+ ;; (tdatpath (conc testpath "/testdat.db"))
+ ;; (dbexists (file-exists? tdatpath)))
+ ;; (or (not dbexists) ;; if no file then something wrong - mark as incomplete
+ ;; (> (- (current-seconds)(file-modification-time tdatpath)) 600)))) ;; no change in 10 minutes to testdat.db - she's dead Jim
+ ;; incompleted))
+ (min-incompleted-ids (map car incompleted)) ;; do 'em all
+ (all-ids (append min-incompleted-ids (map car oldlaunched))))
+ (if (> (length all-ids) 0)
+ (begin
+ (debug:print 0 *default-log-port* "WARNING: Marking test(s); " (string-intersperse (map conc all-ids) ", ") " as INCOMPLETE")
+ (for-each
+ (lambda (test-id)
+ (db:test-set-state-status dbstruct run-id test-id "COMPLETE" "DEAD" "Test failed to complete"))
+ all-ids))))))))
+
+;; ALL REPLACED BY THE BLOCK ABOVE
+;;
+;; (sqlite3:execute
+;; db
+;; (conc "UPDATE tests SET state='INCOMPLETE' WHERE run_id=? AND id IN ("
+;; (string-intersperse (map conc all-ids) ",")
+;; ");")
+;; run-id))))
+;;
+;; ;; Now do rollups for the toplevel tests
+;; ;;
+;; ;; (db:delay-if-busy dbdat)
+;; (for-each
+;; (lambda (toptest)
+;; (let ((test-name (list-ref toptest 3)))
+;; ;; (run-id (list-ref toptest 5)))
+;; (db:top-test-set-per-pf-counts dbstruct run-id test-name)))
+;; toplevels)))
;; BUG: Probably broken - does not explicitly use run-id in the query
;;
(define (db:top-test-set-per-pf-counts dbstruct run-id test-name)
- (db:general-call (db:get-db dbstruct run-id) 'top-test-set-per-pf-counts (list test-name test-name test-name test-name test-name test-name test-name test-name test-name test-name test-name test-name test-name test-name test-name test-name test-name)))
-
-
+ (db:general-call dbstruct 'top-test-set-per-pf-counts (list test-name test-name test-name test-name test-name test-name test-name test-name test-name test-name test-name test-name test-name test-name test-name test-name test-name)))
+
;; Clean out old junk and vacuum the database
;;
;; Ultimately do something like this:
;;
;; 1. Look at test records either deleted or part of deleted run:
@@ -1664,23 +1684,24 @@
;; returns number if string->number is successful, string otherwise
;; also updates *global-delta*
;;
(define (db:get-var dbstruct var)
- (let* ((res #f)
- (dbdat (db:get-db dbstruct #f))
- (db (db:dbdat-get-db dbdat)))
- (sqlite3:for-each-row
- (lambda (val)
- (set! res val))
- db
- "SELECT val FROM metadat WHERE var=?;" var)
- ;; convert to number if can
- (if (string? res)
- (let ((valnum (string->number res)))
- (if valnum (set! res valnum))))
- res))
+ (let* ((res #f))
+ (db:with-db
+ dbstruct #f #f
+ (lambda (db)
+ (sqlite3:for-each-row
+ (lambda (val)
+ (set! res val))
+ db
+ "SELECT val FROM metadat WHERE var=?;" var)
+ ;; convert to number if can
+ (if (string? res)
+ (let ((valnum (string->number res)))
+ (if valnum (set! res valnum))))
+ res))))
;; This was part of db:get-var. It was used to estimate the load on
;; the database files.
;;
;; scale by 10, average with current value.
@@ -1691,16 +1712,15 @@
;; (begin
;; (debug:print-info 4 *default-log-port* "launch throttle factor=" *global-delta*)
;; (set! *last-global-delta-printed* *global-delta*)))
(define (db:set-var dbstruct var val)
- (let* ((dbdat (db:get-db dbstruct #f))
- (db (db:dbdat-get-db dbdat)))
- (sqlite3:execute db "INSERT OR REPLACE INTO metadat (var,val) VALUES (?,?);" var val)))
+ (db:with-db dbstruct #f #t
+ (lambda (db)
+ (sqlite3:execute db "INSERT OR REPLACE INTO metadat (var,val) VALUES (?,?);" var val))))
(define (db:del-var dbstruct var)
- ;; (db:delay-if-busy)
(db:with-db dbstruct #f #t
(lambda (db)
(sqlite3:execute db "DELETE FROM metadat WHERE var=?;" var))))
;; use a global for some primitive caching, it is just silly to
@@ -1796,13 +1816,11 @@
;; 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* ((dbdat (db:get-db dbstruct #f))
- (db (db:dbdat-get-db dbdat))
- (keys (map car keyvals))
+ (let* ((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)))
@@ -1809,26 +1827,25 @@
(qryvals (append (list runname) (map cadr keyvals)))
(key=?str (string-intersperse (map (lambda (k)(conc k "=?")) keys) " AND ")))
(debug:print 3 *default-log-port* "keys: " keys " allvals: " allvals " keyvals: " keyvals " key=?str is " key=?str)
(debug:print 2 *default-log-port* "NOTE: using target " (string-intersperse (map cadr keyvals) "/") " for this run")
(if (and runname (null? (filter (lambda (x)(not x)) keyvals))) ;; there must be a better way to "apply and"
- (let ((res #f))
- ;; (db:delay-if-busy dbdat)
- (apply sqlite3:execute db (conc "INSERT OR IGNORE INTO runs (runname,state,status,owner,event_time" comma keystr ") VALUES (?,?,?,?,strftime('%s','now')" comma valslots ");")
- allvals)
- ;; (db:delay-if-busy dbdat)
- (apply sqlite3:for-each-row
- (lambda (id)
- (set! res id))
- db
- (let ((qry (conc "SELECT id FROM runs WHERE (runname=? " andstr key=?str ");")))
- ;(debug:print 4 *default-log-port* "qry: " qry)
- qry)
- qryvals)
- ;; (db:delay-if-busy dbdat)
- (sqlite3:execute db "UPDATE runs SET state=?,status=?,event_time=strftime('%s','now') WHERE id=? AND state='deleted';" state status res)
- res)
+ (db:with-db
+ dbstruct #f #f
+ (lambda (db)
+ (let ((res #f))
+ (apply sqlite3:execute db (conc "INSERT OR IGNORE INTO runs (runname,state,status,owner,event_time" comma keystr ") VALUES (?,?,?,?,strftime('%s','now')" comma valslots ");")
+ allvals)
+ (apply sqlite3:for-each-row
+ (lambda (id)
+ (set! res id))
+ db
+ (let ((qry (conc "SELECT id FROM runs WHERE (runname=? " andstr key=?str ");")))
+ qry)
+ qryvals)
+ (sqlite3:execute db "UPDATE runs SET state=?,status=?,event_time=strftime('%s','now') WHERE id=? AND state='deleted';" state status res)
+ res)))
(begin
(debug:print-error 0 *default-log-port* "Called without all necessary keys")
#f))))
;; replace header and keystr with a call to runs:get-std-run-fields
@@ -1946,23 +1963,26 @@
(sqlite3:fold-row
(lambda (res state status count)
(cons (list state status count) res))
'()
db
- "SELECT state,status,count(id) AS count FROM tests WHERE run_id=? AND NOT(uname='n/a' AND item_path='') GROUP BY state,status;;"
+ "SELECT state,status,count(id) AS count FROM tests WHERE run_id=? AND NOT(uname='n/a' AND item_path='') GROUP BY state,status;"
run-id))))
;; Update run_stats for given run_id
;; input data is a list (state status count)
;;
(define (db:update-run-stats dbstruct run-id stats)
+ ;; (mutex-lock! *db-transaction-mutex*)
(db:with-db
dbstruct
#f
#f
+
(lambda (db)
;; remove previous data
+
(let* ((stmt1 (sqlite3:prepare db "DELETE FROM run_stats WHERE run_id=? AND state=? AND status=?;"))
(stmt2 (sqlite3:prepare db "INSERT INTO run_stats (run_id,state,status,count) VALUES (?,?,?,?);"))
(res
(sqlite3:with-transaction
db
@@ -1972,10 +1992,11 @@
(sqlite3:execute stmt1 run-id (car dat)(cadr dat))
(apply sqlite3:execute stmt2 run-id dat))
stats)))))
(sqlite3:finalize! stmt1)
(sqlite3:finalize! stmt2)
+ ;; (mutex-unlock! *db-transaction-mutex*)
res))))
(define (db:get-main-run-stats dbstruct run-id)
(db:with-db
dbstruct
@@ -1987,10 +2008,25 @@
(cons (list state status count) res))
'()
db
"SELECT state,status,count FROM run_stats WHERE run_id=? AND run_id IN (SELECT id FROM runs WHERE state NOT IN ('DELETED','deleted'));"
run-id))))
+
+(define (db:print-current-query-stats)
+ ;; generate stats from *db-api-call-time*
+ (let ((ordered-keys (sort (hash-table-keys *db-api-call-time*)
+ (lambda (a b)
+ (let ((sum-a (common:sum (hash-table-ref *db-api-call-time* a)))
+ (sum-b (common:sum (hash-table-ref *db-api-call-time* b))))
+ (> sum-a sum-b))))))
+ (for-each
+ (lambda (cmd-key)
+ (let* ((dat (hash-table-ref *db-api-call-time* cmd-key))
+ (avg (if (> (length dat) 0)
+ (/ (common:sum dat)(length dat)))))
+ (debug:print-info 0 *default-log-port* cmd-key "\tavg: " avg " max: " (common:max dat) " min: " (common:min-max < dat) " num: " (length dat))))
+ ordered-keys)))
(define (db:get-all-run-ids dbstruct)
(db:with-db
dbstruct
#f
@@ -2007,23 +2043,23 @@
;; get some basic run stats
;;
;; ( (runname (( state count ) ... ))
;; ( ...
(define (db:get-run-stats dbstruct)
- (let* ((dbdat (db:get-db dbstruct #f))
- (db (db:dbdat-get-db dbdat))
- (totals (make-hash-table))
+ (let* ((totals (make-hash-table))
(curr (make-hash-table))
(res '())
(runs-info '()))
;; First get all the runname/run-ids
- ;; (db:delay-if-busy dbdat)
- (sqlite3:for-each-row
- (lambda (run-id runname)
- (set! runs-info (cons (list run-id runname) runs-info)))
- db
- "SELECT id,runname FROM runs WHERE state != 'deleted' ORDER BY event_time DESC;") ;; If you change this to the more logical ASC please adjust calls to db:get-run-stats
+ (db:with-db
+ dbstruct #f #f
+ (lambda (db)
+ (sqlite3:for-each-row
+ (lambda (run-id runname)
+ (set! runs-info (cons (list run-id runname) runs-info)))
+ db
+ "SELECT id,runname FROM runs WHERE state != 'deleted' ORDER BY event_time DESC;"))) ;; If you change this to the more logical ASC please adjust calls to db:get-run-stats
;; for each run get stats data
(for-each
(lambda (run-info)
;; get the net state/status counts for this run
(let* ((run-id (car run-info))
@@ -2039,11 +2075,12 @@
(if (string? netstate)
(begin
(hash-table-set! totals netstate (+ (hash-table-ref/default totals netstate 0) count))
(hash-table-set! curr netstate (+ (hash-table-ref/default curr netstate 0) count))))))
db
- "SELECT state,status,count(id) FROM tests AS t GROUP BY state,status ORDER BY state,status DESC;")
+ "SELECT state,status,count(id) FROM tests AS t WHERE run_id=? GROUP BY state,status ORDER BY state,status DESC;"
+ run-id)
;; add the per run counts to res
(for-each (lambda (state)
(set! res (cons (list run-name state (hash-table-ref curr state)) res)))
(sort (hash-table-keys curr) string>=))
(set! curr (make-hash-table))))))
@@ -2102,70 +2139,61 @@
;; 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* ((dbdat (db:get-db dbstruct #f))
- (db (db:dbdat-get-db dbdat))
- (res (vector #f #f #f #f))
+ (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 *default-log-port* "db:get-run-info run-id: " run-id " header: " header " keystr: " keystr)
- ;; (db:delay-if-busy dbdat)
- (sqlite3:for-each-row
- (lambda (a . x)
- (set! res (apply vector a x)))
- db
- (conc "SELECT " keystr " FROM runs WHERE id=? AND state != 'deleted';")
- run-id)
+ (db:with-db
+ dbstruct #f #f
+ (lambda (db)
+ (sqlite3:for-each-row
+ (lambda (a . x)
+ (set! res (apply vector a x)))
+ db
+ (conc "SELECT " keystr " FROM runs WHERE id=? AND state != 'deleted';")
+ run-id)))
(debug:print-info 11 *default-log-port* "db:get-run-info run-id: " run-id " header: " header " keystr: " keystr)
(let ((finalres (vector header res)))
;; (hash-table-set! *run-info-cache* run-id finalres)
finalres)))
(define (db:set-comment-for-run dbstruct run-id comment)
(db:with-db
- dbstruct
- #f
- #f
+ dbstruct #f #f
(lambda (db)
(sqlite3:execute db "UPDATE runs SET comment=? WHERE id=?;" comment ;; (sdb:qry 'getid comment)
run-id))))
;; does not (obviously!) removed dependent data. But why not!!?
(define (db:delete-run dbstruct run-id)
- ;; First set any related tests to DELETED
- (let* ((rdbdat (db:get-db dbstruct run-id))
- (rdb (db:dbdat-get-db rdbdat))
- (dbdat (db:get-db dbstruct #f))
- (db (db:dbdat-get-db dbdat)))
- ;; (db:delay-if-busy rdbdat)
- (sqlite3:with-transaction
- db
- (lambda ()
- (sqlite3:execute rdb "DELETE FROM test_steps WHERE test_id IN (SELECT id FROM tests WHERE run_id=?);" run-id)
- (sqlite3:execute rdb "DELETE FROM test_data WHERE test_id IN (SELECT id FROM tests WHERE run_id=?);" run-id)
- (sqlite3:execute rdb "UPDATE tests SET state='DELETED',comment='' WHERE run_id=?;" run-id)
- ;; (db:delay-if-busy dbdat)
- (sqlite3:execute db "UPDATE runs SET state='deleted',comment='' WHERE id=?;" run-id)))))
+ (db:with-db
+ dbstruct #f #f
+ (lambda (db)
+ (sqlite3:with-transaction
+ db
+ (lambda ()
+ (sqlite3:execute db "DELETE FROM test_steps WHERE test_id IN (SELECT id FROM tests WHERE run_id=?);" run-id)
+ (sqlite3:execute db "DELETE FROM test_data WHERE test_id IN (SELECT id FROM tests WHERE run_id=?);" run-id)
+ (sqlite3:execute db "UPDATE tests SET state='DELETED',comment='' WHERE run_id=?;" run-id)
+ ;; (db:delay-if-busy dbdat)
+ (sqlite3:execute db "UPDATE runs SET state='deleted',comment='' WHERE id=?;" run-id))))))
(define (db:update-run-event_time dbstruct run-id)
(db:with-db
- dbstruct
- #f
- #t
+ dbstruct #f #t
(lambda (db)
(sqlite3:execute db "UPDATE runs SET event_time=strftime('%s','now') WHERE id=?;" run-id))))
(define (db:lock/unlock-run dbstruct run-id lock unlock user)
(db:with-db
- dbstruct
- #f
- #t
+ dbstruct #f #t
(lambda (db)
(let ((newlockval (if lock "locked"
(if unlock
"unlocked"
"locked")))) ;; semi-failsafe
@@ -2173,23 +2201,21 @@
(sqlite3:execute db "INSERT INTO access_log (user,accessed,args) VALUES(?,strftime('%s','now'),?);"
user (conc newlockval " " run-id))
(debug:print-info 1 *default-log-port* "" newlockval " run number " run-id)))))
(define (db:set-run-status dbstruct run-id status msg)
- (let* ((dbdat (db:get-db dbstruct #f))
- (db (db:dbdat-get-db dbdat)))
- ;; (db:delay-if-busy dbdat)
- (if msg
- (sqlite3:execute db "UPDATE runs SET status=?,comment=? WHERE id=?;" status msg run-id)
- (sqlite3:execute db "UPDATE runs SET status=? WHERE id=?;" status run-id))))
+ (db:with-db
+ dbstruct #f #f
+ (lambda (db)
+ (if msg
+ (sqlite3:execute db "UPDATE runs SET status=?,comment=? WHERE id=?;" status msg run-id)
+ (sqlite3:execute db "UPDATE runs SET status=? WHERE id=?;" status run-id)))))
(define (db:get-run-status dbstruct run-id)
(let ((res "n/a"))
(db:with-db
- dbstruct
- #f
- #f
+ dbstruct #f #f
(lambda (db)
(sqlite3:for-each-row
(lambda (status)
(set! res status))
db
@@ -2203,39 +2229,40 @@
;; get key val pairs for a given run-id
;; ( (FIELDNAME1 keyval1) (FIELDNAME2 keyval2) ... )
(define (db:get-key-val-pairs dbstruct run-id)
(let* ((keys (db:get-keys dbstruct))
- (res '())
- (dbdat (db:get-db dbstruct #f))
- (db (db:dbdat-get-db dbdat)))
- (for-each
- (lambda (key)
- (let ((qry (conc "SELECT " key " FROM runs WHERE id=?;")))
- ;; (db:delay-if-busy dbdat)
- (sqlite3:for-each-row
- (lambda (key-val)
- (set! res (cons (list key key-val) res)))
- db qry run-id)))
- keys)
- (reverse res)))
+ (res '()))
+ (db:with-db
+ dbstruct #f #f
+ (lambda (db)
+ (for-each
+ (lambda (key)
+ (let ((qry (conc "SELECT " key " FROM runs WHERE id=?;")))
+ (sqlite3:for-each-row
+ (lambda (key-val)
+ (set! res (cons (list key key-val) res)))
+ db qry run-id)))
+ keys)))
+ (reverse res)))
;; get key vals for a given run-id
(define (db:get-key-vals dbstruct run-id)
(let* ((keys (db:get-keys dbstruct))
- (res '())
- (dbdat (db:get-db dbstruct #f))
- (db (db:dbdat-get-db dbdat)))
- (for-each
- (lambda (key)
- (let ((qry (conc "SELECT " key " FROM runs WHERE id=?;")))
- ;; (db:delay-if-busy dbdat)
- (sqlite3:for-each-row
- (lambda (key-val)
- (set! res (cons key-val res)))
- db qry run-id)))
- keys)
+ (res '()))
+ (db:with-db
+ dbstruct #f #f
+ (lambda (db)
+ (for-each
+ (lambda (key)
+ (let ((qry (conc "SELECT " key " FROM runs WHERE id=?;")))
+ ;; (db:delay-if-busy dbdat)
+ (sqlite3:for-each-row
+ (lambda (key-val)
+ (set! res (cons key-val res)))
+ db qry run-id)))
+ keys)))
(let ((final-res (reverse res)))
(hash-table-set! *keyvals* run-id final-res)
final-res)))
;; The target is keyval1/keyval2..., cached in *target* as it is used often
@@ -2250,18 +2277,22 @@
(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)))
+ (if (null? keyvals)
+ '()
+ (begin
+ (db:with-db dbstruct #f #f ;; #f means work with the zeroth db - i.e. the runs db
+ (lambda (db)
+ (apply sqlite3:for-each-row
+ (lambda (id)
+ (set! prev-run-ids (cons id prev-run-ids)))
+ db
+ (conc "SELECT id FROM runs WHERE " qrystr " AND state != 'deleted' AND id != ?;")
+ (append kvalues (list run-id)))))
+ prev-run-ids)))))
;;======================================================================
;; T E S T S
;;======================================================================
@@ -2428,16 +2459,16 @@
;; 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* ((dbdat (db:get-db dbstruct run-id))
- (db (db:dbdat-get-db dbdat)))
- (db:general-call dbdat 'delete-test-step-records (list test-id))
- ;; (db:delay-if-busy)
- (db:general-call dbdat 'delete-test-data-records (list test-id))
- (sqlite3:execute db "UPDATE tests SET state='DELETED',status='n/a',comment='' WHERE id=?;" test-id)))
+ (db:general-call dbstruct 'delete-test-step-records (list test-id))
+ (db:general-call dbstruct 'delete-test-data-records (list test-id))
+ (db:with-db
+ dbstruct #f #f
+ (lambda (db)
+ (sqlite3:execute db "UPDATE tests SET state='DELETED',status='n/a',comment='' WHERE id=?;" test-id))))
;;
(define (db:delete-old-deleted-test-records dbstruct)
(let (;; (run-ids (db:get-all-run-ids dbstruct))
(targtime (- (current-seconds)(* 30 24 60 60)))) ;; one month in the past
@@ -2466,26 +2497,25 @@
(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 LIKE ?;")))
+ " run_id=? AND testname LIKE ?;"))
+ (test-id (db:get-test-id dbstruct run-id testname "")))
(db:with-db
dbstruct
run-id
#t
(lambda (db)
- (let ((test-id (db:get-test-id dbstruct run-id testname "")))
- (sqlite3:execute db qry newstate newstatus run-id testname)
- (if test-id (mt:process-triggers run-id test-id newstate newstatus)))
- ))))
+ (sqlite3:execute db qry newstate newstatus run-id testname)))
+ (if test-id (mt:process-triggers dbstruct run-id test-id newstate newstatus))))
testnames))
-;; 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 dbstruct run-id test-id newstate newstatus newcomment)
+;; ;; 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 dbstruct run-id test-id newstate newstatus newcomment)
(db:with-db
dbstruct
run-id
#t
(lambda (db)
@@ -2497,12 +2527,12 @@
(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))))
+ test-id))))))
+ (mt:process-triggers dbstruct run-id test-id newstate newstatus))
;; NEW BEHAVIOR: Count tests running in all runs!
;;
(define (db:get-count-tests-running dbstruct run-id)
(db:with-db
@@ -2558,23 +2588,23 @@
(sqlite3:first-result
db
"SELECT count(id) FROM tests WHERE state in ('RUNNING','LAUNCHED','REMOTEHOSTSTART') AND run_id=? AND NOT (uname = 'n/a' AND item_path = '') AND testname=?;" run-id testname))))
(define (db:get-count-tests-running-in-jobgroup dbstruct run-id jobgroup)
- (let* ((dbdat (db:get-db dbstruct #f))
- (db (db:dbdat-get-db dbdat)))
(if (not jobgroup)
0 ;;
(let ((testnames '()))
;; get the testnames
- ;; (db:delay-if-busy dbdat)
- (sqlite3:for-each-row
- (lambda (testname)
- (set! testnames (cons testname testnames)))
- db
- "SELECT testname FROM test_meta WHERE jobgroup=?"
- jobgroup)
+ (db:with-db
+ dbstruct #f #f
+ (lambda (db)
+ (sqlite3:for-each-row
+ (lambda (testname)
+ (set! testnames (cons testname testnames)))
+ db
+ "SELECT testname FROM test_meta WHERE jobgroup=?"
+ jobgroup)))
;; get the jobcount NB// EXTEND THIS TO OPPERATE OVER ALL RUNS?
(if (not (null? testnames))
(db:with-db
dbstruct
run-id
@@ -2584,14 +2614,14 @@
db
(conc "SELECT count(id) FROM tests WHERE state in ('RUNNING','LAUNCHED','REMOTEHOSTSTART') AND testname in ('"
(string-intersperse testnames "','")
"') AND NOT (uname = 'n/a' AND item_path='');")) ;; should this include the (uname = 'n/a' ...) ???
))
- 0)))))
- ;; DEBUG FIXME - need to merge this v.155 query correctly
- ;; AND testname in (SELECT testname FROM test_meta WHERE jobgroup=?)
- ;; AND NOT (uname = 'n/a' AND item_path = '');"
+ 0))))
+
+;; tags: '("tag%" "tag2" "%ag6")
+;;
;; done with run when:
;; 0 tests in LAUNCHED, NOT_STARTED, REMOTEHOSTSTART, RUNNING
(define (db:estimated-tests-remaining dbstruct run-id)
(db:with-db
@@ -2662,24 +2692,22 @@
;; 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* ((dbdat (if (vector? dbstruct)
- (db:get-db dbstruct run-id)
- dbstruct)) ;; still settling on when to use dbstruct or dbdat
- (db (db:dbdat-get-db dbdat))
- (res '()))
- ;; (db:delay-if-busy dbdat)
- (sqlite3:for-each-row
- (lambda (id run-id testname state status event-time host cpuload diskfree uname rundir item-path run-duration final-logf comment shortdir attemptnum archived)
- ;; 0 1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16
- (set! res (cons (vector id run-id testname state status event-time host cpuload diskfree uname rundir item-path run-duration final-logf comment shortdir attemptnum archived)
- res)))
- db
- (conc "SELECT " db:test-record-qry-selector " FROM tests WHERE state != 'DELETED' AND run_id=?;")
- run-id)
+ (let* ((res '()))
+ (db:with-db
+ dbstruct #f #f
+ (lambda (db)
+ (sqlite3:for-each-row
+ (lambda (id run-id testname state status event-time host cpuload diskfree uname rundir item-path run-duration final-logf comment shortdir attemptnum archived)
+ ;; 0 1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16
+ (set! res (cons (vector id run-id testname state status event-time host cpuload diskfree uname rundir item-path run-duration final-logf comment shortdir attemptnum archived)
+ res)))
+ db
+ (conc "SELECT " db:test-record-qry-selector " FROM tests WHERE state != 'DELETED' AND run_id=?;")
+ run-id)))
res))
(define (db:replace-test-records dbstruct run-id testrecs)
(db:with-db dbstruct run-id #t
(lambda (db)
@@ -2858,27 +2886,27 @@
;; 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* ((dbdat (db:get-db dbstruct run-id))
- (db (db:dbdat-get-db dbdat))
- (fail-count 0)
+ (let* ((fail-count 0)
(pass-count 0))
- ;; (db:delay-if-busy dbdat)
- (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,
+ (db:with-db
+ dbstruct #f #f
+ (lambda (db)
+ (sqlite3:for-each-row
+ (lambda (fcount pcount)
+ (set! fail-count fcount)
+ (set! pass-count pcount))
+ db
+ "SELECT (SELECT count(id) FROM test_data WHERE test_id=? AND status like 'fail') AS fail_count,
(SELECT count(id) FROM test_data WHERE test_id=? AND status like 'pass') AS pass_count;"
- test-id test-id)
- ;; Now rollup the counts to the central megatest.db
- (db:general-call dbdat '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 dbdat 'test_data-pf-rollup (list test-id test-id test-id test-id))))
+ test-id test-id)
+ ;; Now rollup the counts to the central megatest.db
+ (db:general-call dbstruct 'pass-fail-counts (list pass-count fail-count test-id))
+ ;; if the test is not FAIL then set status based on the fail and pass counts.
+ (db:general-call dbstruct 'test_data-pf-rollup (list test-id test-id test-id test-id))))))
;; each section is a rule except "final" which is the final result
;;
;; [rule-5]
;; operator in
@@ -2959,105 +2987,107 @@
;; faz,bar, 10, 8mA, , ,"this is a comment"
;; EOF
(define (db:csv->test-data dbstruct run-id test-id csvdata)
(debug:print 4 *default-log-port* "test-id " test-id ", csvdata: " csvdata)
- (let* ((dbdat (db:get-db dbstruct run-id))
- (db (db:dbdat-get-db dbdat))
- (csvlist (csv->list (make-csv-reader
- (open-input-string csvdata)
- '((strip-leading-whitespace? #t)
- (strip-trailing-whitespace? #t)))))) ;; (csv->list csvdata)))
- (for-each
- (lambda (csvrow)
- (let* ((padded-row (take (append csvrow (list #f #f #f #f #f #f #f #f #f)) 9))
- (category (list-ref padded-row 0))
- (variable (list-ref padded-row 1))
- (value (any->number-if-possible (list-ref padded-row 2)))
- (expected (any->number-if-possible (list-ref padded-row 3)))
- (tol (any->number-if-possible (list-ref padded-row 4))) ;; >, <, >=, <=, or a number
- (units (list-ref padded-row 5))
- (comment (list-ref padded-row 6))
- (status (let ((s (list-ref padded-row 7)))
- (if (and (string? s)(or (string-match (regexp "^\\s*$") s)
- (string-match (regexp "^n/a$") s)))
- #f
- s))) ;; if specified on the input then use, else calculate
- (type (list-ref padded-row 8)))
- ;; look up expected,tol,units from previous best fit test if they are all either #f or ''
- (debug:print 4 *default-log-port* "BEFORE: category: " category " variable: " variable " value: " value
- ", expected: " expected " tol: " tol " units: " units " status: " status " comment: " comment " type: " type)
-
- (if (and (or (not expected)(equal? expected ""))
- (or (not tol) (equal? expected ""))
- (or (not units) (equal? expected "")))
- (let-values (((new-expected new-tol new-units)(tdb:get-prev-tol-for-test #f test-id category variable)))
- (set! expected new-expected)
- (set! tol new-tol)
- (set! units new-units)))
-
- (debug:print 4 *default-log-port* "AFTER: category: " category " variable: " variable " value: " value
- ", expected: " expected " tol: " tol " units: " units " status: " status " comment: " comment)
- ;; calculate status if NOT specified
- (if (and (not status)(number? expected)(number? value)) ;; need expected and value to be numbers
- (if (number? tol) ;; if tol is a number then we do the standard comparison
- (let* ((max-val (+ expected tol))
- (min-val (- expected tol))
- (result (and (>= value min-val)(<= value max-val))))
- (debug:print 4 *default-log-port* "max-val: " max-val " min-val: " min-val " result: " result)
- (set! status (if result "pass" "fail")))
- (set! status ;; NB// need to assess each one (i.e. not return operator since need to act if not valid op.
- (case (string->symbol tol) ;; tol should be >, <, >=, <=
- ((>) (if (> value expected) "pass" "fail"))
- ((<) (if (< value expected) "pass" "fail"))
- ((>=) (if (>= value expected) "pass" "fail"))
- ((<=) (if (<= value expected) "pass" "fail"))
- (else (conc "ERROR: bad tol comparator " tol))))))
- (debug:print 4 *default-log-port* "AFTER2: category: " category " variable: " variable " value: " value
- ", expected: " expected " tol: " tol " units: " units " status: " status " comment: " comment)
- ;; (db:delay-if-busy dbdat)
- (sqlite3:execute db "INSERT OR REPLACE INTO test_data (test_id,category,variable,value,expected,tol,units,comment,status,type) VALUES (?,?,?,?,?,?,?,?,?,?);"
- test-id category variable value expected tol units (if comment comment "") status type)))
- csvlist)))
+ (db:with-db
+ dbstruct #f #f
+ (lambda (db)
+ (let* ((csvlist (csv->list (make-csv-reader
+ (open-input-string csvdata)
+ '((strip-leading-whitespace? #t)
+ (strip-trailing-whitespace? #t)))))) ;; (csv->list csvdata)))
+ (for-each
+ (lambda (csvrow)
+ (let* ((padded-row (take (append csvrow (list #f #f #f #f #f #f #f #f #f)) 9))
+ (category (list-ref padded-row 0))
+ (variable (list-ref padded-row 1))
+ (value (any->number-if-possible (list-ref padded-row 2)))
+ (expected (any->number-if-possible (list-ref padded-row 3)))
+ (tol (any->number-if-possible (list-ref padded-row 4))) ;; >, <, >=, <=, or a number
+ (units (list-ref padded-row 5))
+ (comment (list-ref padded-row 6))
+ (status (let ((s (list-ref padded-row 7)))
+ (if (and (string? s)(or (string-match (regexp "^\\s*$") s)
+ (string-match (regexp "^n/a$") s)))
+ #f
+ s))) ;; if specified on the input then use, else calculate
+ (type (list-ref padded-row 8)))
+ ;; look up expected,tol,units from previous best fit test if they are all either #f or ''
+ (debug:print 4 *default-log-port* "BEFORE: category: " category " variable: " variable " value: " value
+ ", expected: " expected " tol: " tol " units: " units " status: " status " comment: " comment " type: " type)
+
+ (if (and (or (not expected)(equal? expected ""))
+ (or (not tol) (equal? expected ""))
+ (or (not units) (equal? expected "")))
+ (let-values (((new-expected new-tol new-units)(tdb:get-prev-tol-for-test #f test-id category variable)))
+ (set! expected new-expected)
+ (set! tol new-tol)
+ (set! units new-units)))
+
+ (debug:print 4 *default-log-port* "AFTER: category: " category " variable: " variable " value: " value
+ ", expected: " expected " tol: " tol " units: " units " status: " status " comment: " comment)
+ ;; calculate status if NOT specified
+ (if (and (not status)(number? expected)(number? value)) ;; need expected and value to be numbers
+ (if (number? tol) ;; if tol is a number then we do the standard comparison
+ (let* ((max-val (+ expected tol))
+ (min-val (- expected tol))
+ (result (and (>= value min-val)(<= value max-val))))
+ (debug:print 4 *default-log-port* "max-val: " max-val " min-val: " min-val " result: " result)
+ (set! status (if result "pass" "fail")))
+ (set! status ;; NB// need to assess each one (i.e. not return operator since need to act if not valid op.
+ (case (string->symbol tol) ;; tol should be >, <, >=, <=
+ ((>) (if (> value expected) "pass" "fail"))
+ ((<) (if (< value expected) "pass" "fail"))
+ ((>=) (if (>= value expected) "pass" "fail"))
+ ((<=) (if (<= value expected) "pass" "fail"))
+ (else (conc "ERROR: bad tol comparator " tol))))))
+ (debug:print 4 *default-log-port* "AFTER2: category: " category " variable: " variable " value: " value
+ ", expected: " expected " tol: " tol " units: " units " status: " status " comment: " comment)
+ ;; (db:delay-if-busy dbdat)
+ (sqlite3:execute db "INSERT OR REPLACE INTO test_data (test_id,category,variable,value,expected,tol,units,comment,status,type) VALUES (?,?,?,?,?,?,?,?,?,?);"
+ test-id category variable value expected tol units (if comment comment "") status type)))
+ csvlist)))))
;; This routine moved from tdb.scm, tdb:read-test-data
;;
(define (db:read-test-data dbstruct run-id test-id categorypatt)
- (let* ((dbdat (db:get-db dbstruct run-id))
- (db (db:dbdat-get-db dbdat))
- (res '()))
- ;; (db:delay-if-busy dbdat)
- (sqlite3:for-each-row
- (lambda (id test_id category variable value expected tol units comment status type)
- (set! res (cons (vector id test_id category variable value expected tol units comment status type) res)))
- db
- "SELECT id,test_id,category,variable,value,expected,tol,units,comment,status,type FROM test_data WHERE test_id=? AND category LIKE ? ORDER BY category,variable;" test-id categorypatt)
- (reverse res)))
+ (let* ((res '()))
+ (db:with-db
+ dbstruct #f #f
+ (lambda (db)
+ (sqlite3:for-each-row
+ (lambda (id test_id category variable value expected tol units comment status type)
+ (set! res (cons (vector id test_id category variable value expected tol units comment status type) res)))
+ db
+ "SELECT id,test_id,category,variable,value,expected,tol,units,comment,status,type FROM test_data WHERE test_id=? AND category LIKE ? ORDER BY category,variable;" test-id categorypatt)
+ (reverse res)))))
;;======================================================================
;; Misc. test related queries
;;======================================================================
(define (db:get-run-ids-matching-target dbstruct keynames target res runname testpatt statepatt statuspatt)
- (let* ((dbdat (db:get-db dbstruct #f))
- (db (db:dbdat-get-db dbdat))
- (row-ids '())
- (keystr (string-intersperse
- (map (lambda (key val)
- (conc key " like '" val "'"))
- keynames
- (string-split target "/"))
- " AND "))
- ;; (testqry (tests:match->sqlqry testpatt))
- (runsqry (sqlite3:prepare db (conc "SELECT id FROM runs WHERE " keystr " AND runname LIKE '" runname "';"))))
- ;; (debug:print 8 *default-log-port* "db:test-get-paths-matching-keynames-target-new\n runsqry=" runsqry "\n tstsqry=" testqry)
- (sqlite3:for-each-row
- (lambda (rid)
- (set! row-ids (cons rid row-ids)))
- runsqry)
- (sqlite3:finalize! runsqry)
- row-ids))
+ (db:with-db
+ dbstruct #f #f
+ (lambda (db)
+ (let* ((row-ids '())
+ (keystr (string-intersperse
+ (map (lambda (key val)
+ (conc key " like '" val "'"))
+ keynames
+ (string-split target "/"))
+ " AND "))
+ ;; (testqry (tests:match->sqlqry testpatt))
+ (runsqry (sqlite3:prepare db (conc "SELECT id FROM runs WHERE " keystr " AND runname LIKE '" runname "';"))))
+ ;; (debug:print 8 *default-log-port* "db:test-get-paths-matching-keynames-target-new\n runsqry=" runsqry "\n tstsqry=" testqry)
+ (sqlite3:for-each-row
+ (lambda (rid)
+ (set! row-ids (cons rid row-ids)))
+ runsqry)
+ (sqlite3:finalize! runsqry)
+ row-ids))))
;; finds latest matching all patts for given run-id
;;
(define (db:test-get-paths-matching-keynames-target-new dbstruct run-id keynames target res testpatt statepatt statuspatt runname)
(let* ((testqry (tests:match->sqlqry testpatt))
@@ -3126,140 +3156,111 @@
(print-call-chain (current-error-port))
msg))) ;; crude reply for when things go awry
((zmq nmsg)(with-input-from-string msg (lambda ()(deserialize))))
(else msg))) ;; rpc
-;; This is to be the big daddy call
-
-(define (db:test-set-status-state dbstruct run-id test-id status state msg)
- (let ((dbdat (db:get-db dbstruct run-id)))
- (if (member state '("LAUNCHED" "REMOTEHOSTSTART"))
- (db:general-call dbdat 'set-test-start-time (list test-id)))
- ;; (if msg
- ;; (db:general-call dbdat 'state-status-msg (list state status msg test-id))
- ;; (db:general-call dbdat 'state-status (list state status test-id)))
- (db:set-state-status-and-roll-up-items dbstruct run-id test-id #f state status msg)
- ;; process the test_data table
- (if (and test-id state status (equal? status "AUTO"))
- (db:test-data-rollup dbstruct run-id test-id status))
- (mt:process-triggers run-id test-id state status)))
+;; ; This is to be the big daddy call NOPE: Replaced by db:set-state-status-and-roll-up-items
+;; ;
+;; define (db:test-set-state-status dbstruct run-id test-id state status msg)
+;; (let ((dbdat (db:get-db dbstruct run-id)))
+;; (if (member state '("LAUNCHED" "REMOTEHOSTSTART"))
+;; (db:general-call dbdat 'set-test-start-time (list test-id)))
+;; ;; (if msg
+;; ;; (db:general-call dbdat 'state-status-msg (list state status msg test-id))
+;; ;; (db:general-call dbdat 'state-status (list state status test-id)))
+;; (db:set-state-status-and-roll-up-items dbstruct run-id test-id #f state status msg)
+;; ;; process the test_data table
+;; (if (and test-id state status (equal? status "AUTO"))
+;; (db:test-data-rollup dbstruct run-id test-id status))
+;; (mt:process-triggers dbstruct run-id test-id state status)))
;; state is the priority rollup of all states
;; status is the priority rollup of all completed statesfu
;;
;; if test-name is an integer work off that instead of test-name test-path
;;
(define (db:set-state-status-and-roll-up-items dbstruct run-id test-name item-path state status comment)
;; establish info on incoming test followed by info on top level test
- (let* ((db (db:dbdat-get-db (dbr:dbstruct-tmpdb dbstruct)))
- (testdat (if (number? test-name)
+ (let* ((testdat (if (number? test-name)
(db:get-test-info-by-id dbstruct run-id test-name) ;; test-name is actually a test-id
(db:get-test-info dbstruct run-id test-name item-path)))
(test-id (db:test-get-id testdat))
(test-name (if (number? test-name)
(db:test-get-testname testdat)
test-name))
(item-path (db:test-get-item-path testdat))
(tl-testdat (db:get-test-info dbstruct run-id test-name ""))
(tl-test-id (db:test-get-id tl-testdat)))
- (sqlite3:with-transaction
- db
- (lambda ()
- (db:test-set-state-status-by-id dbstruct run-id test-id state status comment)
- (if (not (equal? item-path "")) ;; only roll up IF incoming test is an item
- (let* ((state-status-counts (db:get-all-state-status-counts-for-test db run-id test-name item-path)) ;; item-path is used to exclude current state/status of THIS test
- (running (length (filter (lambda (x)
- (member (dbr:counts-state x) *common:running-states*))
- state-status-counts)))
- (bad-not-started (length (filter (lambda (x)
- (and (equal? (dbr:counts-state x) "NOT_STARTED")
- (not (member (dbr:counts-status x)
- *common:not-started-ok-statuses*))))
- state-status-counts)))
- (all-curr-states (common:special-sort ;; worst -> best (sort of)
- (delete-duplicates
- (cons state (map dbr:counts-state state-status-counts)))
- *common:std-states* >))
- (all-curr-statuses (common:special-sort ;; worst -> best
- (delete-duplicates
- (cons status (map dbr:counts-status state-status-counts)))
- *common:std-statuses* >))
- (newstate (if (> running 0)
- "RUNNING"
- (if (> bad-not-started 0)
- "COMPLETED"
- (car all-curr-states))))
- (newstatus (if (> bad-not-started 0)
- "CHECK"
- (car all-curr-statuses))))
- ;; (print "Setting toplevel to: " newstate "/" newstatus)
- (db:test-set-state-status-by-id dbstruct run-id tl-test-id newstate newstatus #f)))))))
-
-(define db:roll-up-pass-fail-counts db:set-state-status-and-roll-up-items)
-
-;; call with state = #f to roll up with out accounting for state/status of this item
-;;
-;; (define (db:roll-up-pass-fail-counts dbstruct run-id test-name item-path state status)
-;; (if (not (equal? item-path "")) ;; if asked to do this for a specific item then do an incremental update
-;; (let* ((dbdat (db:get-db dbstruct run-id))
-;; (toptestdat (db:get-test-info dbstruct run-id test-name item-path))
-;; (currtopstate (db:test-get-state toptestdat))
-;; (currtopstatus (db:test-get-status toptestdat))
-;; (nextss (common:apply-state-status currtopstate currtopstatus state status))
-;; (newtopstate (car nextss)) ;; #f or a symbol
-;; (newtopstatus (cdr nextss))) ;; #f or a symbol
-;; (if (not newtopstate) ;; need to calculate it
-;;
-;; ;; We rely on the toplevel to track status as state varies. I.e. preserve an ABORT
-;;
-;;
-;; ;; (db (db:dbdat-get-db dbdat)))
-;; (db:general-call dbdat 'update-pass-fail-counts (list test-name test-name test-name))
-;; (db:top-test-set-per-pf-counts dbstruct run-id test-name))))
-;;
-;; ;; (case (string->symbol status)
-;; ;; ((RUNNING) (db:general-call dbdat 'top-test-set-running (list test-name)))
-;; ;; ((LAUNCHED) (db:general-call dbdat 'top-test-set (list "LAUNCHED" test-name)))
-;; ;; ((ABORT INCOMPLETE) (db:general-call dbdat 'top-test-set (list status test-name))))
-;;
-;; ;; (if (or (not state)
-;; ;; (not (equal? item-path "")))
-;; ;; ;; just do a rollup
-;; ;; (begin
-;; ;; (db:top-test-set-per-pf-counts dbdat run-id test-name)
-;; ;; #f)
-;; ;; (begin
-;; ;; ;; NOTE: No else clause needed for this case
-;; ;; (case (string->symbol status)
-;; ;; ((RUNNING) (db:general-call dbdat 'top-test-set-running (list test-name)))
-;; ;; ((LAUNCHED) (db:general-call dbdat 'top-test-set (list "LAUNCHED" test-name)))
-;; ;; ((ABORT INCOMPLETE) (db:general-call dbdat 'top-test-set (list status test-name))))
-;; ;; #f)
-;; ;; )))
-
-(define (db:get-all-state-status-counts-for-test db run-id test-name item-path)
- (sqlite3:map-row
- (lambda (state status count)
- (make-dbr:counts state: state status: status count: count))
- db
- "SELECT state,status,count(id) FROM tests WHERE run_id=? AND testname=? AND item_path != '' AND item_path !=? GROUP BY state,status;"
- run-id test-name item-path))
-
-
-(define (db:get-all-item-states db run-id test-name)
- (sqlite3:map-row
- (lambda (a) a)
- db
- "SELECT DISTINCT state FROM tests WHERE item_path != '' AND state != 'DELETED' AND run_id=? AND testname=?"
- run-id test-name))
-
-(define (db:get-all-item-statuses db run-id test-name)
- (sqlite3:map-row
- (lambda (a) a)
- db
- "SELECT DISTINCT status FROM tests WHERE item_path != '' AND state != 'DELETED' AND state='COMPLETED' AND run_id=? AND testname=?"
- run-id test-name))
+ (if (member state '("LAUNCHED" "REMOTEHOSTSTART"))
+ (db:general-call dbstruct 'set-test-start-time (list test-id)))
+ (mutex-lock! *db-transaction-mutex*)
+ (db:with-db
+ dbstruct #f #f
+ (lambda (db)
+ (let ((tr-res
+ (sqlite3:with-transaction
+ db
+ (lambda ()
+ ;; NB// Pass the db so it is part fo the transaction
+ (db:test-set-state-status db run-id test-id state status comment)
+ (if (not (equal? item-path "")) ;; only roll up IF incoming test is an item
+ (let* ((state-status-counts (db:get-all-state-status-counts-for-test dbstruct run-id test-name item-path)) ;; item-path is used to exclude current state/status of THIS test
+ (running (length (filter (lambda (x)
+ (member (dbr:counts-state x) *common:running-states*))
+ state-status-counts)))
+ (bad-not-started (length (filter (lambda (x)
+ (and (equal? (dbr:counts-state x) "NOT_STARTED")
+ (not (member (dbr:counts-status x)
+ *common:not-started-ok-statuses*))))
+ state-status-counts)))
+ (all-curr-states (common:special-sort ;; worst -> best (sort of)
+ (delete-duplicates
+ (cons state (map dbr:counts-state state-status-counts)))
+ *common:std-states* >))
+ (all-curr-statuses (common:special-sort ;; worst -> best
+ (delete-duplicates
+ (cons status (map dbr:counts-status state-status-counts)))
+ *common:std-statuses* >))
+ (newstate (if (> running 0)
+ "RUNNING"
+ (if (> bad-not-started 0)
+ "COMPLETED"
+ (car all-curr-states))))
+ (newstatus (if (> bad-not-started 0)
+ "CHECK"
+ (car all-curr-statuses))))
+ ;; NB// Pass the db so it is part of the transaction
+ (db:test-set-state-status db run-id tl-test-id newstate newstatus #f)))))))
+ (mutex-unlock! *db-transaction-mutex*)
+ (if (and test-id state status (equal? status "AUTO"))
+ (db:test-data-rollup dbstruct run-id test-id status))
+ tr-res)))))
+
+(define (db:get-all-state-status-counts-for-test dbstruct run-id test-name item-path)
+ (db:with-db
+ dbstruct #f #f
+ (lambda (db)
+ (sqlite3:map-row
+ (lambda (state status count)
+ (make-dbr:counts state: state status: status count: count))
+ db
+ "SELECT state,status,count(id) FROM tests WHERE run_id=? AND testname=? AND item_path != '' AND item_path !=? GROUP BY state,status;"
+ run-id test-name item-path))))
+
+;; (define (db:get-all-item-states db run-id test-name)
+;; (sqlite3:map-row
+;; (lambda (a) a)
+;; db
+;; "SELECT DISTINCT state FROM tests WHERE item_path != '' AND state != 'DELETED' AND run_id=? AND testname=?"
+;; run-id test-name))
+;;
+;; (define (db:get-all-item-statuses db run-id test-name)
+;; (sqlite3:map-row
+;; (lambda (a) a)
+;; db
+;; "SELECT DISTINCT status FROM tests WHERE item_path != '' AND state != 'DELETED' AND state='COMPLETED' AND run_id=? AND testname=?"
+;; run-id test-name))
(define (db:test-get-logfile-info dbstruct run-id test-name)
(db:with-db
dbstruct
run-id
@@ -3317,11 +3318,11 @@
'(update-cpuload-diskfree "UPDATE tests SET cpuload=?,diskfree=? WHERE id=?;") ;; DONE
'(update-uname-host "UPDATE tests SET uname=?,host=? WHERE id=?;") ;; DONE
'(update-test-rundat "INSERT INTO test_rundat (test_id,update_time,cpuload,diskfree,diskusage,run_duration) VALUES (?,?,?,?,?,?);")
'(update-test-state "UPDATE tests SET state=? WHERE state=? AND run_id=? AND testname=? AND NOT (item_path='' AND testname IN (SELECT DISTINCT testname FROM tests WHERE testname=? AND item_path != ''));")
'(update-test-status "UPDATE tests SET status=? WHERE status like ? AND run_id=? AND testname=? AND NOT (item_path='' AND testname IN (SELECT DISTINCT testname FROM tests WHERE testname=? AND item_path != ''));")
- ;; stuff for roll-up-pass-fail-counts
+ ;; stuff for set-state-status-and-roll-up-items
'(update-pass-fail-counts "UPDATE tests
SET fail_count=(SELECT count(id) FROM tests WHERE testname=? AND item_path != '' AND status IN ('FAIL','CHECK','INCOMPLETE','ABORT')),
pass_count=(SELECT count(id) FROM tests WHERE testname=? AND item_path != '' AND status IN ('PASS','WARN','WAIVED'))
WHERE testname=? AND item_path='' AND run_id=?;") ;; DONE ;; BROKEN!!! NEEDS run-id
'(top-test-set-running "UPDATE tests SET state='RUNNING' WHERE testname=? AND item_path='' AND run_id=?;") ;; DONE ;; BROKEN!!! NEEDS run-id
@@ -3425,11 +3426,11 @@
(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!?
+ ;; db:set-state-status-and-roll-up-items ;; WHY NOT!?
login
immediate
flush
sync
set-verbosity
@@ -3446,38 +3447,50 @@
(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 dbdat stmtname params)
+(define (db:general-call dbstruct stmtname params)
(let ((query (let ((q (alist-ref (if (string? stmtname)
(string->symbol stmtname)
stmtname)
db:queries)))
(if q (car q) #f))))
- ;; (db:delay-if-busy dbdat)
- (apply sqlite3:execute (db:dbdat-get-db dbdat) query params)
- #t))
+ (db:with-db
+ dbstruct #f #f
+ (lambda (db)
+ (apply sqlite3:execute db query params)
+ #t))))
;; get a summary of state and status counts to calculate a rollup
;;
-;; NOTE: takes a db, not a dbstruct
-;;
-(define (db:get-state-status-summary db run-id testname)
+(define (db:get-state-status-summary dbstruct run-id testname)
(let ((res '()))
- (sqlite3:for-each-row
- (lambda (state status count)
- (set! res (cons (vector state status count) res)))
- db
- "SELECT state,status,count(state) FROM tests WHERE run_id=? AND testname=? AND item_path='' GROUP BY state,status;"
- run-id testname)
- res))
+ (db:with-db
+ dbstruct #f #f
+ (sqlite3:for-each-row
+ (lambda (state status count)
+ (set! res (cons (vector state status count) res)))
+ db
+ "SELECT state,status,count(state) FROM tests WHERE run_id=? AND testname=? AND item_path='' GROUP BY state,status;"
+ run-id testname)
+ res)))
+
+(define (db:get-latest-host-load dbstruct raw-hostname)
+ (let* ((hostname (string-substitute "\\..*$" "" raw-hostname))
+ (res (cons -1 0)))
+ (db:with-db
+ dbstruct #f #f
+ (lambda (db)
+ (sqlite3:for-each-row
+ (lambda (cpuload update-time) (set! res (cons cpuload update-time)))
+ db
+ "SELECT tr.cpuload, tr.update_time FROM test_rundat tr, tests t WHERE t.host=? AND tr.cpuload != -1 AND tr.test_id=t.id ORDER BY tr.update_time DESC LIMIT 1;"
+ hostname))) res ))
(define (db:set-top-level-from-items dbstruct run-id testname)
- (let* ((dbdat (db:get-db dbstruct run-id))
- (db (db:dbdat-get-db dbdat))
- (summ (db:get-state-status-summary db run-id testname))
+ (let* ((summ (db:get-state-status-summary dbstruct run-id testname))
(find (lambda (state status)
(if (null? summ)
#f
(let loop ((hed (car summ))
(tal (cdr summ)))
@@ -3502,32 +3515,35 @@
;; 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* ((dbdat (db:get-db dbstruct #f))
- (db (db:dbdat-get-db dbdat))
- (keys (db:get-keys dbstruct))
+ (let* ((keys (db:get-keys dbstruct))
(selstr (string-intersperse keys ","))
(qrystr (string-intersperse (map (lambda (x)(conc x "=?")) keys) " AND "))
(keyvals #f)
(tests-hash (make-hash-table)))
;; first look up the key values from the run selected by run-id
- ;; (db:delay-if-busy dbdat)
- (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)
+ (db:with-db
+ dbstruct #f #f
+ (lambda (db)
+ (sqlite3:for-each-row
+ (lambda (a . b)
+ (set! keyvals (cons a b)))
+ db
+ (conc "SELECT " selstr " FROM runs WHERE id=? ORDER BY event_time DESC;") run-id)))
(if (not keyvals)
'()
(let ((prev-run-ids '()))
- (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)))
+ (db:with-db
+ dbstruct #f #f
+ (lambda (db)
+ (apply sqlite3:for-each-row
+ (lambda (id)
+ (set! prev-run-ids (cons id prev-run-ids)))
+ db
+ (conc "SELECT id FROM runs WHERE " qrystr " AND id != ?;") (append keyvals (list run-id)))))
;; collect all matching tests for the runs then
;; extract the most recent test and return that.
(debug:print 4 *default-log-port* "selstr: " selstr ", qrystr: " qrystr ", keyvals: " keyvals
", previous run ids found: " prev-run-ids)
(if (null? prev-run-ids) '() ;; no previous runs? return null
@@ -3609,10 +3625,30 @@
res))))
;;======================================================================
;; Tests meta data
;;======================================================================
+
+;; returns a hash table of tags to tests
+;;
+(define (db:get-tests-tags dbstruct)
+ (db:with-db
+ dbstruct #f #f
+ (lambda (db)
+ (let* ((res (make-hash-table)))
+ (sqlite3:for-each-row
+ (lambda (testname tags-in)
+ (let ((tags (string-split tags-in ",")))
+ (for-each
+ (lambda (tag)
+ (hash-table-set! res tag
+ (delete-duplicates
+ (cons testname (hash-table-ref/default res tag '())))))
+ tags)))
+ db
+ "SELECT testname,tags FROM test_meta")
+ res))))
;; read the record given a testname
(define (db:testmeta-get-record dbstruct testname)
(let ((res #f))
(db:with-db
@@ -3796,11 +3832,11 @@
(define (db:extract-ods-file dbstruct outputfile keypatt-alist runspatt pathmod)
(let* ((keysstr (string-intersperse (map car keypatt-alist) ","))
(keyqry (string-intersperse (map (lambda (p)(conc (car p) " LIKE ? ")) keypatt-alist) " AND "))
(numkeys (length keypatt-alist))
(test-ids '())
- (dbdat (db:get-db dbstruct #f))
+ (dbdat (db:get-db dbstruct))
(db (db:dbdat-get-db dbdat))
(windows (and pathmod (substring-index "\\" pathmod)))
(tempdir (conc "/tmp/" (current-user-name) "/" runspatt "_" (random 10000) "_" (current-process-id)))
(runsheader (append (list "Run Id" "Runname") ; 0 1
(map car keypatt-alist) ; + N = length keypatt-alist
ADDED diff-report.scm
Index: diff-report.scm
==================================================================
--- /dev/null
+++ diff-report.scm
@@ -0,0 +1,190 @@
+;; #!/bin/bash
+
+;; #;; rmt:get-tests-for-run
+
+
+;; #;; (let* ((dbstruct (db:get-db
+
+
+;; #;; (db:get-tests-for-run dbstruct run-id testpatt states statuses offset limit not-in sort-by sort-order qryvals last-update mode)
+
+;; #;; (rmt:get-test-info-by-id run-id test-id)
+;; #;; (rmt:get-tests-for-run run-id testpatt states statuses offset limit not-in sort-by sort-order qryvals last-update mode)
+
+;; megatest -repl << EOF
+
+;; TODO:dashboard not on homehost message exit
+
+
+(define (tests-mindat->hash tests-mindat)
+ (let* ((res (make-hash-table)))
+ (for-each
+ (lambda (item)
+ (let* ((test-name+item-path (cons (list-ref item 0) (list-ref item 1)))
+ (value (list-ref item 2)))
+ (hash-table-set! res test-name+item-path value)))
+ tests-mindat)
+ res))
+
+;; return 1 if status1 is better
+;; return 0 if status1 and 2 are equally good
+;; return -1 if status2 is better
+(define (status-compare3 status1 status2)
+ (let*
+ ((status-goodness-ranking (list "PASS" "WARN" "WAIVED" "SKIP" "FAIL" "ABORT" #f))
+ (mem1 (member status1 status-goodness-ranking))
+ (mem2 (member status2 status-goodness-ranking))
+ )
+ (cond
+ ((and (not mem1) (not mem2)) 0)
+ ((not mem1) -1)
+ ((not mem2) 1)
+ ((= (length mem1) (length mem2)) 0)
+ ((> (length mem1) (length mem2)) 1)
+ (else -1))))
+
+
+(define (xor-tests-mindat src-tests-mindat dest-tests-mindat #!key (hide-clean #f))
+ (let* ((src-hash (tests-mindat->hash src-tests-mindat))
+ (dest-hash (tests-mindat->hash dest-tests-mindat))
+ (all-keys
+ (reverse (sort
+ (delete-duplicates
+ (append (hash-table-keys src-hash) (hash-table-keys dest-hash)))
+
+ (lambda (a b)
+ (cond
+ ((< 0 (string-compare3 (car a) (car b))) #t)
+ ((> 0 (string-compare3 (car a) (car b))) #f)
+ ((< 0 (string-compare3 (cdr a) (cdr b))) #t)
+ (else #f)))
+
+ ))))
+ (let ((res
+ (map ;; TODO: rename xor to delta globally in dcommon and dashboard
+ (lambda (key)
+ (let* ((test-name (car key))
+ (item-path (cdr key))
+
+ (dest-value (hash-table-ref/default dest-hash key #f)) ;; (list test-id state status)
+ (dest-test-id (if dest-value (list-ref dest-value 0) #f))
+ (dest-state (if dest-value (list-ref dest-value 1) #f))
+ (dest-status (if dest-value (list-ref dest-value 2) #f))
+
+ (src-value (hash-table-ref/default src-hash key #f)) ;; (list test-id state status)
+ (src-test-id (if src-value (list-ref src-value 0) #f))
+ (src-state (if src-value (list-ref src-value 1) #f))
+ (src-status (if src-value (list-ref src-value 2) #f))
+
+ (incomplete-statuses '("DELETED" "INCOMPLETE" "STUCK/DEAD" "N/A")) ;; if any of these statuses apply, treat test as incomplete
+
+ (dest-complete
+ (and dest-value dest-state dest-status
+ (equal? dest-state "COMPLETED")
+ (not (member dest-status incomplete-statuses))))
+ (src-complete
+ (and src-value src-state src-status
+ (equal? src-state "COMPLETED")
+ (not (member src-status incomplete-statuses))))
+ (status-compare-result (status-compare3 src-status dest-status))
+ (xor-new-item
+ (cond
+ ;; complete, for this case means: state=compelte AND status not in ( deleted uncomplete stuck/dead n/a )
+ ;; neither complete -> bad
+
+ ;; src !complete, dest complete -> better
+ ((and (not dest-complete) (not src-complete))
+ (list dest-test-id "BOTH-BAD" "BOTH-INCOMPLETE"))
+ ((not dest-complete)
+ (list src-test-id "DIFF-MISSING" "DEST-INCOMPLETE"))
+ ((not src-complete)
+ (list dest-test-id "DIFF-NEW" "SRC-INCOMPLETE"))
+ ((and
+ (equal? src-state dest-state)
+ (equal? src-status dest-status))
+ (list dest-test-id (conc "CLEAN") (conc "CLEAN-" dest-status) ))
+ ;; better or worse: pass > warn > waived > skip > fail > abort
+ ;; pass > warn > waived > skip > fail > abort
+
+ ((= 1 status-compare-result) ;; src is better, dest is worse
+ (list dest-test-id "DIRTY-WORSE" (conc src-status "->" dest-status)))
+ (else
+ (list dest-test-id "DIRTY-BETTER" (conc src-status "->" dest-status)))
+ )))
+ (list test-name item-path xor-new-item)))
+ all-keys)))
+
+ (if hide-clean
+ (filter
+ (lambda (item)
+ ;;(print item)
+ (not
+ (equal?
+ "CLEAN"
+ (list-ref (list-ref item 2) 1))))
+ res)
+ res))))
+
+(define (run-name->run-id runname)
+ (let* ((qry-res (rmt:get-runs runname 1 0 '())))
+ (if (eq? 2 (vector-length qry-res))
+ (vector-ref (car (vector-ref qry-res 1)) 1)
+ #f)))
+
+
+
+
+(define (run-name->tests-mindat runname)
+ (let* ((run-id (run-name->run-id runname))
+ (testpatt "%/%")
+;; (states '("COMPLETED" "INCOMPLETE"))
+ ;; (statuses '("PASS" "FAIL" "ABORT" "SKIP"))
+ (states '())
+ (statuses '())
+ (offset #f)
+ (limit #f)
+ (not-in #t)
+ (sort-by #f)
+ (sort-order #f)
+ (qryvals "id,testname,item_path,state,status")
+ (qryvals "id,testname,item_path,state,status")
+ (last-update 0)
+ (mode #f)
+ )
+ (print run-id)
+ (map
+ (lambda (row)
+ (let* ((id (vector-ref row 0))
+ (test-name (vector-ref row 1))
+ (item-path (vector-ref row 2))
+ (state (vector-ref row 3))
+ (status (vector-ref row 4)))
+ ;;(hash-table-set! ht (cons testname item_path) (list id state status))
+ (list test-name item-path (list id state status))
+ ;;(print testname id))
+ ))
+ (rmt:get-tests-for-run run-id
+ testpatt states statuses
+ offset limit
+ not-in sort-by sort-order
+ qryvals
+ last-update
+ mode))
+ ;(print (rmt:get-tests-for-run run-id testpatt states statuses offset limit not-in "%" "%" #f "id,testname,testpath,state,status" 0 'normal))
+ ;(print run-id)
+
+ ))
+
+(print (run-name->tests-mindat "all60"))
+
+
+
+(let* ((src-tests-mindat (run-name->tests-mindat "all57"))
+ (dest-tests-mindat (run-name->tests-mindat "all60")))
+ (print (xor-tests-mindat src-tests-mindat dest-tests-mindat)));; #!key (hide-clean #f))
+
+;;(exit)
+
+;;EOF
+
+
Index: docs/inprogress/megatest-architecture-proposed-2.fig
==================================================================
--- docs/inprogress/megatest-architecture-proposed-2.fig
+++ docs/inprogress/megatest-architecture-proposed-2.fig
@@ -13,35 +13,140 @@
2 1 0 1 0 7 50 -1 -1 0.000 0 0 -1 0 0 2
675 1575 675 2175
2 1 0 1 0 7 50 -1 -1 0.000 0 0 -1 0 0 2
1575 1500 1575 2175
-6
-6 1875 825 2850 1875
-1 1 0 1 0 7 50 -1 -1 0.000 1 0.0000 2400 975 450 150 2400 975 2850 1125
-1 1 0 1 0 7 50 -1 -1 0.000 1 0.0000 2399 1652 450 150 2399 1652 2849 1802
-2 1 0 1 0 7 50 -1 -1 0.000 0 0 -1 0 0 2
- 1950 1050 1950 1650
-2 1 0 1 0 7 50 -1 -1 0.000 0 0 -1 0 0 2
- 2850 975 2850 1650
--6
-6 3225 450 4200 1500
-1 1 0 1 0 7 50 -1 -1 0.000 1 0.0000 3750 600 450 150 3750 600 4200 750
-1 1 0 1 0 7 50 -1 -1 0.000 1 0.0000 3749 1277 450 150 3749 1277 4199 1427
-2 1 0 1 0 7 50 -1 -1 0.000 0 0 -1 0 0 2
- 3300 675 3300 1275
-2 1 0 1 0 7 50 -1 -1 0.000 0 0 -1 0 0 2
- 4200 600 4200 1275
--6
-6 3075 2925 4050 3975
-1 1 0 1 0 7 50 -1 -1 0.000 1 0.0000 3600 3075 450 150 3600 3075 4050 3225
-1 1 0 1 0 7 50 -1 -1 0.000 1 0.0000 3599 3752 450 150 3599 3752 4049 3902
-2 1 0 1 0 7 50 -1 -1 0.000 0 0 -1 0 0 2
- 3150 3150 3150 3750
-2 1 0 1 0 7 50 -1 -1 0.000 0 0 -1 0 0 2
- 4050 3075 4050 3750
--6
-6 7275 4050 12825 9675
+6 14100 150 19950 6075
+6 14850 1350 15825 2400
+1 1 0 1 0 7 50 -1 -1 0.000 1 0.0000 15375 1500 450 150 15375 1500 15825 1650
+1 1 0 1 0 7 50 -1 -1 0.000 1 0.0000 15374 2177 450 150 15374 2177 15824 2327
+2 1 0 1 0 7 50 -1 -1 0.000 0 0 -1 0 0 2
+ 14925 1575 14925 2175
+2 1 0 1 0 7 50 -1 -1 0.000 0 0 -1 0 0 2
+ 15825 1500 15825 2175
+-6
+2 4 0 1 0 7 50 -1 -1 0.000 0 0 7 0 0 5
+ 17025 4050 17025 3450 15750 3450 15750 4050 17025 4050
+2 1 0 1 0 7 50 -1 -1 3.000 0 0 -1 1 1 2
+ 0 0 1.00 60.00 120.00
+ 0 0 1.00 60.00 120.00
+ 16050 3375 15525 2400
+2 2 0 1 0 7 50 -1 -1 0.000 0 0 -1 0 0 5
+ 15825 5325 17175 5325 17175 5850 15825 5850 15825 5325
+2 1 0 1 0 7 50 -1 -1 3.000 0 0 -1 1 1 2
+ 0 0 1.00 60.00 120.00
+ 0 0 1.00 60.00 120.00
+ 16350 4050 16350 5325
+2 2 0 1 0 7 50 -1 -1 0.000 0 0 -1 0 0 5
+ 17550 4800 18900 4800 18900 5325 17550 5325 17550 4800
+2 2 0 1 0 7 50 -1 -1 0.000 0 0 -1 0 0 5
+ 18375 3900 19725 3900 19725 4425 18375 4425 18375 3900
+2 1 0 1 0 7 50 -1 -1 3.000 0 0 -1 1 1 2
+ 0 0 1.00 60.00 120.00
+ 0 0 1.00 60.00 120.00
+ 16725 4050 17850 4800
+2 1 0 1 0 7 50 -1 -1 3.000 0 0 -1 1 1 2
+ 0 0 1.00 60.00 120.00
+ 0 0 1.00 60.00 120.00
+ 17025 3750 18375 4125
+2 1 0 1 14 7 50 -1 -1 3.000 0 0 -1 1 1 3
+ 0 0 1.00 60.00 120.00
+ 0 0 1.00 60.00 120.00
+ 18975 3900 18075 2625 15900 1875
+2 2 0 1 0 7 50 -1 -1 3.000 0 0 -1 0 0 5
+ 14100 150 19950 150 19950 6075 14100 6075 14100 150
+4 0 0 50 -1 0 12 0.0000 4 150 900 15825 3675 rpc-server\001
+4 0 0 50 -1 0 12 0.0000 4 165 270 17475 3825 tcp\001
+4 0 0 50 -1 0 12 0.0000 4 120 315 18525 4125 test\001
+4 0 0 50 -1 0 12 0.0000 4 195 1065 14850 1200 megatest.db\001
+4 0 0 50 -1 0 12 0.0000 4 150 1020 14325 525 basic model\001
+-6
+6 14850 7425 15825 8475
+1 1 0 1 0 7 50 -1 -1 0.000 1 0.0000 15375 7575 450 150 15375 7575 15825 7725
+1 1 0 1 0 7 50 -1 -1 0.000 1 0.0000 15374 8252 450 150 15374 8252 15824 8402
+2 1 0 1 0 7 50 -1 -1 0.000 0 0 -1 0 0 2
+ 14925 7650 14925 8250
+2 1 0 1 0 7 50 -1 -1 0.000 0 0 -1 0 0 2
+ 15825 7575 15825 8250
+-6
+6 17775 6675 18750 7725
+1 1 0 1 0 7 50 -1 -1 0.000 1 0.0000 18300 6825 450 150 18300 6825 18750 6975
+1 1 0 1 0 7 50 -1 -1 0.000 1 0.0000 18299 7502 450 150 18299 7502 18749 7652
+2 1 0 1 0 7 50 -1 -1 0.000 0 0 -1 0 0 2
+ 17850 6900 17850 7500
+2 1 0 1 0 7 50 -1 -1 0.000 0 0 -1 0 0 2
+ 18750 6825 18750 7500
+-6
+6 6150 2700 7500 3225
+2 2 0 1 0 7 50 -1 -1 0.000 0 0 -1 0 0 5
+ 6150 2700 7500 2700 7500 3225 6150 3225 6150 2700
+4 0 0 50 -1 0 12 0.0000 4 180 870 6225 2925 run2/test1\001
+-6
+6 2025 675 3000 1725
+1 1 0 1 0 7 50 -1 -1 0.000 1 0.0000 2550 825 450 150 2550 825 3000 975
+1 1 0 1 0 7 50 -1 -1 0.000 1 0.0000 2549 1502 450 150 2549 1502 2999 1652
+2 1 0 1 0 7 50 -1 -1 0.000 0 0 -1 0 0 2
+ 2100 900 2100 1500
+2 1 0 1 0 7 50 -1 -1 0.000 0 0 -1 0 0 2
+ 3000 825 3000 1500
+-6
+6 675 7275 1650 8325
+1 1 0 1 0 7 50 -1 -1 0.000 1 0.0000 1200 7425 450 150 1200 7425 1650 7575
+1 1 0 1 0 7 50 -1 -1 0.000 1 0.0000 1199 8102 450 150 1199 8102 1649 8252
+2 1 0 1 0 7 50 -1 -1 0.000 0 0 -1 0 0 2
+ 750 7500 750 8100
+2 1 0 1 0 7 50 -1 -1 0.000 0 0 -1 0 0 2
+ 1650 7425 1650 8100
+-6
+6 3675 6675 4650 7725
+1 1 0 1 0 7 50 -1 -1 0.000 1 0.0000 4200 6825 450 150 4200 6825 4650 6975
+1 1 0 1 0 7 50 -1 -1 0.000 1 0.0000 4199 7502 450 150 4199 7502 4649 7652
+2 1 0 1 0 7 50 -1 -1 0.000 0 0 -1 0 0 2
+ 3750 6900 3750 7500
+2 1 0 1 0 7 50 -1 -1 0.000 0 0 -1 0 0 2
+ 4650 6825 4650 7500
+-6
+6 900 3825 2175 4425
+2 4 0 1 0 7 50 -1 -1 0.000 0 0 7 0 0 5
+ 2175 4425 2175 3825 900 3825 900 4425 2175 4425
+4 0 0 50 -1 0 12 0.0000 4 150 720 1050 4125 server-1\001
+-6
+6 150 5475 1500 6000
+2 2 0 1 0 7 50 -1 -1 0.000 0 0 -1 0 0 5
+ 150 5475 1500 5475 1500 6000 150 6000 150 5475
+4 0 0 50 -1 0 12 0.0000 4 180 870 300 5700 run1/test1\001
+-6
+6 1725 5400 3075 5925
+2 2 0 1 0 7 50 -1 -1 0.000 0 0 -1 0 0 5
+ 1725 5400 3075 5400 3075 5925 1725 5925 1725 5400
+4 0 0 50 -1 0 12 0.0000 4 180 870 1800 5625 run1/test2\001
+-6
+6 5400 5100 6375 6975
+6 5400 5100 6375 6150
+1 1 0 1 0 7 50 -1 -1 0.000 1 0.0000 5925 5250 450 150 5925 5250 6375 5400
+1 1 0 1 0 7 50 -1 -1 0.000 1 0.0000 5924 5927 450 150 5924 5927 6374 6077
+2 1 0 1 0 7 50 -1 -1 0.000 0 0 -1 0 0 2
+ 5475 5325 5475 5925
+2 1 0 1 0 7 50 -1 -1 0.000 0 0 -1 0 0 2
+ 6375 5250 6375 5925
+-6
+4 0 0 50 -1 0 12 0.0000 4 195 885 5475 6375 postgresql\001
+4 0 0 50 -1 0 12 0.0000 4 195 555 5475 6630 sqlite3\001
+4 0 0 50 -1 0 12 0.0000 4 195 510 5475 6885 mysql\001
+-6
+6 4050 675 6000 2175
+6 4125 900 5100 1950
+1 1 0 1 0 7 50 -1 -1 0.000 1 0.0000 4650 1050 450 150 4650 1050 5100 1200
+1 1 0 1 0 7 50 -1 -1 0.000 1 0.0000 4649 1727 450 150 4649 1727 5099 1877
+2 1 0 1 0 7 50 -1 -1 0.000 0 0 -1 0 0 2
+ 4200 1125 4200 1725
+2 1 0 1 0 7 50 -1 -1 0.000 0 0 -1 0 0 2
+ 5100 1050 5100 1725
+-6
+4 0 0 50 -1 0 12 0.0000 4 195 1905 4050 2100 pointers to the servers\001
+4 0 0 50 -1 0 12 0.0000 4 150 930 4200 825 monitor.db\001
+-6
6 8175 4125 8400 8625
2 2 0 1 0 7 50 -1 -1 0.000 0 0 -1 0 0 5
8175 4125 8400 4125 8400 4350 8175 4350 8175 4125
2 2 0 1 0 7 50 -1 -1 0.000 0 0 -1 0 0 5
8175 4350 8400 4350 8400 4575 8175 4575 8175 4350
@@ -248,165 +353,14 @@
2 2 0 1 0 7 50 -1 -1 0.000 0 0 -1 0 0 5
9375 8175 9600 8175 9600 8400 9375 8400 9375 8175
2 2 0 1 0 7 50 -1 -1 0.000 0 0 -1 0 0 5
9375 8400 9600 8400 9600 8625 9375 8625 9375 8400
-6
-# Dimension line: 1-1/16 in
-6 7875 9375 9150 9675
-# main dimension line
-2 1 0 1 0 7 50 -1 -1 4.000 0 0 -1 1 1 2
- 1 1 1.00 60.00 120.00
- 1 1 1.00 60.00 120.00
- 7875 9525 9150 9525
-# text box
-2 3 0 1 4 7 49 -1 20 0.000 0 0 -1 0 0 5
- 8085 9375 8085 9675 8939 9675 8939 9375 8085 9375
-# tick
-2 1 0 1 0 7 50 -1 -1 4.000 0 0 -1 0 0 2
- 7875 9375 7875 9675
-# tick
-2 1 0 1 0 7 50 -1 -1 4.000 0 0 -1 0 0 2
- 9150 9375 9150 9675
-4 1 0 48 -1 0 12 -0.0000 4 180 735 8512 9585 1-1/16 in\001
--6
-# Dimension line: 1-11/16 in
-6 7425 4125 7725 6150
-# main dimension line
-2 1 0 1 0 7 50 -1 -1 4.000 0 0 -1 1 1 2
- 1 1 1.00 60.00 120.00
- 1 1 1.00 60.00 120.00
- 7575 4125 7575 6150
-# text box
-2 3 0 1 4 7 49 -1 20 0.000 0 0 -1 0 0 5
- 7425 5617 7725 5617 7725 4657 7425 4657 7425 5617
-# tick
-2 1 0 1 0 7 50 -1 -1 4.000 0 0 -1 0 0 2
- 7425 6150 7725 6150
-# tick
-2 1 0 1 0 7 50 -1 -1 4.000 0 0 -1 0 0 2
- 7425 4125 7725 4125
-4 1 0 48 -1 0 12 1.5708 4 180 840 7635 5137 1-11/16 in\001
--6
-2 2 0 1 0 7 50 -1 -1 0.000 0 0 -1 0 0 5
- 7800 4050 12825 4050 12825 8925 7800 8925 7800 4050
-2 2 0 1 0 7 50 -1 -1 0.000 0 0 -1 0 0 5
- 9225 6225 12450 6225 12450 8325 9225 8325 9225 6225
-2 2 0 1 4 7 50 -1 -1 0.000 0 0 -1 0 0 5
- 9225 6150 9675 6150 9675 8400 9225 8400 9225 6150
-4 0 0 50 -1 0 12 0.0000 4 150 150 8475 9300 X\001
-4 0 0 50 -1 0 12 0.0000 4 150 135 7275 6975 Y\001
--6
-6 14100 150 19950 6075
-6 14850 1350 15825 2400
-1 1 0 1 0 7 50 -1 -1 0.000 1 0.0000 15375 1500 450 150 15375 1500 15825 1650
-1 1 0 1 0 7 50 -1 -1 0.000 1 0.0000 15374 2177 450 150 15374 2177 15824 2327
-2 1 0 1 0 7 50 -1 -1 0.000 0 0 -1 0 0 2
- 14925 1575 14925 2175
-2 1 0 1 0 7 50 -1 -1 0.000 0 0 -1 0 0 2
- 15825 1500 15825 2175
--6
-2 4 0 1 0 7 50 -1 -1 0.000 0 0 7 0 0 5
- 17025 4050 17025 3450 15750 3450 15750 4050 17025 4050
-2 1 0 1 0 7 50 -1 -1 3.000 0 0 -1 1 1 2
- 0 0 1.00 60.00 120.00
- 0 0 1.00 60.00 120.00
- 16050 3375 15525 2400
-2 2 0 1 0 7 50 -1 -1 0.000 0 0 -1 0 0 5
- 15825 5325 17175 5325 17175 5850 15825 5850 15825 5325
-2 1 0 1 0 7 50 -1 -1 3.000 0 0 -1 1 1 2
- 0 0 1.00 60.00 120.00
- 0 0 1.00 60.00 120.00
- 16350 4050 16350 5325
-2 2 0 1 0 7 50 -1 -1 0.000 0 0 -1 0 0 5
- 17550 4800 18900 4800 18900 5325 17550 5325 17550 4800
-2 2 0 1 0 7 50 -1 -1 0.000 0 0 -1 0 0 5
- 18375 3900 19725 3900 19725 4425 18375 4425 18375 3900
-2 1 0 1 0 7 50 -1 -1 3.000 0 0 -1 1 1 2
- 0 0 1.00 60.00 120.00
- 0 0 1.00 60.00 120.00
- 16725 4050 17850 4800
-2 1 0 1 0 7 50 -1 -1 3.000 0 0 -1 1 1 2
- 0 0 1.00 60.00 120.00
- 0 0 1.00 60.00 120.00
- 17025 3750 18375 4125
-2 1 0 1 14 7 50 -1 -1 3.000 0 0 -1 1 1 3
- 0 0 1.00 60.00 120.00
- 0 0 1.00 60.00 120.00
- 18975 3900 18075 2625 15900 1875
-2 2 0 1 0 7 50 -1 -1 3.000 0 0 -1 0 0 5
- 14100 150 19950 150 19950 6075 14100 6075 14100 150
-4 0 0 50 -1 0 12 0.0000 4 150 900 15825 3675 rpc-server\001
-4 0 0 50 -1 0 12 0.0000 4 165 270 17475 3825 tcp\001
-4 0 0 50 -1 0 12 0.0000 4 120 315 18525 4125 test\001
-4 0 0 50 -1 0 12 0.0000 4 195 1065 14850 1200 megatest.db\001
-4 0 0 50 -1 0 12 0.0000 4 150 1020 14325 525 basic model\001
--6
-6 14850 7425 15825 8475
-1 1 0 1 0 7 50 -1 -1 0.000 1 0.0000 15375 7575 450 150 15375 7575 15825 7725
-1 1 0 1 0 7 50 -1 -1 0.000 1 0.0000 15374 8252 450 150 15374 8252 15824 8402
-2 1 0 1 0 7 50 -1 -1 0.000 0 0 -1 0 0 2
- 14925 7650 14925 8250
-2 1 0 1 0 7 50 -1 -1 0.000 0 0 -1 0 0 2
- 15825 7575 15825 8250
--6
-6 17775 6675 18750 7725
-1 1 0 1 0 7 50 -1 -1 0.000 1 0.0000 18300 6825 450 150 18300 6825 18750 6975
-1 1 0 1 0 7 50 -1 -1 0.000 1 0.0000 18299 7502 450 150 18299 7502 18749 7652
-2 1 0 1 0 7 50 -1 -1 0.000 0 0 -1 0 0 2
- 17850 6900 17850 7500
-2 1 0 1 0 7 50 -1 -1 0.000 0 0 -1 0 0 2
- 18750 6825 18750 7500
--6
-6 4875 6075 5850 7125
-1 1 0 1 0 7 50 -1 -1 0.000 1 0.0000 5400 6225 450 150 5400 6225 5850 6375
-1 1 0 1 0 7 50 -1 -1 0.000 1 0.0000 5399 6902 450 150 5399 6902 5849 7052
-2 1 0 1 0 7 50 -1 -1 0.000 0 0 -1 0 0 2
- 4950 6300 4950 6900
-2 1 0 1 0 7 50 -1 -1 0.000 0 0 -1 0 0 2
- 5850 6225 5850 6900
--6
-6 5400 7425 7350 8925
-6 5475 7650 6450 8700
-1 1 0 1 0 7 50 -1 -1 0.000 1 0.0000 6000 7800 450 150 6000 7800 6450 7950
-1 1 0 1 0 7 50 -1 -1 0.000 1 0.0000 5999 8477 450 150 5999 8477 6449 8627
-2 1 0 1 0 7 50 -1 -1 0.000 0 0 -1 0 0 2
- 5550 7875 5550 8475
-2 1 0 1 0 7 50 -1 -1 0.000 0 0 -1 0 0 2
- 6450 7800 6450 8475
--6
-4 0 0 50 -1 0 12 0.0000 4 195 1905 5400 8850 pointers to the servers\001
-4 0 0 50 -1 0 12 0.0000 4 150 930 5550 7575 monitor.db\001
--6
-6 6150 2700 7500 3225
-2 2 0 1 0 7 50 -1 -1 0.000 0 0 -1 0 0 5
- 6150 2700 7500 2700 7500 3225 6150 3225 6150 2700
-4 0 0 50 -1 0 12 0.0000 4 180 870 6225 2925 run2/test1\001
--6
-2 1 0 1 0 7 50 -1 -1 0.000 0 0 -1 1 1 2
- 0 0 1.00 60.00 120.00
- 0 0 1.00 60.00 120.00
- 1725 5025 1275 2475
-2 4 0 1 0 7 50 -1 -1 0.000 0 0 7 0 0 5
- 5550 4500 5550 225 225 225 225 4500 5550 4500
-2 1 0 1 0 7 50 -1 -1 0.000 0 0 -1 1 1 2
- 0 0 1.00 60.00 120.00
- 0 0 1.00 60.00 120.00
- 1875 7725 1875 5775
-2 2 0 1 0 7 50 -1 -1 0.000 0 0 -1 0 0 5
- 1425 7725 2775 7725 2775 8250 1425 8250 1425 7725
-2 2 0 1 0 7 50 -1 -1 0.000 0 0 -1 0 0 5
- 3375 7725 4725 7725 4725 8250 3375 8250 3375 7725
-2 1 0 1 0 7 50 -1 -1 3.000 0 0 -1 1 1 2
- 0 0 1.00 60.00 120.00
- 0 0 1.00 60.00 120.00
- 3675 7725 2175 5775
-2 4 0 1 0 7 50 -1 -1 0.000 0 0 7 0 0 5
- 2775 5700 2775 5100 1500 5100 1500 5700 2775 5700
-2 1 0 1 0 7 50 -1 -1 3.000 0 0 -1 1 1 2
- 0 0 1.00 60.00 120.00
- 0 0 1.00 60.00 120.00
- 6600 3300 2925 5025
+2 1 0 1 0 7 50 -1 -1 0.000 0 0 -1 1 1 2
+ 0 0 1.00 60.00 120.00
+ 0 0 1.00 60.00 120.00
+ 1500 3825 1200 2550
2 4 0 1 0 7 50 -1 -1 0.000 0 0 7 0 0 5
17025 10125 17025 9525 15750 9525 15750 10125 17025 10125
2 1 0 1 0 7 50 -1 -1 3.000 0 0 -1 1 1 2
0 0 1.00 60.00 120.00
0 0 1.00 60.00 120.00
@@ -448,32 +402,55 @@
2 4 0 1 0 7 50 -1 -1 0.000 0 0 7 0 0 5
5325 12675 5325 12075 4050 12075 4050 12675 5325 12675
2 1 0 1 0 7 50 -1 -1 3.000 0 0 -1 1 0 2
0 0 1.00 60.00 120.00
3975 11250 4575 12075
+2 4 0 1 0 7 50 -1 -1 0.000 0 0 7 0 0 5
+ 3300 3000 3300 225 225 225 225 3000 3300 3000
+2 1 0 1 0 7 50 -1 -1 0.000 0 0 -1 1 0 2
+ 0 0 1.00 60.00 120.00
+ 3675 7275 1800 7875
+2 4 0 1 0 7 50 -1 -1 0.000 0 0 7 0 0 5
+ 2475 8775 2475 6675 225 6675 225 8775 2475 8775
+2 4 0 1 5 7 50 -1 -1 0.000 0 0 7 0 0 5
+ 75 6525 75 9000 4950 9000 4950 6525 75 6525
+2 1 0 1 0 7 50 -1 -1 0.000 0 0 -1 1 0 2
+ 0 0 1.00 60.00 120.00
+ 2400 4200 5400 5400
+2 1 0 1 0 7 50 -1 -1 0.000 0 0 -1 1 1 2
+ 0 0 1.00 60.00 120.00
+ 0 0 1.00 60.00 120.00
+ 1135 5476 1285 4426
2 1 0 1 0 7 50 -1 -1 3.000 0 0 -1 1 1 2
0 0 1.00 60.00 120.00
0 0 1.00 60.00 120.00
- 2175 5025 3075 3750
+ 2321 5402 1796 4427
2 1 0 1 0 7 50 -1 -1 3.000 0 0 -1 1 1 2
0 0 1.00 60.00 120.00
0 0 1.00 60.00 120.00
- 4800 6375 2850 5550
+ 6000 3075 1725 2100
2 1 0 1 0 7 50 -1 -1 0.000 0 0 -1 1 1 2
0 0 1.00 60.00 120.00
0 0 1.00 60.00 120.00
- 3600 2475 7425 6525
-4 0 0 50 -1 0 12 0.0000 4 195 990 1800 2625 last_update\001
-4 0 0 50 -1 0 12 0.0000 4 150 690 3150 4125 main.db\001
-4 0 0 50 -1 0 12 0.0000 4 195 990 4200 3600 last_update\001
-4 0 0 50 -1 0 12 0.0000 4 195 330 1950 6825 http\001
-4 0 0 50 -1 0 12 0.0000 4 180 870 1575 7950 run1/test1\001
-4 0 0 50 -1 0 12 0.0000 4 150 720 1650 5400 server-1\001
-4 0 0 50 -1 0 12 0.0000 4 150 375 2175 2025 2.db\001
-4 0 0 50 -1 0 12 0.0000 4 150 375 750 2550 1.db\001
-4 0 0 50 -1 0 12 0.0000 4 180 870 3450 7950 run1/test2\001
-4 0 0 50 -1 0 12 0.0000 4 150 1110 9675 3750 Dashboardm\001
+ 1725 2250 7275 4425
+2 4 0 1 5 7 50 -1 -1 0.000 0 0 7 0 0 5
+ 6300 525 6300 2175 3825 2175 3825 525 6300 525
+2 1 0 1 5 7 50 -1 -1 0.000 0 0 -1 0 0 2
+ 3675 225 6000 2400
+2 1 0 1 5 7 50 -1 -1 0.000 0 0 -1 0 0 2
+ 3825 2475 5775 300
+2 2 0 1 0 7 50 -1 -1 0.000 0 0 -1 0 0 5
+ 7800 4050 12825 4050 12825 8925 7800 8925 7800 4050
+2 2 0 1 0 7 50 -1 -1 0.000 0 0 -1 0 0 5
+ 9225 6225 12450 6225 12450 8325 9225 8325 9225 6225
+2 2 0 1 4 7 50 -1 -1 0.000 0 0 -1 0 0 5
+ 9225 6150 9675 6150 9675 8400 9225 8400 9225 6150
+3 2 0 1 0 7 50 -1 -1 3.000 0 1 1 3
+ 0 0 1.00 60.00 120.00
+ 0 0 1.00 60.00 120.00
+ 4125 6675 3675 5250 2325 4425
+ 0.000 -1.000 0.000
4 0 0 50 -1 0 12 1.5708 4 150 390 8325 3975 run1\001
4 0 0 50 -1 0 12 0.0000 4 150 900 15825 9750 rpc-server\001
4 0 0 50 -1 0 12 0.0000 4 165 270 17475 9900 tcp\001
4 0 0 50 -1 0 12 0.0000 4 120 315 18525 10200 test\001
4 0 0 50 -1 0 12 0.0000 4 195 1065 14850 7275 megatest.db\001
@@ -481,10 +458,17 @@
4 0 0 50 -1 0 12 0.0000 4 195 1875 14325 6600 mysql/postgres model\001
4 0 0 50 -1 0 12 0.0000 4 195 4065 600 9300 Current state, no bypass - (if we switch to rpc?)\001
4 0 0 50 -1 0 12 0.0000 4 195 1125 2175 10650 prev try RPC\001
4 0 0 50 -1 0 12 0.0000 4 165 1095 2475 11100 rmt:get-tests\001
4 0 0 50 -1 0 12 0.0000 4 195 2205 450 525 /tmp/<user>/??? /.db/*.db\001
-4 0 0 50 -1 0 12 0.0000 4 195 1065 4800 7350 megatest.db\001
-4 0 0 50 -1 0 12 0.0000 4 150 1785 600 8775 Possible Future state\001
4 0 0 50 -1 0 12 0.0000 4 150 1110 8025 450 CHANGES:\001
4 0 0 50 -1 0 12 0.0000 4 195 2145 8025 705 1. http -> rcp or nanomsg\001
4 0 0 50 -1 0 12 0.0000 4 195 3330 8025 960 2. cache db moves from inmem to /tmp\001
+4 0 0 50 -1 0 12 0.0000 4 195 1410 2025 1875 megatest_ref.db\001
+4 0 0 50 -1 0 12 0.0000 4 150 1785 3675 375 Possible Future state\001
+4 0 0 50 -1 0 12 0.0000 4 195 1290 450 6900 Read-only user\001
+4 0 0 50 -1 0 12 0.0000 4 195 1755 675 8475 /tmp/.../megatest.db\001
+4 0 0 50 -1 0 12 0.0000 4 195 1065 3750 8025 megatest.db\001
+4 0 0 50 -1 0 12 0.0000 4 195 990 1650 2925 last_update\001
+4 0 0 50 -1 0 12 0.0000 4 195 330 1350 5100 http\001
+4 0 0 50 -1 0 12 0.0000 4 195 1065 750 2475 megatest.db\001
+4 0 0 50 -1 0 12 0.0000 4 150 945 9675 3750 Dashboard\001
Index: ezsteps.scm
==================================================================
--- ezsteps.scm
+++ ezsteps.scm
@@ -164,11 +164,11 @@
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
(if (not (equal? item-path ""))
- (cdb:roll-up-pass-fail-counts *runremote* run-id test-name item-path new-status))))
+ (cdb:set-state-status-and-roll-up-items *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
)))
(pop-directory)
Index: http-transport.scm
==================================================================
--- http-transport.scm
+++ http-transport.scm
@@ -217,11 +217,11 @@
(let* ((fullurl (if (vector? serverdat)
(http-transport:server-dat-get-api-req serverdat)
(begin
(debug:print 0 *default-log-port* "FATAL ERROR: http-transport:client-api-send-receive called with no server info")
(exit 1))))
- (res #f)
+ (res (vector #f "uninitialized"))
(success #t)
(sparams (db:obj->string params transport: 'http)))
(debug:print-info 11 *default-log-port* "fullurl=" fullurl ", cmd=" cmd ", params=" params ", run-id=" run-id "\n")
;; set up the http-client here
(max-retry-attempts 1)
@@ -383,30 +383,34 @@
(server-going #f))
(let loop ((count 0)
(server-state 'available)
(bad-sync-count 0)
(start-time (current-milliseconds)))
-
+ ;;(BB> "http-transport: top of loop; count="count" server-state="server-state" bad-sync-count="bad-sync-count" server-going="server-going)
;; Use this opportunity to sync the tmp db to megatest.db
(if (not server-going) ;; *dbstruct-db*
;; Removed code is pasted below (keeping it around until we are clear it is not needed).
;; no *dbstruct-db* yet, set running after our first pass through and start the db
(if (eq? server-state 'available)
(let ((new-server-id (tasks:server-am-i-the-server? (db:delay-if-busy tdbdat) run-id))) ;; try to ensure no double registering of servers
(if (equal? new-server-id server-id)
(begin
(tasks:server-set-state! (db:delay-if-busy tdbdat) server-id "dbprep")
+ ;;(BB> "http-transport: ->dbprep")
(thread-sleep! 0.5) ;; give some margin for queries to complete before switching from file based access to server based access
(set! *dbstruct-db* (db:setup)) ;; run-id))
(set! server-going #t)
(tasks:server-set-state! (db:delay-if-busy tdbdat) server-id "running")
- (server:write-dotserver *toppath* (conc iface ":" port))
- (delete-file* (conc *toppath* "/.starting-server")))
+ ;;(BB> "http-transport: ->running")
+ (server:write-dotserver *toppath* iface port (current-process-id) 'http)
+ (thread-start! *watchdog*)
+ (server:complete-attempt *toppath*))
(begin ;; gotta exit nicely
+ ;;(BB> "http-transport: ->collision")
(tasks:server-set-state! (db:delay-if-busy tdbdat) server-id "collision")
(http-transport:server-shutdown server-id port))))))
-
+
;; when things go wrong we don't want to be doing the various queries too often
;; so we strive to run this stuff only every four seconds or so.
(let* ((sync-time (- (current-milliseconds) start-time))
(rem-time (quotient (- 4000 sync-time) 1000)))
(if (and (<= rem-time 4)
@@ -424,11 +428,12 @@
(if (or (not (equal? sdat (list iface port)))
(not server-id))
(begin
(debug:print-info 0 *default-log-port* "interface changed, refreshing iface and port info")
(set! iface (car sdat))
- (set! port (cadr sdat))))
+ (set! port (cadr sdat))
+ (server:write-dotserver *toppath* iface port (current-process-id) 'http)))
;; Transfer *db-last-access* to last-access to use in checking that we are still alive
(mutex-lock! *heartbeat-mutex*)
(set! last-access *db-last-access*)
(mutex-unlock! *heartbeat-mutex*)
@@ -443,25 +448,30 @@
(adjusted-timeout (if (> hrs-since-start 1)
(- server-timeout (inexact->exact (round (* hrs-since-start 60)))) ;; subtract 60 seconds per hour
server-timeout)))
(if (common:low-noise-print 120 "server timeout")
(debug:print-info 0 *default-log-port* "Adjusted server timeout: " adjusted-timeout))
- (if (and *server-run*
+ (cond
+ ((not (server:confirm-dotserver *toppath* iface port (current-process-id) 'http))
+ (debug:print-info 0 *default-log-port* "Server .server file does not exist or contents do not match. Initiate server shutdown.")
+ (http-transport:server-shutdown server-id port))
+ ((and *server-run*
(> (+ last-access server-timeout)
(current-seconds)))
- (begin
- (if (common:low-noise-print 120 "server continuing")
- (debug:print-info 0 *default-log-port* "Server continuing, seconds since last db access: " (- (current-seconds) last-access)))
- ;;
- ;; 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 bad-sync-count (current-milliseconds)))
- (http-transport:server-shutdown server-id port))))))
+ (if (common:low-noise-print 120 "server continuing")
+ (debug:print-info 0 *default-log-port* "Server continuing, seconds since last db access: " (- (current-seconds) last-access)))
+ ;;
+ ;; 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 bad-sync-count (current-milliseconds)))
+ (else
+ (debug:print-info 0 *default-log-port* "Server timeed out. seconds since last db access: " (- (current-seconds) last-access))
+ (http-transport:server-shutdown server-id port)))))))
;; code cut out from above
;;
;; (condition-case
;; ;; (if (and (member (mutex-state *db-sync-mutex*) '(abandoned not-abandoned))
@@ -486,48 +496,50 @@
;; (thread-sleep! rem-time)
;; (thread-sleep! 4))) ;; fallback for if the math is changed ...
(define (http-transport:server-shutdown server-id port)
(let ((tdbdat (tasks:open-db)))
- (debug:print-info 0 *default-log-port* "Starting to shutdown the server.")
+ ;;(BB> "http-transport:server-shutdown called")
+ (debug:print-info 0 *default-log-port* "Starting to shutdown the server. pid="(current-process-id))
;;
;; start_shutdown
;;
(tasks:server-set-state! (db:delay-if-busy tdbdat) server-id "shutting-down")
(set! *time-to-exit* #t) ;; tell on-exit to be fast as we've already cleaned up
(portlogger:open-run-close portlogger:set-port port "released")
(thread-sleep! 5)
- (debug:print-info 0 *default-log-port* "Max cached queries was " *max-cache-size*)
- (debug:print-info 0 *default-log-port* "Number of cached writes " *number-of-writes*)
- (debug:print-info 0 *default-log-port* "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 *default-log-port* "Number non-cached queries " *number-non-write-queries*)
- (debug:print-info 0 *default-log-port* "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 *default-log-port* "Max cached queries was " *max-cache-size*)
+;; (debug:print-info 0 *default-log-port* "Number of cached writes " *number-of-writes*)
+;; (debug:print-info 0 *default-log-port* "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 *default-log-port* "Number non-cached queries " *number-non-write-queries*)
+;; (debug:print-info 0 *default-log-port* "Average non-cached time "
+;; (if (eq? *number-non-write-queries* 0)
+;; "n/a (no queries)"
+;; (/ *total-non-write-delay*
+;; *number-non-write-queries*))
+ ;; " ms")
+
+ (db:print-current-query-stats)
+
(debug:print-info 0 *default-log-port* "Server shutdown complete. Exiting")
(tasks:server-delete-record (db:delay-if-busy tdbdat) server-id " http-transport:keep-running complete")
;; if the .server file contained :myport then we can remove it
(server:remove-dotserver-file *toppath* port)
+ ;;(BB> "http-transport:server-shutdown -> exit")
(exit)))
;; all routes though here end in exit ...
;;
;; start_server?
;;
(define (http-transport:launch run-id)
- (with-output-to-file
- (conc *toppath* "/.starting-server")
- (lambda ()
- (print (current-process-id) " on " (get-host-name))))
+ (server:attempting-start *toppath*)
(let* ((tdbdat (tasks:open-db)))
(set! *run-id* run-id)
(if (args:get-arg "-daemonize")
(begin
(daemon:ize)
@@ -539,11 +551,11 @@
(server:check-if-running run-id))
(begin
(debug:print 0 *default-log-port* "INFO: Server for run-id " run-id " already running")
(exit 0))
(begin ;; ok, no server detected, clean out any lingering records
- (tasks:server-force-clean-running-records-for-run-id (db:delay-if-busy tdbdat) run-id "notresponding")))
+ (tasks:server-force-clean-running-records-for-run-id (db:delay-if-busy tdbdat) run-id "notresponding")))
(let loop ((server-id (tasks:server-lock-slot (db:delay-if-busy tdbdat) run-id))
(remtries 4))
(if (not server-id)
(if (> remtries 0)
(begin
@@ -552,11 +564,11 @@
(- remtries 1)))
(begin
;; since we didn't get the server lock we are going to clean up and bail out
(debug:print-info 2 *default-log-port* "INFO: server pid=" (current-process-id) ", hostname=" (get-host-name) " not starting due to other candidates ahead in start queue")
(tasks:server-delete-records-for-this-pid (db:delay-if-busy tdbdat) " http-transport:launch")
- (delete-file* (conc *toppath* "/.starting-server"))
+ (server:complete-attempt *toppath*)
))
(let* ((th2 (make-thread (lambda ()
(debug:print-info 0 *default-log-port* "Server run thread started")
(http-transport:run
(if (args:get-arg "-server")
DELETED inteldate.scm
Index: inteldate.scm
==================================================================
--- inteldate.scm
+++ /dev/null
@@ -1,180 +0,0 @@
-(use srfi-19)
-(use test)
-(use format)
-(use regex)
-(declare (unit inteldate))
-;; utility procedures to convert among
-;; different ways to express date (inteldate, seconds since epoch, isodate)
-;;
-;; samples:
-;; isodate -> "2016-01-01"
-;; inteldate -> "16ww01.5"
-;; seconds -> 1451631600
-
-;; procedures provided:
-;; ====================
-;; seconds->isodate
-;; seconds->inteldate
-;;
-;; isodate->seconds
-;; isodate->inteldate
-;;
-;; inteldate->seconds
-;; inteldate->isodate
-
-;; srfi-19 used extensively; this doc is better tha the eggref:
-;; http://srfi.schemers.org/srfi-19/srfi-19.html
-
-;; Author: brandon.j.barclay@intel.com 16ww18.6
-
-(define (date->seconds date)
- (inexact->exact
- (string->number
- (date->string date "~s"))))
-
-(define (seconds->isodate seconds)
- (let* ((date (seconds->date seconds))
- (result (date->string date "~Y-~m-~d")))
- result))
-
-(define (isodate->seconds isodate)
- "Takes a string input of the form 'YY-MM-DD' or 'YYYY-MM-DD' and returns epoch time; for YY, assume after Y2K"
- (let* ((numlist (map string->number (string-split isodate "-")))
- (raw-year (car numlist))
- (year (if (< raw-year 100) (+ raw-year 2000) raw-year))
- (month (list-ref numlist 1))
- (day (list-ref numlist 2))
- (date (make-date 0 0 0 0 day month year))
- (seconds (date->seconds date)))
-
- seconds))
-
-;; adapted from perl Intel::WorkWeek perl module
-;; intel year consists of numbered weeks starting from week 1
-;; week 1 is the week containing jan 1 of the year
-;; days of week are numbered starting from 0 on sunday
-;; intel year does not match calendar year in workweek 1
-;; before jan1.
-(define (seconds->inteldate-values seconds)
- (define (date-difference->seconds d1 d2)
- (- (date->seconds d1) (date->seconds d2)))
-
- (let* ((thisdate (seconds->date seconds))
- (thisdow (string->number (date->string thisdate "~w")))
-
- (year (date-year thisdate))
- ;; intel workweek 1 begins on sunday of week containing jan1
- (jan1 (make-date 0 0 0 0 1 1 year))
- (jan1dow (date-week-day jan1))
- (ww01 (date-subtract-duration jan1 (seconds->time (* 60 60 24 jan1dow))))
-
- (ww01_delta_seconds (date-difference->seconds thisdate ww01))
- (wwnum_initial (inexact->exact (add1 (floor (/ ww01_delta_seconds 24 3600 7) ))))
-
- ;; we could be in ww1 of next year
- (this-saturday (seconds->date
- (+ seconds
- (* 60 60 24 (- 6 thisdow)))))
- (this-week-ends-next-year?
- (> (date-year this-saturday) year))
- (intelyear
- (if this-week-ends-next-year?
- (add1 year)
- year))
- (intelweek
- (if this-week-ends-next-year?
- 1
- wwnum_initial)))
- (values intelyear intelweek thisdow)))
-
-(define (seconds->inteldate seconds)
- (define (string-leftpad in width pad-char)
- (let* ((unpadded-str (->string in))
- (padlen_temp (- width (string-length unpadded-str)))
- (padlen (if (< padlen_temp 0) 0 padlen_temp))
- (padding
- (fold conc ""
- (map (lambda (x) (->string pad-char)) (iota padlen)))))
- (conc padding unpadded-str)))
- (define (zeropad num width)
- (string-leftpad num width #:0))
-
- (let-values (((intelyear intelweek day-of-week-num)
- (seconds->inteldate-values seconds)))
- (let ((intelyear-str
- (zeropad
- (->string
- (if (> intelyear 1999)
- (- intelyear 2000) intelyear))
- 2))
- (intelweek-str
- (zeropad (->string intelweek) 2))
- (dow-str (->string day-of-week-num)))
- (conc intelyear-str "ww" intelweek-str "." dow-str))))
-
-(define (isodate->inteldate isodate)
- (seconds->inteldate
- (isodate->seconds isodate)))
-
-(define (inteldate->seconds inteldate)
- (let ((match (string-match "^(\\d+)ww(\\d+).(\\d)$" inteldate)))
- (if
- (not match)
- #f
- (let* (
- (intelyear-raw (string->number (list-ref match 1)))
- (intelyear (if (< intelyear-raw 100)
- (+ intelyear-raw 2000)
- intelyear-raw))
- (intelww (string->number (list-ref match 2)))
- (dayofweek (string->number (list-ref match 3)))
-
- (day-of-seconds (* 60 60 24 ))
- (week-of-seconds (* day-of-seconds 7))
-
-
- ;; get seconds at ww1.0
- (new-years-date (make-date 0 0 0 0 1 1 intelyear))
- (new-years-seconds
- (date->seconds new-years-date))
- (new-years-dayofweek (date-week-day new-years-date))
- (ww1.0_seconds (- new-years-seconds
- (* day-of-seconds
- new-years-dayofweek)))
- (workweek-adjustment (* week-of-seconds (sub1 intelww)))
- (weekday-adjustment (* dayofweek day-of-seconds))
-
- (result (+ ww1.0_seconds workweek-adjustment weekday-adjustment)))
- result))))
-
-(define (inteldate->isodate inteldate)
- (seconds->isodate (inteldate->seconds inteldate)))
-
-(define (inteldate-tests)
- (test-group
- "date conversion tests"
- (let ((test-table
- '(("16ww01.5" . "2016-01-01")
- ("16ww18.5" . "2016-04-29")
- ("1999ww33.5" . "1999-08-13")
- ("16ww18.4" . "2016-04-28")
- ("16ww18.3" . "2016-04-27")
- ("13ww01.0" . "2012-12-30")
- ("13ww52.6" . "2013-12-28")
- ("16ww53.3" . "2016-12-28"))))
- (for-each
- (lambda (test-pair)
- (let ((inteldate (car test-pair))
- (isodate (cdr test-pair)))
- (test
- (conc "(isodate->inteldate "isodate ") => "inteldate)
- inteldate
- (isodate->inteldate isodate))
-
- (test
- (conc "(inteldate->isodate "inteldate ") => "isodate)
- isodate
- (inteldate->isodate inteldate))))
- test-table))))
-
-;(inteldate-tests)
Index: launch.scm
==================================================================
--- launch.scm
+++ launch.scm
@@ -64,18 +64,19 @@
(define (launch:load-logpro-dat run-id test-id stepname)
(let ((cname (conc stepname ".dat")))
(if (file-exists? cname)
(let* ((dat (read-config cname #f #f))
(csvr (db:logpro-dat->csv dat stepname))
- (csvt (let-values (( (fmt-cell fmt-record fmt-csv) (make-format ",")))
- (fmt-csv (map list->csv-record csvr))))
+ (csvt (let-values (((fmt-cell fmt-record fmt-csv) (make-format ",")))
+ (fmt-csv (map list->csv-record csvr))))
(status (configf:lookup dat "final" "exit-status"))
(msg (configf:lookup dat "final" "message")))
- ;;(if csvt ;; this if blocked stack dump caused by .dat file from logpro being 0-byte. fixed by upgrading logpro
+ (if csvt ;; this if blocked stack dump caused by .dat file from logpro being 0-byte. fixed by upgrading logpro
(rmt:csv->test-data run-id test-id csvt)
- ;; (BB> "Error: run-id/test-id/stepname="run-id"/"test-id"/"stepname" => bad csvr="csvr)
- ;; )
+ (debug:print 0 *default-log-port* "ERROR: no csvdat exists for run-id: " run-id " test-id: " test-id " stepname: " stepname ", check that logpro version is 1.15 or newer"))
+ ;; (BB> "Error: run-id/test-id/stepname="run-id"/"test-id"/"stepname" => bad csvr="csvr)
+ ;; )
(cond
((equal? status "PASS") "PASS") ;; skip the message part if status is pass
(status (conc (configf:lookup dat "final" "exit-status") ": " (if msg msg "no message")))
(else #f)))
#f)))
@@ -122,10 +123,22 @@
(call-with-environment-variables
(list (cons "PATH" (conc (get-environment-variable "PATH") ":.")))
(lambda () ;; (process-run "/bin/bash" "-c" "exec ls -l /tmp/foobar > /tmp/delme-more.log 2>&1")
(let* ((cmd (conc stepcmd " > " stepname ".log 2>&1")) ;; >outfile 2>&1
(pid (process-run "/bin/bash" (list "-c" cmd))))
+
+ (with-output-to-file "Makefile.ezsteps"
+ (lambda ()
+ (print stepname ".log :")
+ (print "\t" cmd)
+ (if (file-exists? (conc stepname ".logpro"))
+ (print "\tlogpro " stepname ".logpro " stepname ".html < " stepname ".log"))
+ (print)
+ (print stepname " : " stepname ".log")
+ (print))
+ #:append)
+
(rmt:test-set-top-process-pid run-id test-id pid)
(let processloop ((i 0))
(let-values (((pid-val exit-status exit-code)(process-wait pid #t)))
(mutex-lock! m)
(launch:einf-pid-set! exit-info pid) ;; (vector-set! exit-info 0 pid)
@@ -241,11 +254,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! run-id test-id "RUNNING" "n/a")
- (rmt:roll-up-pass-fail-counts run-id test-name item-path #f "RUNNING" #f)
+ (rmt:set-state-status-and-roll-up-items run-id test-name item-path "RUNNING" #f #f)
;; (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)))
@@ -268,11 +281,11 @@
;; do all the ezsteps (if any)
(if ezsteps
(let* ((testconfig ;; (read-config (conc work-area "/testconfig") #f #t environ-patt: "pre-launch-env-vars")) ;; FIXME??? is allow-system ok here?
;; NOTE: it is tempting to turn off force-create of testconfig but dynamic
;; ezstep names need a full re-eval here.
- (tests:get-testconfig test-name tconfigreg #t force-create: #t)) ;; 'return-procs)))
+ (tests:get-testconfig test-name item-path tconfigreg #t force-create: #t)) ;; 'return-procs)))
(ezstepslst (if (hash-table? testconfig)
(hash-table-ref/default testconfig "ezsteps" '())
#f)))
(if testconfig
(hash-table-set! *testconfigs* test-name testconfig) ;; cached for lazy reads later ...
@@ -316,15 +329,15 @@
(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)
(tests:set-full-meta-info #f test-id run-id (calc-minutes) work-area 10)
(let loop ((minutes (calc-minutes))
- (cpu-load (get-cpu-load))
+ (cpu-load (alist-ref 'adj-core-load (common:get-normalized-cpu-load #f)))
(disk-free (get-df (current-directory))))
- (let ((new-cpu-load (let* ((load (get-cpu-load))
+ (let ((new-cpu-load (let* ((load (alist-ref 'adj-core-load (common:get-normalized-cpu-load #f)))
(delta (abs (- load cpu-load))))
- (if (> delta 0.6) ;; don't bother updating with small changes
+ (if (> delta 0.1) ;; don't bother updating with small changes
load
#f)))
(new-disk-free (let* ((df (get-df (current-directory)))
(delta (abs (- df disk-free))))
(if (> delta 200) ;; ignore changes under 200 Meg
@@ -445,11 +458,11 @@
(if (eq? signum signal/stop)
(debug:print-error 0 *default-log-port* "attempt to STOP process. Exiting."))
(set! *time-to-exit* #t)
(print "Received signal " signum ", cleaning up before exit. Please wait...")
(let ((th1 (make-thread (lambda ()
- (tests:test-force-state-status! run-id test-id "INCOMPLETE" "KILLED")
+ (rmt:test-set-state-status run-id test-id "INCOMPLETE" "KILLED" #f)
(print "Killed by signal " signum ". Exiting")
(thread-sleep! 1)
(exit 1))))
(th2 (make-thread (lambda ()
(thread-sleep! 2)
@@ -469,17 +482,23 @@
(test-host (db:test-get-host test-info))
(test-pid (db:test-get-process_id test-info)))
(cond
((member (db:test-get-state test-info) '("INCOMPLETE" "KILLED" "UNKNOWN" "KILLREQ" "STUCK")) ;; prior run of this test didn't complete, go ahead and try to rerun
(debug:print 0 *default-log-port* "INFO: test is INCOMPLETE or KILLED, treat this execute call as a rerun request")
- (tests:test-force-state-status! run-id test-id "REMOTEHOSTSTART" "n/a")) ;; prime it for running
+ ;; (tests:test-force-state-status! run-id test-id "REMOTEHOSTSTART" "n/a")
+ (rmt:test-set-state-status run-id test-id "REMOTEHOSTSTART" "n/a" #f)
+ ) ;; prime it for running
((member (db:test-get-state test-info) '("RUNNING" "REMOTEHOSTSTART"))
(if (process:alive-on-host? test-host test-pid)
(debug:print-error 0 *default-log-port* "test state is " (db:test-get-state test-info) " and process " test-pid " is still running on host " test-host ", cannot proceed")
- (tests:test-force-state-status! run-id test-id "REMOTEHOSTSTART" "n/a")))
+ ;; (tests:test-force-state-status! run-id test-id "REMOTEHOSTSTART" "n/a")
+ (rmt:test-set-state-status run-id test-id "REMOTEHOSTSTART" "n/a" #f)
+ ))
((not (member (db:test-get-state test-info) '("REMOVING" "REMOTEHOSTSTART" "RUNNING" "KILLREQ")))
- (tests:test-force-state-status! run-id test-id "REMOTEHOSTSTART" "n/a"))
+ ;; (tests:test-force-state-status! run-id test-id "REMOTEHOSTSTART" "n/a")
+ (rmt:test-set-state-status run-id test-id "REMOTEHOSTSTART" "n/a" #f)
+ )
(else ;; (member (db:test-get-state test-info) '("REMOVING" "REMOTEHOSTSTART" "RUNNING" "KILLREQ"))
(debug:print-error 0 *default-log-port* "test state is " (db:test-get-state test-info) ", cannot proceed")
(exit))))
(debug:print 2 *default-log-port* "Exectuing " test-name " (id: " test-id ") on " (get-host-name))
@@ -639,11 +658,11 @@
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!
+ ;; NO NEED TO CALL set-state-status-and-roll-up-items HERE, THIS IS DONE IN set-state-status-and-roll-up-items called by tests:test-set-status!
))
;; for automated creation of the rollup html file this is a good place...
(if (not (equal? item-path ""))
(tests:summarize-items run-id test-id test-name #f))
(tests:summarize-test run-id test-id) ;; don't force - just update if no
@@ -846,11 +865,14 @@
(directory-exists? *toppath*))
(begin
(setenv "MT_RUN_AREA_HOME" *toppath*)
(setenv "MT_TESTSUITE_NAME" (common:get-testsuite-name)))
(begin
- (debug:print-error 0 *default-log-port* "failed to find the top path to your Megatest area.")))
+ (debug:print-error 0 *default-log-port* "failed to find the top path to your Megatest area.")
+ ;;(exit 1)
+ #f
+ ))
*toppath*))
(define (get-best-disk confdat testconfig)
(let* ((disks (or (and testconfig (hash-table-ref/default testconfig "disks" #f))
(hash-table-ref/default confdat "disks" #f)))
@@ -861,11 +883,11 @@
(if res
(cdr res)
(begin
(if (common:low-noise-print 20 "No valid disks or no disk with enough space")
(debug:print-error 0 *default-log-port* "No valid disks found in megatest.config. Please add some to your [disks] section and ensure the directory exists and has enough space!\n You can change minspace in the [setup] section of megatest.config. Current setting is: " minspace))
- (exit 1)))))))
+ (exit 1))))))) ;; TODO - move the exit to the calling location and return #f
;; Desired directory structure:
;;
;; <linkdir> - <target> - <testname> -.
;; |
@@ -1053,30 +1075,35 @@
;; 4. remotely run the test on allocated host
;; - could be ssh to host from hosts table (update regularly with load)
;; - could be netbatch
;; (launch-test db (cadr status) test-conf))
(define (launch-test test-id run-id run-info keyvals runname test-conf test-name test-path itemdat params)
+ (mutex-lock! *launch-setup-mutex*) ;; setting variables and processing the testconfig is NOT thread-safe, reuse the launch-setup mutex
(let* ((item-path (item-list->path itemdat)))
(let loop ((delta (- (current-seconds) *last-launch*))
(launch-delay (string->number (or (configf:lookup *configdat* "setup" "launch-delay") "5"))))
(if (> launch-delay delta)
(begin
(debug:print-info 0 *default-log-port* "Delaying launch of " test-name " for " (- launch-delay delta) " seconds")
(thread-sleep! (- launch-delay delta))
(loop (- (current-seconds) *last-launch*) launch-delay))))
- (set! *last-launch* (current-seconds))
(change-directory *toppath*)
(alist->env-vars ;; consolidate this code with the code in megatest.scm for "-execute", *maybe* - the longer they are set the longer each launch takes (must be non-overlapping with the vars)
- (list
- (list "MT_RUN_AREA_HOME" *toppath*)
- (list "MT_TEST_NAME" test-name)
- (list "MT_RUNNAME" runname)
- (list "MT_ITEMPATH" item-path)
- ))
- (let* ((tregistry (tests:get-all))
- (tconfig (or (tests:get-testconfig test-name tregistry #t force-create: #t)
- test-conf)) ;; force re-read now that all vars are set
+ (append
+ (list
+ (list "MT_RUN_AREA_HOME" *toppath*)
+ (list "MT_TEST_NAME" test-name)
+ (list "MT_RUNNAME" runname)
+ (list "MT_ITEMPATH" item-path)
+ )
+ itemdat))
+ (let* ((tregistry (tests:get-all)) ;; third param (below) is system-allowed
+ ;; for tconfig, why do we allow fallback to test-conf?
+ (tconfig (or (tests:get-testconfig test-name item-path tregistry #t force-create: #t)
+ (begin
+ (debug:print 0 *default-log-port* "WARNING: falling back to pre-calculated testconfig. This is likely not desired.")
+ test-conf))) ;; force re-read now that all vars are set
(useshell (let ((ush (config-lookup *configdat* "jobtools" "useshell")))
(if ush
(if (equal? ush "no") ;; must use "no" to NOT use shell
#f
ush)
@@ -1101,22 +1128,21 @@
((dboard) "../megatest")
((mtest) "../megatest")
((dashboard) "megatest")
(else exe)))))
(launcher (common:get-launcher *configdat* test-name item-path)) ;; (config-lookup *configdat* "jobtools" "launcher"))
- (test-sig (conc (common:get-testsuite-name) ":" test-name ":" item-path)) ;; (item-list->path itemdat))) ;; test-path is the full path including the item-path
- (work-area #f)
+ (test-sig (conc (common:get-testsuite-name) ":" test-name ":" item-path)) ;; (item-list->path itemdat))) ;; test-path is the full path including the item-path
+ (work-area #f)
(toptest-work-area #f) ;; for iterated tests the top test contains data relevant for all
(diskpath #f)
(cmdparms #f)
(fullcmd #f) ;; (define a (with-output-to-string (lambda ()(write x))))
(mt-bindir-path #f)
(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") '()))))
-
;; (if hosts (set! hosts (string-split hosts)))
;; set the megatest to be called on the remote host
(if (not remote-megatest)(set! remote-megatest local-megatest)) ;; "megatest"))
(set! mt-bindir-path (pathname-directory remote-megatest))
(if launcher (set! launcher (string-split launcher)))
@@ -1129,11 +1155,12 @@
;; prevent overlapping actions - set to LAUNCHED as early as possible
;;
;; the following call handles waiver propogation. cannot yet condense into roll-up-pass-fail
(tests:test-set-status! run-id test-id "LAUNCHED" "n/a" #f #f) ;; (if launch-results launch-results "FAILED"))
- (rmt:roll-up-pass-fail-counts run-id test-name item-path #f "LAUNCHED" #f)
+ (rmt:set-state-status-and-roll-up-items run-id test-name item-path #f "LAUNCHED" #f)
+ ;; (pp (hash-table->alist tconfig))
(set! diskpath (get-best-disk *configdat* tconfig))
(if diskpath
(let ((dat (create-work-area run-id run-info keyvals test-id test-path diskpath test-name itemdat)))
(set! work-area (car dat))
(set! toptest-work-area (cadr dat))
@@ -1184,10 +1211,11 @@
;; (set! fullcmd (list remote-megatest test-sig "-execute" cmdparms (if useshell "&" "")))))
(if (args:get-arg "-xterm")(set! fullcmd (append fullcmd (list "-xterm"))))
(debug:print 1 *default-log-port* "Launching " work-area)
;; set pre-launch-env-vars before launching, keep the vars in prevvals and put the envionment back when done
(debug:print 4 *default-log-port* "fullcmd: " fullcmd)
+ (set! *last-launch* (current-seconds)) ;; all that junk above takes time, set this as late as possible.
(let* ((commonprevvals (alist->env-vars
(hash-table-ref/default *configdat* "env-override" '())))
(miscprevvals (alist->env-vars ;; consolidate this code with the code in megatest.scm for "-execute"
(append (list (list "MT_TEST_RUN_DIR" work-area)
(list "MT_TEST_NAME" test-name)
@@ -1206,15 +1234,16 @@
process-run)
(if useshell
(let ((cmdstr (string-intersperse fullcmd " ")))
(if launchwait
cmdstr
- (conc cmdstr " >> mt_launch.log 2>&1")))
+ (conc cmdstr " >> mt_launch.log 2>&1 &")))
(car fullcmd))
(if useshell
'()
(cdr fullcmd)))))
+ (mutex-unlock! *launch-setup-mutex*) ;; yes, really should mutex all the way to here. Need to put this entire process into a fork.
(if (not launchwait) ;; give the OS a little time to allow the process to start
(thread-sleep! 0.01))
(with-output-to-file "mt_launch.log"
(lambda ()
(print "LAUNCHCMD: " (string-intersperse fullcmd " "))
Index: megatest-version.scm
==================================================================
--- megatest-version.scm
+++ megatest-version.scm
@@ -1,7 +1,7 @@
;; Always use two or four digit decimal
;; 1.01, 1.02...1.10,1.11,1.1101 ... 1.99,2.00..
(declare (unit megatest-version))
-(define megatest-version 1.6302)
+(define megatest-version 1.6304)
Index: megatest.scm
==================================================================
--- megatest.scm
+++ megatest.scm
@@ -93,10 +93,12 @@
-reqtarg key1/key2/... : run for key1, key2, etc. but key1/key2 must be in runconfig
-testpatt patt1/patt2,patt3/... : % is wildcard
-runname : required, name for this particular test run
-state : Applies to runs, tests or steps depending on context
-status : Applies to runs, tests or steps depending on context
+ -mode key : load testpatt from <key> in runconfigs instead of default TESTPATT
+ -tagexpr tag1,tag2%,.. : select tests with tags matching expression
Test helpers (for use inside tests)
-step stepname
-test-status : set the state and status of a test (use :state and :status)
-setlog logfname : set the path/filename to the final log relative to the test
@@ -209,11 +211,13 @@
":state"
"-state"
":status"
"-status"
"-list-runs"
- "-testpatt"
+ "-testpatt"
+ "-mode"
+ "-tagexpr"
"-itempatt"
"-setlog"
"-set-toplog"
"-runstep"
"-logpro"
@@ -345,11 +349,13 @@
;; The watchdog is to keep an eye on things like db sync etc.
;;
(define *watchdog* (make-thread common:watchdog "Watchdog thread"))
-(thread-start! *watchdog*)
+(if (not (args:get-arg "-server"))
+ (thread-start! *watchdog*)) ;; if starting a server; wait till we get to running state before kicking off watchdog
+;;(BB> "thread-start! watchdog")
(if (args:get-arg "-log")
(let ((oup (open-output-file (args:get-arg "-log"))))
(debug:print-info 0 *default-log-port* "Sending log output to " (args:get-arg "-log"))
(set! *default-log-port* oup)))
@@ -1851,13 +1857,11 @@
(begin
(if (not (launch:setup))
(begin
(debug:print 0 *default-log-port* "Failed to setup, exiting")
(exit 1)))
- ;; now can find our db
- ;; keep this one local
- (open-run-close runs:update-all-test_meta #f)
+ (runs:update-all-test_meta #f)
(set! *didsomething* #t)))
;;======================================================================
;; Start a repl
;;======================================================================
@@ -1986,17 +1990,22 @@
;;======================================================================
;; Exit and clean up
;;======================================================================
-(if *runremote* (close-all-connections!)) ;; for http-client
-
(if (not *didsomething*)
(debug:print 0 *default-log-port* help))
+;;(BB> "thread-join! watchdog")
+
+;; join the watchdog thread if it has been thread-start!ed (it may not have been started in the case of a server that never enters running state)
+;; (symbols returned by thread-state: created ready running blocked suspended sleeping terminated dead)
+(if (thread? *watchdog*)
+ (case (thread-state *watchdog*)
+ ((ready running blocked sleeping terminated dead)
+ (thread-join! *watchdog*))))
(set! *time-to-exit* #t)
-(thread-join! *watchdog*)
(if (not (eq? *globalexitstatus* 0))
(if (or (args:get-arg "-run")(args:get-arg "-runtests")(args:get-arg "-runall"))
(begin
(debug:print 0 *default-log-port* "NOTE: Subprocesses with non-zero exit code detected: " *globalexitstatus*)
ADDED minimal/manyservers.sh
Index: minimal/manyservers.sh
==================================================================
--- /dev/null
+++ minimal/manyservers.sh
@@ -0,0 +1,119 @@
+#!/bin/bash
+
+echo manyservers.sh pid $$
+
+logdir=$PWD/log-manysrv
+
+
+function reset {
+ rm -f .homehost .server .server.lock links/.db/monitor.db .starting-server
+ }
+
+function launch_many_servers {
+ # count = $1
+ # logdir = $2
+ # prefx = $3
+ perl -e 'foreach my $i (1 ... '$1'){print "'$2'/'$3'-srv-$i.log\n"}' | \
+ xargs -P $1 -n 1 megatest -server - -run-id 0 -daemonize -log
+}
+
+
+function get_srv_pids {
+ ps auwx | grep "mtest -server" | grep $logdir | grep -v grep | awk '{print $2}'
+}
+
+
+if [[ -e $logdir ]]; then rm -rf $logdir; fi
+if [[ ! -e $logdir ]]; then mkdir $logdir; fi
+
+reset
+
+simultaneous_servers=20
+server_collision_resolution_delay=15
+server_timeout_delay=65
+
+echo "Launching $simultaneous_servers simultaneous servers"
+launch_many_servers $simultaneous_servers $logdir "first"
+echo "Sleeping $server_collision_resolution_delay seconds to allow new servers to die because one is already running."
+sleep $server_collision_resolution_delay
+
+pids=`get_srv_pids`
+pids_left=`echo $pids | wc -w`
+echo "pids_left=$pids_left"
+echo "after $server_collision_resolution_delay seconds: servers remaining=$pids_left; expecting 1"
+if [[ $pids_left == 1 ]]; then
+ echo "All servers but 1 terminated. Still good."
+else
+ if [[ $pids_left == 0 ]]; then
+ echo "All servers died too soon. Not good. Aborting."
+ echo "TEST FAIL"
+ exit 1
+ else
+ echo "Too many servers left. Not good. Aborting."
+ echo "TEST FAIL"
+ echo $pids | xargs kill
+ sleep 5
+ pids=`get_srv_pids`
+ pids_left=`echo $pids | wc -w`
+ if [[ ! ( $pids_left == 0 ) ]]; then
+ echo $pids | xargs kill -9
+ fi
+ exit 1
+ fi
+fi
+
+
+
+echo "launching another volley of $simultaneous_servers. THey should all perish. right away, leaving the one server running."
+launch_many_servers $simultaneous_servers $logdir "second"
+sleep $server_collision_resolution_delay
+
+pids=`get_srv_pids`
+pids_left=`echo $pids | wc -w`
+echo "pids_left=$pids_left"
+echo "after $server_collision_resolution_delay seconds: servers remaining=$pids_left; expecting 1"
+if [[ $pids_left == 1 ]]; then
+ echo "All servers but 1 terminated. So far so good."
+else
+ if [[ $pids_left == 0 ]]; then
+ echo "All servers died too soon. Not good. Aborting."
+ echo "TEST FAIL"
+ exit 1
+ else
+ echo "Too many servers left. Not good. Aborting."
+ echo "TEST FAIL"
+ echo $pids | xargs kill
+ sleep 5
+ pids=`get_srv_pids`
+ pids_left=`echo $pids | wc -w`
+ if [[ ! ( $pids_left == 0 ) ]]; then
+ echo $pids | xargs kill -9
+ fi
+ exit 1
+ fi
+fi
+
+
+
+echo "sleeping for awhile ($server_timeout_delay seconds) to let server exit on its own for no-request timeout"
+sleep $server_timeout_delay
+pids=`get_srv_pids`
+pids_left=`echo $pids | wc -w`
+echo "after $server_timeout_delay seconds: servers remaining=$pids_left; expecting 0"
+
+if [[ $pids_left == 0 ]]; then
+ echo "No servers remain. This is good."
+ echo "TEST PASS"
+ exit 0
+else
+ echo "Too many servers left. Not good. Aborting."
+ echo "TEST FAIL"
+ echo $pids | xargs kill
+ sleep 5
+ pids=`get_srv_pids`
+ pids_left=`echo $pids | wc -w`
+ if [[ ! ( $pids_left == 0 ) ]]; then
+ echo $pids | xargs kill -9
+ fi
+ exit 1
+fi
Index: mt.scm
==================================================================
--- mt.scm
+++ mt.scm
@@ -128,12 +128,12 @@
;;======================================================================
;; T R I G G E R S
;;======================================================================
-(define (mt:process-triggers run-id test-id newstate newstatus)
- (let* ((test-dat (rmt:get-test-info-by-id run-id test-id)))
+(define (mt:process-triggers dbstruct run-id test-id newstate newstatus)
+ (let* ((test-dat (db:get-test-info-by-id dbstruct run-id test-id)))
(if test-dat
(let* ((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)
@@ -186,18 +186,18 @@
;; (rmt:general-call 'state-status run-id newstate newstatus test-id))
;; (else
;; (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))))
- (rmt:roll-up-pass-fail-counts run-id test-id #f newstate newstatus newcomment)
- (mt:process-triggers run-id test-id newstate newstatus)
+ (rmt:set-state-status-and-roll-up-items run-id test-id #f newstate newstatus newcomment)
+ ;; (mt:process-triggers run-id test-id newstate newstatus)
#t)))
(define (mt:test-set-state-status-by-testname run-id test-name item-path new-state new-status new-comment)
(let ((test-id (rmt:get-test-id run-id test-name item-path)))
- (rmt:roll-up-pass-fail-counts run-id test-name item-path new-state new-status new-comment)
- (mt:process-triggers run-id test-id new-state new-status)
+ (rmt:set-state-status-and-roll-up-items run-id test-name item-path new-state new-status new-comment)
+ ;; (mt:process-triggers run-id test-id new-state new-status)
#t))
;;(mt:test-set-state-status-by-id run-id test-id new-state new-status new-comment)))
(define (mt:lazy-read-test-config test-name)
(let ((tconf (hash-table-ref/default *testconfigs* test-name #f)))
Index: rmt.scm
==================================================================
--- rmt.scm
+++ rmt.scm
@@ -24,27 +24,20 @@
;; generate entries for ~/.megatestrc with the following
;;
;; grep define ../rmt.scm | grep rmt: |perl -pi -e 's/\(define\s+\((\S+)\W.*$/\1/'|sort -u
-(defstruct remote
- (hh-dat (common:get-homehost)) ;; homehost record ( addr . hhflag )
- (server-url (if *toppath* (server:read-dotserver *toppath*))) ;; (server:check-if-running *toppath*) #f))
- (last-server-check 0) ;; last time we checked to see if the server was alive
- (conndat #f)
- (transport *transport-type*)
- (server-timeout (or (server:get-timeout) 100))) ;; default to 100 seconds
-
;;======================================================================
;; S U P P O R T F U N C T I O N S
;;======================================================================
;; if a server is either running or in the process of starting call client:setup
;; else return #f to let the calling proc know that there is no server available
;;
-(define (rmt:get-connection-info run-id)
- (let ((cinfo (remote-conndat *runremote*)))
+(define (rmt:get-connection-info areapath) ;; TODO: push areapath down.
+ (let ((cinfo (remote-conndat *runremote*))
+ (run-id 0))
(if cinfo
cinfo
(if (tasks:server-running-or-starting? (db:delay-if-busy (tasks:open-db)) run-id)
(client:setup run-id)
#f))))
@@ -82,11 +75,11 @@
(set! *runremote* (make-remote))
(mutex-unlock! *rmt-mutex*)
(debug:print-info 12 *default-log-port* "rmt:send-receive, case 1")
(rmt:send-receive cmd rid params attemptnum: attemptnum))
;; ensure we have a homehost record
- ((not (pair? (remote-hh-dat *runremote*))) ;; have a homehost record?
+ ((not (pair? (remote-hh-dat *runremote*))) ;; not on homehost
(thread-sleep! 0.1) ;; since we shouldn't get here, delay a little
(remote-hh-dat-set! *runremote* (common:get-homehost))
(mutex-unlock! *rmt-mutex*)
(debug:print-info 12 *default-log-port* "rmt:send-receive, case 2")
(rmt:send-receive cmd rid params attemptnum: attemptnum))
@@ -94,60 +87,92 @@
((and (cdr (remote-hh-dat *runremote*)) ;; on homehost
(member cmd api:read-only-queries)) ;; this is a read
(mutex-unlock! *rmt-mutex*)
(debug:print-info 12 *default-log-port* "rmt:send-receive, case 3")
(rmt:open-qry-close-locally cmd 0 params))
+
+ ;; on homehost and this is a write, we already have a server, but server has died
+ ((and (cdr (remote-hh-dat *runremote*)) ;; on homehost
+ (not (member cmd api:read-only-queries)) ;; this is a write
+ (remote-server-url *runremote*) ;; have a server
+ (not (server:read-dotserver *toppath*))) ;; server has died.
+ (set! *runremote* #f)
+ (mutex-unlock! *rmt-mutex*)
+ (debug:print-info 12 *default-log-port* "rmt:send-receive, case 4.1")
+ (rmt:send-receive cmd rid params attemptnum: attemptnum))
+
;; on homehost and this is a write, we already have a server
((and (cdr (remote-hh-dat *runremote*)) ;; on homehost
(not (member cmd api:read-only-queries)) ;; this is a write
(remote-server-url *runremote*)) ;; have a server
(mutex-unlock! *rmt-mutex*)
(debug:print-info 12 *default-log-port* "rmt:send-receive, case 4")
(rmt:open-qry-close-locally cmd 0 params))
- ;; on homehost and this is a write, we have a server (we know because case 4 checked)
- ((and (cdr (remote-hh-dat *runremote*)) ;; on homehost
- (not (member cmd api:read-only-queries)))
- (mutex-unlock! *rmt-mutex*)
- (debug:print-info 12 *default-log-port* "rmt:send-receive, case 4.1")
- (rmt:open-qry-close-locally cmd 0 params))
- ;; no server contact made and this is a write, passively start a server
- ((and (not (remote-server-url *runremote*))
+
+ ;; commented by bb; this was blocking server passive start on write on homehost (case 5)
+ ;; ;; on homehost and this is a write, we have a server (we know because case 4 checked)
+ ;; ((and (cdr (remote-hh-dat *runremote*)) ;; on homehost
+ ;; (not (member cmd api:read-only-queries)))
+ ;; (mutex-unlock! *rmt-mutex*)
+ ;; (debug:print-info 12 *default-log-port* "rmt:send-receive, case 4.1")
+ ;; (rmt:open-qry-close-locally cmd 0 params))
+
+
+ ;; on homehost, no server contact made and this is a write, passively start a server
+ ((and (cdr (remote-hh-dat *runremote*)) ; new
+ (not (remote-server-url *runremote*))
(not (member cmd api:read-only-queries)))
(debug:print-info 12 *default-log-port* "rmt:send-receive, case 5")
- (let ((serverconn (server:read-dotserver *toppath*))) ;; (server:check-if-running *toppath*))) ;; Do NOT want to run server:check-if-running - very expensive to do for every write call
- (if serverconn
- (remote-server-url-set! *runremote* serverconn) ;; the string can be consumed by the client setup if needed
+ (let ((server-url (server:read-dotserver->url *toppath*))) ;; (server:check-if-running *toppath*))) ;; Do NOT want to run server:check-if-running - very expensive to do for every write call
+ (if server-url
+ (remote-server-url-set! *runremote* server-url) ;; the string can be consumed by the client setup if needed
(if (not (server:start-attempted? *toppath*))
(server:kind-run *toppath*))))
- (if (cdr (remote-hh-dat *runremote*)) ;; we are on the homehost, just do the call
- (begin
- (mutex-unlock! *rmt-mutex*)
- (debug:print-info 12 *default-log-port* "rmt:send-receive, case 5.1")
- (rmt:open-qry-close-locally cmd 0 params))
- (begin ;; not on homehost, start server and wait
- (mutex-unlock! *rmt-mutex*)
- (debug:print-info 12 *default-log-port* "rmt:send-receive, case 5.2")
- (tasks:start-and-wait-for-server (tasks:open-db) 0 15)
- (rmt:send-receive cmd rid params attemptnum: attemptnum))))
+ (mutex-unlock! *rmt-mutex*)
+ (debug:print-info 12 *default-log-port* "rmt:send-receive, case 5.1")
+ (rmt:open-qry-close-locally cmd 0 params))
+
+
+
+ ;;;
+ ;; (begin ;; not on homehost, start server and wait
+ ;; (mutex-unlock! *rmt-mutex*)
+ ;; (debug:print-info 12 *default-log-port* "rmt:send-receive, case 5.2")
+ ;; (tasks:start-and-wait-for-server (tasks:open-db) 0 15)
+ ;; (rmt:send-receive cmd rid params attemptnum: attemptnum)) ;) ;)
+;;;;
+
;; if not on homehost ensure we have a connection to a live server
;; NOTE: we *have* a homehost record by now
- ((and (not (cdr (remote-hh-dat *runremote*))) ;; are we on a homehost?
+
+ ;; ((and (not (cdr (remote-hh-dat *runremote*))) ;; not on a homehost
+ ;; (not (remote-conndat *runremote*)) ;; and no connection
+ ;; (server:read-dotserver *toppath*)) ;; .server file exists
+ ;; ;; something caused the server entry in tdb to disappear, but the server is still running
+ ;; (server:remove-dotserver-file *toppath* ".*")
+ ;; (mutex-unlock! *rmt-mutex*)
+ ;; (debug:print-info 12 *default-log-port* "rmt:send-receive, case 20")
+ ;; (rmt:send-receive cmd rid params attemptnum: (add1 attemptnum)))
+
+ ((and (not (cdr (remote-hh-dat *runremote*))) ;; not on a homehost
(not (remote-conndat *runremote*))) ;; and no connection
(debug:print-info 12 *default-log-port* "rmt:send-receive, case 6 hh-dat: " (remote-hh-dat *runremote*) " conndat: " (remote-conndat *runremote*))
(mutex-unlock! *rmt-mutex*)
(tasks:start-and-wait-for-server (tasks:open-db) 0 15)
- (remote-conndat-set! *runremote* (rmt:get-connection-info 0)) ;; calls client:setup which calls client:setup-http
- (rmt:send-receive cmd rid params attemptnum: attemptnum))
+ (remote-conndat-set! *runremote* (rmt:get-connection-info *toppath*)) ;; calls client:setup which calls client:setup-http
+ (rmt:send-receive cmd rid params attemptnum: attemptnum)) ;; TODO: add back-off timeout as
;; all set up if get this far, dispatch the query
((cdr (remote-hh-dat *runremote*)) ;; we are on homehost
(mutex-unlock! *rmt-mutex*)
(debug:print-info 12 *default-log-port* "rmt:send-receive, case 7")
(rmt:open-qry-close-locally cmd (if rid rid 0) params))
+
;; not on homehost, do server query
(else
(mutex-unlock! *rmt-mutex*)
(debug:print-info 12 *default-log-port* "rmt:send-receive, case 9")
+ (mutex-lock! *rmt-mutex*)
(let* ((conninfo (remote-conndat *runremote*))
(dat (case (remote-transport *runremote*)
((http) (condition-case ;; handling here has caused a lot of problems. However it is needed to deal with attemtped communication to servers that have gone away
(http-transport:client-api-send-receive 0 conninfo cmd params)
((commfail)(vector #f "communications fail"))
@@ -156,44 +181,48 @@
(debug:print 0 *default-log-port* "ERROR: transport " (remote-transport *runremote*) " not supported")
(exit))))
(success (if (vector? dat) (vector-ref dat 0) #f))
(res (if (vector? dat) (vector-ref dat 1) #f)))
(if (vector? conninfo)(http-transport:server-dat-update-last-access conninfo)) ;; refresh access time
- (debug:print-info 12 *default-log-port* "rmt:send-receive, case 9. conninfo=" conninfo " dat=" dat)
+ ;; (mutex-unlock! *rmt-mutex*)
+ (debug:print-info 12 *default-log-port* "rmt:send-receive, case 9. conninfo=" conninfo " dat=" dat " *runremote* = "*runremote*)
(if success
(case (remote-transport *runremote*)
- ((http) res)
+ ((http)
+ (mutex-unlock! *rmt-mutex*)
+ res)
(else
(debug:print 0 *default-log-port* "ERROR: transport " (remote-transport *runremote*) " is unknown")
+ (mutex-unlock! *rmt-mutex*)
(exit 1)))
(begin
(debug:print 0 *default-log-port* "WARNING: communication failed. Trying again, try num: " attemptnum)
(remote-conndat-set! *runremote* #f)
(remote-server-url-set! *runremote* #f)
(debug:print-info 12 *default-log-port* "rmt:send-receive, case 9.1")
+ (mutex-unlock! *rmt-mutex*)
(tasks:start-and-wait-for-server (tasks:open-db) 0 15)
(rmt:send-receive cmd rid params attemptnum: (+ attemptnum 1)))))))))
-(define (rmt:update-db-stats run-id rawcmd params duration)
- (mutex-lock! *db-stats-mutex*)
- (handle-exceptions
- exn
- (begin
- (debug:print 0 *default-log-port* "WARNING: stats collection failed in update-db-stats")
- (debug:print 0 *default-log-port* " message: " ((condition-property-accessor 'exn 'message) exn))
- (print "exn=" (condition->list exn))
- #f) ;; if this fails we don't care, it is just stats
- (let* ((cmd (conc "run-id=" run-id " " (if (eq? rawcmd 'general-call) (car params) rawcmd)))
- (stat-vec (hash-table-ref/default *db-stats* cmd #f)))
- (if (not (vector? stat-vec))
- (let ((newvec (vector 0 0)))
- (hash-table-set! *db-stats* cmd newvec)
- (set! stat-vec newvec)))
- (vector-set! stat-vec 0 (+ (vector-ref stat-vec 0) 1))
- (vector-set! stat-vec 1 (+ (vector-ref stat-vec 1) duration))))
- (mutex-unlock! *db-stats-mutex*))
-
+;; (define (rmt:update-db-stats run-id rawcmd params duration)
+;; (mutex-lock! *db-stats-mutex*)
+;; (handle-exceptions
+;; exn
+;; (begin
+;; (debug:print 0 *default-log-port* "WARNING: stats collection failed in update-db-stats")
+;; (debug:print 0 *default-log-port* " message: " ((condition-property-accessor 'exn 'message) exn))
+;; (print "exn=" (condition->list exn))
+;; #f) ;; if this fails we don't care, it is just stats
+;; (let* ((cmd (conc "run-id=" run-id " " (if (eq? rawcmd 'general-call) (car params) rawcmd)))
+;; (stat-vec (hash-table-ref/default *db-stats* cmd #f)))
+;; (if (not (vector? stat-vec))
+;; (let ((newvec (vector 0 0)))
+;; (hash-table-set! *db-stats* cmd newvec)
+;; (set! stat-vec newvec)))
+;; (vector-set! stat-vec 0 (+ (vector-ref stat-vec 0) 1))
+;; (vector-set! stat-vec 1 (+ (vector-ref stat-vec 1) duration))))
+;; (mutex-unlock! *db-stats-mutex*))
(define (rmt:print-db-stats)
(let ((fmtstr "~40a~7-d~9-d~20,2-f")) ;; "~20,2-f"
(debug:print 18 *default-log-port* "DB Stats\n========")
(debug:print 18 *default-log-port* (format #f "~40a~8a~10a~10a" "Cmd" "Count" "TotTime" "Avg"))
@@ -257,11 +286,11 @@
;; (rmt:update-db-stats run-id cmd params duration)
;; mark this run as dirty if this was a write, the watchdog is responsible for syncing it
(if qry-is-write
(let ((start-time (current-seconds)))
(mutex-lock! *db-multi-sync-mutex*)
- (set! *db-last-write* start-time) ;; the oldest "write"
+ (set! *db-last-access* start-time) ;; THIS IS PROBABLY USELESS? (we are on a client)
(mutex-unlock! *db-multi-sync-mutex*)))))
res))
(define (rmt:send-receive-no-auto-client-setup connection-info cmd run-id params)
(let* ((run-id (if run-id run-id 0))
@@ -320,10 +349,15 @@
;; 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)))
+
+;; given a hostname, return a pair of cpu load and update time representing latest intelligence from tests running on that host
+(define (rmt:get-latest-host-load hostname)
+ (rmt:send-receive 'get-latest-host-load 0 (list hostname)))
+
;; (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
@@ -330,10 +364,17 @@
(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))
+
+;;======================================================================
+;; T E S T M E T A
+;;======================================================================
+
+(define (rmt:get-tests-tags)
+ (rmt:send-receive 'get-tests-tags #f '()))
;;======================================================================
;; K E Y S
;;======================================================================
@@ -345,10 +386,15 @@
(define (rmt:get-keys)
(if *db-keys* *db-keys*
(let ((res (rmt:send-receive 'get-keys #f '())))
(set! *db-keys* res)
res)))
+
+(define (rmt:get-keys-write) ;; dummy query to force server start
+ (let ((res (rmt:send-receive 'get-keys-write #f '())))
+ (set! *db-keys* res)
+ res))
;; we don't reuse run-id's (except possibly *after* a db cleanup) so it is safe
;; to cache the resuls in a hash
;;
(define (rmt:get-key-vals run-id)
@@ -460,12 +506,12 @@
;; This is not needed as test steps are deleted on test delete call
;;
;; (define (rmt:delete-test-step-records run-id test-id)
;; (rmt:send-receive 'delete-test-step-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:test-set-state-status run-id test-id state status msg)
+ (rmt:send-receive 'test-set-state-status run-id (list run-id test-id state status msg)))
(define (rmt:test-toplevel-num-items run-id test-name)
(rmt:send-receive 'test-toplevel-num-items run-id (list run-id test-name)))
;; (define (rmt:get-previous-test-run-record run-id test-name item-path)
@@ -524,12 +570,12 @@
(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)))
;; state and status are extra hints not usually used in the calculation
;;
-(define (rmt:roll-up-pass-fail-counts run-id test-name item-path state status comment)
- (rmt:send-receive 'roll-up-pass-fail-counts run-id (list run-id test-name item-path state status comment)))
+(define (rmt:set-state-status-and-roll-up-items run-id test-name item-path state status comment)
+ (rmt:send-receive 'set-state-status-and-roll-up-items run-id (list run-id test-name item-path state status comment)))
(define (rmt:update-pass-fail-counts run-id test-name)
(rmt:general-call 'update-pass-fail-counts run-id test-name test-name test-name))
(define (rmt:top-test-set-per-pf-counts run-id test-name)
Index: rpc-transport.scm
==================================================================
--- rpc-transport.scm
+++ rpc-transport.scm
@@ -176,11 +176,11 @@
(if ping-res
(let ((server-dat (list iface port #f #f #f)))
(hash-table-set! *runremote* run-id server-dat)
server-dat)
(begin
- (server:try-running run-id)
+ (server:try-running *toppath*)
(thread-sleep! 2)
(rpc-transport:client-setup run-id (- remtries 1)))))
(let* ((server-db-info (open-run-close tasks:get-server tasks:open-db run-id)))
(debug:print-info 0 *default-log-port* "client:setup server-dat=" server-dat ", remaining-tries=" remaining-tries)
(if server-db-info
@@ -191,15 +191,15 @@
(if start-res
(begin
(hash-table-set! *runremote* run-id server-dat)
server-dat)
(begin
- (server:try-running run-id)
+ (server:try-running *toppath*)
(thread-sleep! 2)
(rpc-transport:client-setup run-id (- remtries 1)))))
(begin
- (server:try-running run-id)
+ (server:try-running *toppath*)
(thread-sleep! 2)
(rpc-transport:client-setup run-id (- remtries 1)))))))))
;;
;; (port (if (and hostinfo (> (length hostdat) 1))(cadr hostdat) #f)))
;; (if (and port
Index: runs.scm
==================================================================
--- runs.scm
+++ runs.scm
@@ -928,11 +928,11 @@
(debug:print 0 *default-log-port* "WARNING: test " hed " has FAILED prerequitests and we've tried at least 10 times to run it. Giving up now."))
;; (debug:print 0 *default-log-port* " prereqs: " prereqs-not-met)
(hash-table-set! test-registry hed 'removed)
(mt:test-set-state-status-by-testname run-id test-name item-path "NOT_STARTED" "TEN_STRIKES" #f)
;; I'm unclear on if this roll up is needed - it may be the root cause of the "all set to FAIL" bug.
- (rmt:roll-up-pass-fail-counts run-id test-name item-path #f "FAIL" #f) ;; treat as FAIL
+ (rmt:set-state-status-and-roll-up-items run-id test-name item-path #f "FAIL" #f) ;; treat as FAIL
(list (if (null? tal)(car newtal)(car tal))
tal
reg
reruns)))))
;; can't drop this - maybe running? Just keep trying
@@ -1673,10 +1673,11 @@
((remove-runs)
;; (if (tasks:need-server run-id)(tasks:start-and-wait-for-server tdbdat run-id 10))
;; seek and kill in flight -runtests with % as testpatt here
;; (if (equal? testpatt "%")
(tasks:kill-runner target run-name testpatt)
+
;; (debug:print 0 *default-log-port* "not attempting to kill any run launcher processes as testpatt is " testpatt))
(debug:print 1 *default-log-port* "Removing tests for run: " runkey " " (db:get-value-by-header run header "runname")))
((set-state-status)
(if (tasks:need-server run-id)(tasks:start-and-wait-for-server tdbdat run-id 10))
(debug:print 1 *default-log-port* "Modifying state and staus for tests for run: " runkey " " (db:get-value-by-header run header "runname")))
@@ -1958,10 +1959,23 @@
(if (and val (not (equal? (vector-ref currrecord idx) val)))
(begin
(print "Updating " test-name " " fld " to " val)
(rmt:testmeta-update-field test-name fld val)))))
'(("author" 2)("owner" 3)("description" 4)("reviewed" 5)("tags" 9)("jobgroup" 10)))))
+
+;; find tests with matching tags, tagpatt is a string "tagpatt1,tagpatt2%, ..."
+;;
+(define (runs:get-tests-matching-tags tagpatt)
+ (let* ((tagdata (rmt:get-tests-tags))
+ (res '())) ;; list of tests that match one or more tags
+ (for-each
+ (lambda (tag)
+ (if (patt-list-match tag tagpatt)
+ (set! res (append (hash-table-ref tagdata tag)))))
+ (hash-table-keys tagdata))
+ res))
+
;; 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
ADDED sample-sauth-paths.scm
Index: sample-sauth-paths.scm
==================================================================
--- /dev/null
+++ sample-sauth-paths.scm
@@ -0,0 +1,4 @@
+(define *db-path* "/path/to/db")
+(define *exe-path* "/path/to/store/suids")
+(define *exe-src* "/path/to/spublish/and/sretrieve/executables")
+(define *sauth-path* "/path/to/production/sauthorize/exe")
ADDED sauth-common.scm
Index: sauth-common.scm
==================================================================
--- /dev/null
+++ sauth-common.scm
@@ -0,0 +1,263 @@
+
+;; Create the sqlite db
+(define (sauthorize:db-do proc)
+ (if (or (not *db-path*)
+ (not (file-exists? *db-path*)))
+ (begin
+ (print 0 "[database]\nlocation " *db-path* " \n\n Is missing from the config file!")
+ (exit 1)))
+ (if (and *db-path*
+ (directory? *db-path*)
+ (file-read-access? *db-path*))
+ (let* ((dbpath (conc *db-path* "/sauthorize.db"))
+ (writeable (file-write-access? dbpath))
+ (dbexists (file-exists? dbpath)))
+ (handle-exceptions
+ exn
+ (begin
+ (debug:print 2 "ERROR: problem accessing db " dbpath
+ ((condition-property-accessor 'exn 'message) exn))
+ (exit 1))
+ ; (print "calling proc " proc "db path " dbpath )
+ (call-with-database
+ dbpath
+ (lambda (db)
+ ;(print 0 "calling proc " proc " on db " db)
+ (set-busy-handler! db (busy-timeout 10000)) ;; 10 sec timeout
+ (if (not dbexists)(sauthorize:initialize-db db))
+ (proc db)))))
+ (print 0 "ERROR: invalid path for storing database: " *db-path*)))
+
+;;execute a query
+(define (sauthorize:db-qry db qry)
+ (exec (sql db qry)))
+
+
+(define (sauthorize:do-as-calling-user proc)
+ (let ((eid (current-effective-user-id))
+ (cid (current-user-id)))
+ (if (not (eq? eid cid)) ;; running suid
+ (set! (current-effective-user-id) cid))
+ ;(print 0 "cid " cid " eid:" eid)
+ (proc)
+ (if (not (eq? eid cid))
+ (set! (current-effective-user-id) eid))))
+
+
+(define (run-cmd cmd arg-list)
+ ; (print (current-effective-user-id))
+ ;(handle-exceptions
+; exn
+; (print 0 "ERROR: failed to run script " cmd " with params " arg-list " " (exn assert))
+ (let ((pid (process-run cmd arg-list)))
+ (process-wait pid))
+)
+;)
+
+
+(define (regster-log inl usr-id area-id cmd)
+ (sauth-common:shell-do-as-adm
+ (lambda ()
+ (sauthorize:db-do (lambda (db)
+ (sauthorize:db-qry db (conc "INSERT INTO actions (cmd,user_id,area_id,action_type ) VALUES ('sretrieve " inl "'," usr-id "," area-id ", 'cat' )")))))))
+
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+; Check user types
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+
+
+
+;;check if a user is an admin
+(define (is-admin username)
+ (let* ((admin #f))
+ (sauthorize:db-do (lambda (db)
+ (let* ((data-row (query fetch (sql db (conc "SELECT users.is_admin FROM users where users.username = '" username "'")))))
+ (if (not (null? data-row))
+ (let ((col (car data-row)))
+ (if (equal? col "yes")
+ (set! admin #t)))))))
+admin))
+
+
+;;check if a user is an read-admin
+(define (is-read-admin username)
+ (let* ((admin #f))
+ (sauthorize:db-do (lambda (db)
+ (let* ((data-row (query fetch (sql db (conc "SELECT users.is_admin FROM users where users.username = '" username "'")))))
+ (if (not (null? data-row))
+ (let ((col (car data-row)))
+ (if (equal? col "read-admin")
+ (set! admin #t)))))))
+admin))
+
+
+;;check if user has specifc role for a area
+(define (is-user role username area)
+ (let* ((has-access #f))
+ (sauthorize:db-do (lambda (db)
+ (let* ((data-row (query fetch (sql db (conc "SELECT permissions.access_type, permissions.expiration FROM users , areas, permissions where permissions.user_id = users.id and permissions.area_id = areas.id and users.username = '" username "' and areas.code = '" area "'")))))
+ (if (not (null? data-row))
+ (begin
+ (let* ((access-type (car data-row))
+ (exdate (cadr data-row)))
+ (if (not (null? exdate))
+ (begin
+ (let ((valid (is-access-valid exdate)))
+ ;(print valid)
+ (if (and (equal? access-type role)
+ (equal? valid #t))
+ (set! has-access #t))))
+ (print "Access expired"))))))))
+ ;(print has-access)
+has-access))
+
+(define (is-access-valid exp-str)
+ (let* ((ret-val #f )
+ (date-parts (string-split exp-str "/"))
+ (yr (string->number (car date-parts)))
+ (month (string->number(car (cdr date-parts))))
+ (day (string->number(caddr date-parts)))
+ (exp-date (make-date 0 0 0 0 day month yr )))
+ ;(print exp-date)
+ ;(print (current-date))
+ (if (> (date-compare exp-date (current-date)) 0)
+ (set! ret-val #t))
+ ;(print ret-val)
+ ret-val))
+
+
+;check if area exists
+(define (area-exists area)
+ (let* ((area-defined #f))
+ (sauthorize:db-do (lambda (db)
+ (let* ((data-row (query fetch (sql db (conc "SELECT id FROM areas where areas.code = '" area "'")))))
+ (if (not (null? data-row))
+ (set! area-defined #t)))))
+area-defined))
+
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+; Get Record from database
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+
+;gets area id by code
+(define (get-area area)
+ (let* ((area-defined '()))
+ (sauthorize:db-do (lambda (db)
+ (let* ((data-row (query fetch (sql db (conc "SELECT id FROM areas where areas.code = '" area "'")))))
+ (set! area-defined data-row))))
+area-defined))
+
+;get id of users table by user name
+(define (get-user user)
+ (let* ((user-defined '()))
+ (sauthorize:db-do (lambda (db)
+ (let* ((data-row (query fetch (sql db (conc "SELECT id FROM users where users.username = '" user "'")))))
+ (set! user-defined data-row))))
+user-defined))
+
+;get permissions id by userid and area id
+(define (get-perm userid areaid)
+ (let* ((user-defined '()))
+ (sauthorize:db-do (lambda (db)
+ (let* ((data-row (query fetch (sql db (conc "SELECT id FROM permissions where user_id = " userid " and area_id = " areaid)))))
+ (set! user-defined data-row))))
+
+user-defined))
+
+(define (get-restrictions base-path usr)
+(let* ((user-defined '()))
+ (sauthorize:db-do (lambda (db)
+ (let* ((data-row (query fetch (sql db (conc "SELECT restriction FROM areas, users, permissions where areas.id = permissions.area_id and users.id = permissions.user_id and users.username = '" usr "' and areas.basepath = '" base-path "'")))))
+ ;(print data-row)
+ (set! user-defined data-row))))
+ ; (print user-defined)
+ (if (null? user-defined)
+ ""
+ (car user-defined))))
+
+
+(define (get-obj-by-path path)
+ (let* ((obj '()))
+ (sauthorize:db-do (lambda (db)
+ (let* ((data-row (query fetch (sql db (conc "SELECT code,exe_name, id, basepath FROM areas where areas.basepath = '" path "'")))))
+ (set! obj data-row))))
+obj))
+
+(define (get-obj-by-code code )
+ (let* ((obj '()))
+ (sauthorize:db-do (lambda (db)
+ (let* ((data-row (query fetch (sql db (conc "SELECT code, exe_name, id, basepath FROM areas where areas.code = '" code "'")))))
+ (set! obj data-row))))
+;(print obj)
+obj))
+
+
+
+;; function to validate the users input for target path and resolve the path
+;; TODO: Check for restriction in subpath
+(define (sauth-common:resolve-path new current allowed-sheets)
+ (let* ((target-path (append current (string-split new "/")))
+ (target-path-string (string-join target-path "/"))
+ (normal-path (normalize-pathname target-path-string))
+ (normal-list (string-split normal-path "/"))
+ (ret '()))
+ (if (string-contains normal-path "..")
+ (begin
+ (print "ERROR: Path " new " resolved outside target area ")
+ #f)
+ (if(equal? normal-path ".")
+ ret
+ (if (not (member (car normal-list) allowed-sheets))
+ (begin
+ (print "ERROR: Permision denied to " new )
+ #f)
+ normal-list)))))
+
+(define (sauth-common:get-target-path base-path-list ext-path top-areas base-path)
+ (let* ((resolved-path (sauth-common:resolve-path ext-path base-path-list top-areas ))
+ (usr (current-user-name) ) )
+ (if (not (equal? resolved-path #f))
+ (if (null? resolved-path)
+ #f
+ (let* ((sheet (car resolved-path))
+ (restricted-areas (get-restrictions base-path usr))
+ (restrictions (conc ".*" (string-join (string-split restricted-areas ",") ".*|.*") ".*"))
+ (target-path (if (null? (cdr resolved-path))
+ base-path
+ (conc base-path "/" (string-join (cdr resolved-path) "/")))))
+ ; (print restricted-areas)
+ (if (and (not (equal? restricted-areas "" ))
+ (string-match (regexp restrictions) target-path))
+ (begin
+ (print "Access denied to " (string-join resolved-path "/"))
+ ;(exit 1)
+ #f)
+ target-path)))
+ #f)))
+
+(define (sauth-common:shell-ls-cmd base-path-list ext-path top-areas base-path tail-cmd-list)
+ (if (and (null? base-path-list) (equal? ext-path "") )
+ (print (string-intersperse top-areas " "))
+ (let* ((resolved-path (sauth-common:resolve-path ext-path base-path-list top-areas )))
+ ;(print resolved-path)
+ (if (not (equal? resolved-path #f))
+ (if (null? resolved-path)
+ (print (string-intersperse top-areas " "))
+ (let* ((target-path (sauth-common:get-target-path base-path-list ext-path top-areas base-path)))
+ (print target-path)
+ (if (not (equal? target-path #f))
+ (begin
+ (cond
+ ((null? tail-cmd-list)
+ (run (pipe
+ (ls "-lrt" ,target-path))))
+ ((not (equal? (car tail-cmd-list) "|"))
+ (print "ls cmd cannot accept " (string-join tail-cmd-list) " as an argument!!"))
+ (else
+ (run (pipe
+ (ls "-lrt" ,target-path)
+ (begin (system (string-join (cdr tail-cmd-list))))))
+ )
+)))
+))))))
+
ADDED sauthorize.scm
Index: sauthorize.scm
==================================================================
--- /dev/null
+++ sauthorize.scm
@@ -0,0 +1,544 @@
+
+;; 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 defstruct)
+(use scsh-process)
+
+(use srfi-18)
+(use srfi-19)
+(use refdb)
+
+(use sql-de-lite srfi-1 posix regex regex-case srfi-69)
+(declare (uses common))
+
+(declare (uses configf))
+(declare (uses margs))
+(declare (uses megatest-version))
+
+(include "megatest-fossil-hash.scm")
+;;; please create this file before using sautherise. For sample file is avaliable sample-sauth-paths.scm.
+(include "sauth-paths.scm")
+(include "sauth-common.scm")
+
+;;
+;; GLOBALS
+;;
+(define *verbosity* 1)
+(define *logging* #f)
+(define *exe-name* (pathname-file (car (argv))))
+(define *sretrieve:current-tab-number* 0)
+(define *args-hash* (make-hash-table))
+(define sauthorize:help (conc "Usage: " *exe-name* " [action [params ...]]
+
+ list : list areas $USER's can access
+ log : get listing of recent activity.
+ sauth list-area-user <area code> : list the users that can access the area.
+ sauth open <path> --group <grpname> : Open up an area. User needs to be the owner of the area to open it.
+ --code <unique short identifier for an area>
+ --retrieve|--publish
+ sauth grant <username> --area <area identifier> : Grant permission to read or write to a area that is alrady opend up.
+ --expiration yyyy/mm/dd --retrieve|--publish
+ [--restrict <comma separated directory names> ]
+ sauth read-shell <area identifier> : Open sretrieve shell for reading.
+ sauth write-shell <area identifier> : Open spublish shell for writing.
+
+Part of the Megatest tool suite.
+Learn more at http://www.kiatoa.com/fossils/megatest
+
+Version: " megatest-fossil-hash)) ;; "
+
+;;======================================================================
+;; RECORDS
+;;======================================================================
+
+;;======================================================================
+;; DB
+;;======================================================================
+
+;; replace (strftime('%s','now')), with datetime('now'))
+(define (sauthorize:initialize-db db)
+ (for-each
+ (lambda (qry)
+ (exec (sql db qry)))
+ (list
+ "CREATE TABLE IF NOT EXISTS actions
+ (id INTEGER PRIMARY KEY,
+ cmd TEXT NOT NULL,
+ user_id INTEGER NOT NULL,
+ datetime TIMESTAMP DEFAULT (datetime('now','localtime')),
+ area_id INTEGER NOT NULL,
+ comment TEXT DEFAULT '' NOT NULL,
+ action_type TEXT NOT NULL);"
+ "CREATE TABLE IF NOT EXISTS users
+ (id INTEGER PRIMARY KEY,
+ username TEXT NOT NULL,
+ is_admin TEXT NOT NULL,
+ datetime TIMESTAMP DEFAULT (datetime('now','localtime'))
+ );"
+ "CREATE TABLE IF NOT EXISTS areas
+ (id INTEGER PRIMARY KEY,
+ basepath TEXT NOT NULL,
+ code TEXT NOT NULL,
+ exe_name TEXT NOT NULL,
+ datetime TIMESTAMP DEFAULT (datetime('now','localtime'))
+ );"
+ "CREATE TABLE IF NOT EXISTS permissions
+ (id INTEGER PRIMARY KEY,
+ access_type TEXT NOT NULL,
+ user_id INTEGER NOT NULL,
+ datetime TIMESTAMP DEFAULT (datetime('now','localtime')),
+ area_id INTEGER NOT NULL,
+ restriction TEXT DEFAULT '' NOT NULL,
+ expiration TIMESTAMP DEFAULT NULL);"
+ )))
+
+
+
+
+(define (get-access-type args)
+ (let loop ((hed (car args))
+ (tal (cdr args)))
+ (cond
+ ((equal? hed "--retrieve")
+ "retrieve")
+ ((equal? hed "--publish")
+ "publish")
+ ((equal? hed "--area-admin")
+ "area-admin")
+ ((equal? hed "--writer-admin")
+ "writer-admin")
+ ((equal? hed "--read-admin")
+ "read-admin")
+
+ ((null? tal)
+ #f)
+ (else
+ (loop (car tal)(cdr tal))))))
+
+
+
+;; check if user can gran access to an area
+(define (can-grant-perm username access-type area)
+ (let* ((isadmin (is-admin username))
+ (is-area-admin (is-user "area-admin" username area ))
+ (is-read-admin (is-user "read-admin" username area) )
+ (is-writer-admin (is-user "writer-admin" username area) ) )
+ (cond
+ ((equal? isadmin #t)
+ #t)
+ ((equal? is-area-admin #t )
+ #t)
+ ((and (equal? is-writer-admin #t ) (equal? access-type "retrieve"))
+ #t)
+ ((and (equal? is-read-admin #t ) (equal? access-type "retrieve"))
+ #t)
+
+ (else
+ #f))))
+
+(define (sauthorize:list-areausers area )
+ (sauthorize:db-do (lambda (db)
+ (print "Users having access to " area ":")
+ (query (for-each-row
+ (lambda (row)
+ (let* ((exp-date (cadr row)))
+ (if (is-access-valid exp-date)
+ (apply print (intersperse row " | "))))))
+ (sql db (conc "SELECT users.username, permissions.expiration, permissions.access_type FROM users, areas, permissions where permissions.user_id = users.id and permissions.area_id = areas.id and areas.code = '" area "'"))))))
+
+
+
+
+; check if executable exists
+(define (exe-exist exe access-type)
+ (let* ((filepath (conc *exe-path* "/" access-type "/" exe)))
+ ; (print filepath)
+ (if (file-exists? filepath)
+ #t
+ #f)))
+
+(define (copy-exe access-type exe-name group)
+ (run-cmd "/bin/chmod" (list "g+w" (conc *exe-path* "/" access-type)))
+ (let* ((spath (conc *exe-src* "/s" access-type))
+ (dpath (conc *exe-path* "/" access-type "/" exe-name)))
+ (sauthorize:do-as-calling-user
+ (lambda ()
+ (run-cmd "/bin/cp" (list spath dpath ))
+ (if (equal? access-type "publish")
+ (run-cmd "/bin/chmod" (list "u+s,o+rx" dpath))
+ (begin
+ (if (equal? group "none")
+ (run-cmd "/bin/chmod" (list "u+s,o+rx" dpath))
+ (begin
+ (run-cmd "/bin/chgrp" (list group dpath))
+ (run-cmd "/bin/chmod" (list "g+s,o+rx" dpath))))))))
+ (run-cmd "chmod" (list "g-w" (conc *exe-path* "/" access-type)))))
+
+(define (get-exe-name path group)
+ (let ((name ""))
+ (sauthorize:do-as-calling-user
+ (lambda ()
+ (if (equal? (current-effective-user-id) (file-owner path))
+ (set! name (conc (current-user-name) "_" group))
+ (begin
+ (print "You cannot open areas that you dont own!!")
+ (exit 1)))))
+name))
+
+;check if a paths/codes are vaid and if area is alrady open
+(define (open-area group path code access-type)
+ (let* ((exe-name (get-exe-name path group))
+ (path-obj (get-obj-by-path path))
+ (code-obj (get-obj-by-code code)))
+ ;(print path-obj)
+ (cond
+ ((not (null? path-obj))
+ (if (equal? code (car path-obj))
+ (begin
+ (if (equal? exe-name (cadr path-obj))
+ (begin
+ (if (not (exe-exist exe-name access-type))
+ (copy-exe access-type exe-name group)
+ (begin
+ (print "Area already open!!")
+ (exit 1))))
+ (begin
+ (if (not (exe-exist exe-name access-type))
+ (copy-exe access-type exe-name group))
+ ;; update exe-name in db
+ (sauthorize:db-do (lambda (db)
+ (sauthorize:db-qry db (conc "update areas set exe_name = '" exe-name "' where id = " (caddr path-obj)))))
+ )))
+ (begin
+ (print "Path " path " is registered with --code " (car path-obj) ". To open this area please execute following cmd: \n sauthorize open " path " --group " group " --code " (car path-obj) " --" access-type )
+ (exit 1))))
+
+ ((not (null? code-obj))
+ (print "Code " code " is used for diffrent path. Please try diffrent value of --code" )
+ (exit 1))
+ (else
+ ; (print (exe-exist exe-name access-type))
+ (if (not (exe-exist exe-name access-type))
+ (copy-exe access-type exe-name group))
+ (sauthorize:db-do (lambda (db)
+ ;(print (conc "insert into areas (code, basepath, exe_name) values ('" code "', '" path "', '" exe-name "') "))
+ (sauthorize:db-qry db (conc "insert into areas (code, basepath, exe_name) values ('" code "', '" path "', '" exe-name "') "))))))))
+
+(define (user-has-open-perm user path access)
+ (let* ((has-access #f)
+ (eid (current-user-id)))
+ (cond
+ ((is-admin user)
+ (set! has-access #t ))
+ ((and (is-read-admin user) (equal? access "retrieve"))
+ (set! has-access #t ))
+ (else
+ (print "User " user " does not have permission to open areas")))
+ has-access))
+
+
+;;check if user has group access
+(define (is-group-washed req_grpid current-grp-list)
+ (let loop ((hed (car current-grp-list))
+ (tal (cdr current-grp-list)))
+ (cond
+ ((equal? hed req_grpid)
+ #t)
+ ((null? tal)
+ #f)
+ (else
+ (loop (car tal)(cdr tal))))))
+
+;create executables with appropriate suids
+(define (sauthorize:open user path group code access-type)
+ (let* ((gpid (group-information group))
+ (req_grpid (if (equal? group "none")
+ group
+ (if (equal? gpid #f)
+ #f
+ (caddr gpid))))
+ (current-grp-list (get-groups))
+ (valid-grp (if (equal? group "none")
+ group
+ (is-group-washed req_grpid current-grp-list))))
+ (if (and (not (equal? group "none")) (equal? valid-grp #f ))
+ (begin
+ (print "Group " group " is not washed in the current xterm!!")
+ (exit 1))))
+ (if (not (file-write-access? path))
+ (begin
+ (print "You can open areas owned by yourself. You do not have permissions to open path." path)
+ (exit 1)))
+ (if (user-has-open-perm user path access-type)
+ (begin
+ ;(print "here")
+ (open-area group path code access-type)
+ (sauthorize:grant user user code "2017/12/25" "read-admin" "")
+ (sauthorize:db-do (lambda (db)
+ (sauthorize:db-qry db (conc "INSERT INTO actions (cmd,user_id,area_id,action_type ) VALUES ('sauthorize open " path " --code " code " --group " group " --" access-type "'," (car (get-user user)) "," (car (get-area code)) ", 'open' )"))))
+ (print "Area has " path " been opened for " access-type ))))
+
+(define (sauthorize:grant auser guser area exp-date access-type restrict)
+ ; check if user exist
+ (let* ((area-obj (get-area area))
+ (auser-obj (get-user auser))
+ (user-obj (get-user guser)))
+
+ (if (null? user-obj)
+ (begin
+ (sauthorize:db-do (lambda (db)
+ (sauthorize:db-qry db (conc "insert into users (username, is_admin) values ('" guser "', 'no') "))))
+ (set! user-obj (get-user guser))))
+ (let* ((perm-obj (get-perm (car user-obj) (car area-obj))))
+ (if(null? perm-obj)
+ (begin
+ ;; insert permissions
+ (sauthorize:db-do (lambda (db)
+ (sauthorize:db-qry db (conc "insert into permissions (access_type, user_id, area_id, restriction, expiration ) values ('" access-type "', " (car user-obj) ", " (car area-obj) ", '" restrict "', '" exp-date "')")))))
+ (begin
+ ;update permissions
+ (sauthorize:db-do (lambda (db)
+ (sauthorize:db-qry db (conc "update permissions set access_type = '" access-type "' , restriction = '" restrict "', expiration = '" exp-date "' where user_id = " (car user-obj) " and area_id = " (car area-obj)))))))
+ (sauthorize:db-do (lambda (db)
+ (sauthorize:db-qry db (conc "INSERT INTO actions (cmd,user_id,area_id,action_type ) VALUES ('sauthorize grant " guser " --area " area " --expiration " exp-date " --" access-type " --restrict " restrict "'," (car auser-obj) "," (car area-obj) ", 'grant' )"))))
+ (print "Permission has been sucessfully granted to user " guser))))
+
+(define (sauthorize:process-action username action . args)
+ (case (string->symbol action)
+ ((grant)
+ (if (< (length args) 6)
+ (begin
+ (print "ERROR: Missing arguments; " (string-intersperse args ", "))
+ (exit 1)))
+ (let* ((remargs (args:get-args args '("--area" "--expiration" "--restrict") '() args:arg-hash 0))
+ (guser (car args))
+ (restrict (or (args:get-arg "--restrict") ""))
+ (area (or (args:get-arg "--area") ""))
+ (exp-date (or (args:get-arg "--expiration") ""))
+ (access-type (get-access-type remargs)))
+ ; (print "version " guser " restrict " restrict )
+ ; (print "area " area " exp-date " exp-date " access-type " access-type)
+ (cond
+ ((equal? guser "")
+ (print "Username not found!! Try \"sauthorize help\" for useage ")
+ (exit 1))
+ ((equal? area "")
+ (print "Area not found!! Try \"sauthorize help\" for useage ")
+ (exit 1))
+ ((equal? access-type #f)
+ (print "Access type not found!! Try \"sauthorize help\" for useage ")
+ (exit 1))
+ ((equal? exp-date "")
+ (print "Date of expiration not found!! Try \"sauthorize help\" for useage ")
+ (exit 1)))
+ (if (not (area-exists area))
+ (begin
+ (print "Area does not exisit!!")
+ (exit 1)))
+ (if (can-grant-perm username access-type area)
+ (begin
+ (print "calling sauthorize:grant ")
+ (sauthorize:grant username guser area exp-date access-type restrict))
+ (begin
+ (print "User " username " does not have permission to grant permissions to area " area "!!")
+ (exit 1)))))
+ ((list-area-user)
+ (if (not (equal? (length args) 1))
+ (begin
+ (print "Missing argument area code to list-area-user ")
+ (exit 1)))
+ (let* ((area (car args)))
+ (if (not (area-exists area))
+ (begin
+ (print "Area does not exisit!!")
+ (exit 1)))
+
+ (sauthorize:list-areausers area )
+ ))
+ ((read-shell)
+ (if (not (equal? (length args) 1))
+ (begin
+ (print "Missing argument area code to read-shell ")
+ (exit 1)))
+ (let* ((area (car args))
+ (code-obj (get-obj-by-code area)))
+ (if (or (null? code-obj)
+ (not (exe-exist (cadr code-obj) "retrieve")))
+ (begin
+ (print "Area " area " is not open for reading!!")
+ (exit 1)))
+ (sauthorize:do-as-calling-user
+ (lambda ()
+ (run-cmd (conc *exe-path* "/retrieve/" (cadr code-obj) ) (list "shell" area ))))))
+ ((write-shell)
+ (if (not (equal? (length args) 1))
+ (begin
+ (print "Missing argument area code to read-shell ")
+ (exit 1)))
+ (let* ((area (car args))
+ (code-obj (get-obj-by-code area)))
+ (if (or (null? code-obj)
+ (not (exe-exist (cadr code-obj) "publish")))
+ (begin
+ (print "Area " area " is not open for Writing!!")
+ (exit 1)))
+ (sauthorize:do-as-calling-user
+ (lambda ()
+ (run-cmd (conc *exe-path* "/publish/" (cadr code-obj) ) (list "shell" area))))))
+ ((publish)
+ (if (< (length args) 2)
+ (begin
+ (print "Missing argument to publish. \n publish <action> <area> [opts] ")
+ (exit 1)))
+ (let* ((action (car args))
+ (area (cadr args))
+ (cmd-args (cddr args))
+ (code-obj (get-obj-by-code area)))
+ (if (or (null? code-obj)
+ (not (exe-exist (cadr code-obj) "publish")))
+ (begin
+ (print "Area " area " is not open for writing!!")
+ (exit 1)))
+ (sauthorize:do-as-calling-user
+ (lambda ()
+ (run-cmd (conc *exe-path* "/publish/" (cadr code-obj) ) (append (list action area ) cmd-args))))))
+
+ ((retrieve)
+ (if (< (length args) 2)
+ (begin
+ (print "Missing argument to publish. \n publish <action> <area> [opts] ")
+ (exit 1)))
+ (let* ((action (car args))
+ (area (cadr args))
+ (cmd-args (cddr args))
+ (code-obj (get-obj-by-code area)))
+ (if (or (null? code-obj)
+ (not (exe-exist (cadr code-obj) "retrieve")))
+ (begin
+ (print "Area " area " is not open for reading!!")
+ (exit 1)))
+ (sauthorize:do-as-calling-user
+ (lambda ()
+ (run-cmd (conc *exe-path* "/retrieve/" (cadr code-obj) ) (append (list action area ) cmd-args))))))
+
+
+
+ ((open)
+ (if (< (length args) 6)
+ (begin
+ (print "sauthorize open cmd takes 6 arguments!! \n Useage: sauthorize open <path> --group <grpname> --code <unique short identifier for an area> --retrieve|--publish")
+ (exit 1)))
+ (let* ((remargs (args:get-args args '("--group" "--code") '() args:arg-hash 0))
+ (path (car args))
+ (group (or (args:get-arg "--group") ""))
+ (area (or (args:get-arg "--code") ""))
+ (access-type (get-access-type remargs)))
+ (cond
+ ((equal? path "")
+ (print "path not found!! Try \"sauthorize help\" for useage ")
+ (exit 1))
+ ((equal? area "")
+ (print "--code not found!! Try \"sauthorize help\" for useage ")
+ (exit 1))
+ ((equal? access-type #f)
+ (print "Access type not found!! Try \"sauthorize help\" for useage ")
+ (exit 1))
+ ((and (not (equal? access-type "publish"))
+ (not (equal? access-type "retrieve")))
+ (print "Access type can be eiter --retrieve or --publish !! Try \"sauthorize help\" for useage ")
+ (exit 1)))
+
+ (sauthorize:open username path group area access-type)))
+ ((area-admin)
+ (let* ((usr (car args))
+ (usr-obj (get-user usr))
+ (user-id (car (get-user username))))
+
+ (if (is-admin username)
+ (begin
+ ; (print usr-obj)
+ (if (null? usr-obj)
+ (begin
+ (sauthorize:db-do (lambda (db)
+ ;(print (conc "INSERT INTO users (username,is_admin) VALUES ( '" usr "', 'read-admin' )"))
+ (sauthorize:db-qry db (conc "INSERT INTO users (username,is_admin) VALUES ( '" usr "', 'read-admin' )")))))
+ (begin
+ ; (print (conc "update users set is_admin = 'no' where id = " (car usr-obj) ))
+ (sauthorize:db-do (lambda (db)
+ (sauthorize:db-qry db (conc "update users set is_admin = 'read-admin' where id = " (car usr-obj)))))))
+ (print "User " usr " is updated with area-admin access!"))
+ (print "Admin only function"))
+ (sauthorize:db-do (lambda (db)
+ (sauthorize:db-qry db (conc "INSERT INTO actions (cmd,user_id,area_id,action_type ) VALUES ('area-admin " usr " ', " user-id ",0, 'area-admin ')" ))))))
+
+ ((register-log)
+ (if (< (length args) 4)
+ (print "Invalid arguments"))
+ ;(print args)
+ (let* ((cmd-line (car args))
+ (user-id (cadr args))
+ (area-id (caddr args))
+ (user-obj (get-user username))
+ (cmd (cadddr args)))
+
+ (if (and (not (null? user-obj)) (equal? user-id (number->string(car user-obj))))
+ (begin
+ (sauthorize:db-do (lambda (db)
+ (sauthorize:db-qry db (conc "INSERT INTO actions (cmd,user_id,area_id,action_type ) VALUES ('" cmd-line"', " user-id "," area-id ", '" cmd "')" )))))
+ (print "You ar not authorised to run this cmd")
+
+)))
+
+
+ (else (print 0 "Unrecognised command " action))))
+
+(define (main)
+ (let* ((args (argv))
+ (prog (car args))
+ (rema (cdr args))
+ (username (current-user-name)))
+ ;; preserve the exe data in the config file
+ (cond
+ ;; one-word commands
+ ((eq? (length rema) 1)
+ (case (string->symbol (car rema))
+ ((help -h -help --h --help)
+ (print sauthorize:help))
+ ((list)
+
+ (sauthorize:db-do (lambda (db)
+ (print "My Area accesses: ")
+ (query (for-each-row
+ (lambda (row)
+ (let* ((exp-date (car row)))
+ (if (is-access-valid exp-date)
+ (apply print (intersperse (cdr row) " | "))))))
+ (sql db (conc "SELECT permissions.expiration, areas.basepath, areas.code, permissions.access_type FROM users, areas, permissions where permissions.user_id = users.id and permissions.area_id = areas.id and users.username = '" username "'"))))))
+
+ ((log)
+ (sauthorize:db-do (lambda (db)
+ (print "Logs : ")
+ (query (for-each-row
+ (lambda (row)
+
+ (apply print (intersperse row " | "))))
+ (sql db "SELECT actions.cmd, users.username, actions.action_type, actions.datetime, areas.code FROM actions, users, areas where actions.user_id = users.id and actions.area_id = areas.id ")))))
+ (else
+ (print "ERROR: Unrecognised command. Try \"sauthorize help\""))))
+ ;; multi-word commands
+ ((null? rema)(print sauthorize:help))
+ ((>= (length rema) 2)
+ (apply sauthorize:process-action username (car rema)(cdr rema)))
+ (else (debug:print 0 "ERROR: Unrecognised command. Try \"sauthorize help\"")))))
+
+(main)
+
+
+
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 directory-utils)
+(use srfi-1 posix regex regex-case srfi-69 hostinfo md5 message-digest directory-utils posix-extras)
;; (use zmq)
(use spiffy uri-common intarweb http-client spiffy-request-vars)
(declare (unit server))
@@ -47,16 +47,33 @@
;; all routes though here end in exit ...
;;
;; start_server
;;
(define (server:launch run-id transport-type)
- (BB> "server:launch fired for run-id="run-id" transport-type="transport-type)
+ ;;(BB> "server:launch fired for run-id="run-id" transport-type="transport-type)
+
+ (let ((attempt-in-progress (server:start-attempted? *toppath*))) ; check for .server-starting
+ (when attempt-in-progress
+ (debug:print-info 0 *default-log-port* "Server start attempt in progress in other process (=> "attempt-in-progress"<=). Aborting server launch attempt in this process ("(current-process-id)")")
+ (exit)))
+
+ (let ((dotserver-url (server:check-if-running *toppath*))) ;; check for .server
+ (when dotserver-url
+ (debug:print-info 0 *default-log-port* "Server already running (=> "dotserver-url"<=). Aborting server launch attempt in this process ("(current-process-id)")")
+ (exit)
+ ))
+
(case transport-type
((http)(http-transport:launch run-id))
;;((nmsg)(nmsg-transport:launch run-id))
((rpc) (rpc-transport:launch run-id))
- (else (debug:print-error 0 *default-log-port* "unknown server type " transport-type))))
+ (else (debug:print-error 0 *default-log-port* "unknown server type " transport-type)))
+
+ ;; is this a good place to print server exit stats?
+ (debug:print 0 "SERVER: max parallel api requests: " *max-api-process-requests*)
+
+ )
;; (else (debug:print-error 0 *default-log-port* "No known transport set, transport=" transport ", using rpc")
;; (rpc-transport:launch run-id)))))
;;======================================================================
;; S E R V E R U T I L I T I E S
@@ -103,52 +120,60 @@
;; 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
;; incidental: rotate logs in logs/ dir.
;;
-(define (server:run areapath) ;; areapath is ignored for now.
+(define (server:run areapath) ;; areapath is *toppath* for a given testsuite area
(let* ((curr-host (get-host-name))
+ (attempt-in-progress (server:start-attempted? areapath))
+ (dot-server-url (server:check-if-running areapath))
(curr-ip (server:get-best-guess-address curr-host))
(curr-pid (current-process-id))
(homehost (common:get-homehost)) ;; configf:lookup *configdat* "server" "homehost" ))
(target-host (car homehost))
(testsuite (common:get-testsuite-name))
- (logfile (conc *toppath* "/logs/server.log"))
+ (logfile (conc areapath "/logs/server.log"))
(cmdln (conc (common:get-megatest-exe)
" -server " (or target-host "-") " -run-id " 0 (if (equal? (configf:lookup *configdat* "server" "daemonize") "yes")
(conc " -daemonize -log " logfile)
"")
" -m testsuite:" testsuite)) ;; (conc " >> " logfile " 2>&1 &")))))
(log-rotate (make-thread common:rotate-logs "server run, rotate logs thread")))
;; we want the remote server to start in *toppath* so push there
- (push-directory *toppath*)
- (debug:print 0 *default-log-port* "INFO: Trying to start server (" cmdln ") ...")
- (thread-start! log-rotate)
-
- ;; 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 *default-log-port* "Starting server on " target-host ", logfile is " logfile)
- (setenv "TARGETHOST" target-host)))
-
- (setenv "TARGETHOST_LOGF" logfile)
- (common:wait-for-normalized-load 4 " delaying server start due to load" remote-host: (get-environment-variable "TARGETHOST")) ;; do not try starting servers on an already overloaded machine, just wait forever
- (system (conc "nbfake " cmdln))
- (unsetenv "TARGETHOST_LOGF")
- (if (get-environment-variable "TARGETHOST")(unsetenv "TARGETHOST"))
- (thread-join! log-rotate)
- (pop-directory)))
-
+ (push-directory areapath)
+ (cond
+ (attempt-in-progress
+ (debug:print 0 *default-log-port* "INFO: Not trying to start server because attempt is in progress: "attempt-in-progress))
+ (dot-server-url
+ (debug:print 0 *default-log-port* "INFO: Not trying to start server because one is already running : "dot-server-url))
+ (else
+ (debug:print 0 *default-log-port* "INFO: Trying to start server (" cmdln ") ...")
+ (thread-start! log-rotate)
+
+ ;; 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 *default-log-port* "Starting server on " target-host ", logfile is " logfile)
+ (setenv "TARGETHOST" target-host)))
+
+ (setenv "TARGETHOST_LOGF" logfile)
+ (common:wait-for-normalized-load 4 " delaying server start due to load" remote-host: (get-environment-variable "TARGETHOST")) ;; do not try starting servers on an already overloaded machine, just wait forever
+ (system (conc "nbfake " cmdln))
+ (unsetenv "TARGETHOST_LOGF")
+ (if (get-environment-variable "TARGETHOST")(unsetenv "TARGETHOST"))
+ (thread-join! log-rotate)
+ (pop-directory)))))
+
(define (server:get-client-signature) ;; BB> why is this proc named "get-"? it returns nothing -- set! has not return value.
(if *my-client-signature* *my-client-signature*
(let ((sig (server:mk-signature)))
- (set! *my-client-signature* sig)
- *my-client-signature*)))
+ (set! *my-client-signature* sig)
+ *my-client-signature*)))
;; kind start up of servers, wait 40 seconds before allowing another server for a given
;; run-id to be launched
(define (server:kind-run areapath)
(let ((last-run-time (hash-table-ref/default *server-kind-run* areapath #f)))
@@ -156,96 +181,168 @@
(> (- (current-seconds) last-run-time) 30))
(begin
(server:run areapath)
(hash-table-set! *server-kind-run* areapath (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:try-running server:run) ;; there is no more per-run servers ;; REMOVE ME. BUG.
+(define (server:attempting-start areapath)
+ (with-output-to-file
+ (conc areapath "/.starting-server")
+ (lambda ()
+ (print (current-process-id) " on " (get-host-name)))))
+
+(define (server:complete-attempt areapath)
+ (delete-file* (conc areapath "/.starting-server")))
+
(define (server:start-attempted? areapath)
(let ((flagfile (conc areapath "/.starting-server")))
(handle-exceptions
exn
#f ;; if things go wrong pretend we can't see the file
- (and (file-exists? flagfile)
- (< (- (current-seconds)
- (file-modification-time flagfile))
- 15))))) ;; exists and less than 15 seconds old
-
+ (cond
+ ((and (file-exists? flagfile)
+ (< (- (current-seconds)
+ (file-modification-time flagfile))
+ 15)) ;; exists and less than 15 seconds old
+ (with-input-from-file flagfile (lambda () (read-line))))
+ ((file-exists? flagfile) ;; it is stale.
+ (server:complete-attempt areapath)
+ #f)
+ (else #f)))))
+
(define (server:read-dotserver areapath)
(let ((dotfile (conc areapath "/.server")))
(handle-exceptions
exn
#f ;; if things go wrong pretend we can't see the file
- (if (and (file-exists? dotfile)
- (file-read-access? dotfile))
- (with-input-from-file
- dotfile
- (lambda ()
- (read-line)))
- #f))))
+ (cond
+ ((not (file-exists? dotfile))
+ #f)
+ ((not (file-read-access? dotfile))
+ #f)
+ ((> (server:dotserver-age-seconds areapath) (+ 5 (server:get-timeout)))
+ (server:remove-dotserver-file areapath ".*")
+ #f)
+ (else
+ (let* ((line
+ (with-input-from-file
+ dotfile
+ (lambda ()
+ (read-line))))
+ (tokens (if (string? line) (string-split line ":") #f)))
+ (cond
+ ((eq? 4 (length tokens))
+ tokens)
+ (else #f))))))))
+
+(define (server:read-dotserver->url areapath)
+ (let ((dotserver-tokens (server:read-dotserver areapath)))
+ (if dotserver-tokens
+ (conc (list-ref dotserver-tokens 0) ":" (list-ref dotserver-tokens 1))
+ #f)))
;; write a .server file in *toppath* with hostport
;; return #t on success, #f otherwise
;;
-(define (server:write-dotserver areapath hostport)
+(define (server:write-dotserver areapath host port pid transport)
(let ((lock-file (conc areapath "/.server.lock"))
(server-file (conc areapath "/.server")))
(if (common:simple-file-lock lock-file)
(let ((res (handle-exceptions
exn
#f ;; failed for some reason, for the moment simply return #f
(with-output-to-file server-file
(lambda ()
- (print hostport)))
+ (print (conc host ":" port ":" pid ":" transport))))
#t)))
- (debug:print-info 0 *default-log-port* "server file " server-file " for " hostport " created")
+ (debug:print-info 0 *default-log-port* "server file " server-file " for " host ":" port " created pid="pid)
(common:simple-file-release-lock lock-file)
res)
#f)))
+
+;; this will check that the .server file present matches the server calling this procedure.
+;; if parameters match (this-pid and transport) the file will be touched and #t returned
+;; otherwise #f will be returned.
+(define (server:confirm-dotserver areapath this-iface this-port this-pid this-transport)
+ (let* ((tokens (server:read-dotserver areapath)))
+ (cond
+ ((not tokens)
+ (debug:print-info 0 *default-log-port* "INFO: .server file does not exist.")
+ #f)
+ ((not (eq? 4 (length tokens)))
+ (debug:print-info 0 *default-log-port* "INFO: .server file is corrupt. There are not 4 tokens as expeted; there are "(length tokens)".")
+ #f)
+ ((not (equal? this-iface (list-ref tokens 0)))
+ (debug:print-info 0 *default-log-port* "INFO: .server file mismatch. for iface, server has value >"(list-ref tokens 0)"< but this server's value is >"this-iface"<")
+ #f)
+ ((not (equal? (->string this-port) (list-ref tokens 1)))
+ (debug:print-info 0 *default-log-port* "INFO: .server file mismatch. for port, .server has value >"(list-ref tokens 1)"< but this server's value is >"(->string this-port)"<")
+ #f)
+ ((not (equal? (->string this-pid) (list-ref tokens 2)))
+ (debug:print-info 0 *default-log-port* "INFO: .server file mismatch. for pid, .server has value >"(list-ref tokens 2)"< but this server's value is >"(->string this-pid)"<")
+ #f)
+ ((not (equal? (->string this-transport) (->string (list-ref tokens 3))))
+ (debug:print-info 0 *default-log-port* "INFO: .server file mismatch. for transport, .server has value >"(list-ref tokens 3)"< but this server's value is >"this-transport"<")
+ #f)
+ (else (server:touch-dotserver areapath)
+ #t))))
+
+(define (server:touch-dotserver areapath)
+ (let ((server-file (conc areapath "/.server")))
+ (change-file-times server-file (current-seconds) (current-seconds))))
+
+(define (server:dotserver-age-seconds areapath)
+ (let ((server-file (conc areapath "/.server")))
+ (begin
+ (handle-exceptions
+ exn
+ #f
+ (- (current-seconds)
+ (file-modification-time server-file))))))
+
(define (server:remove-dotserver-file areapath hostport)
- (let ((dotserver (server:read-dotserver areapath))
+ (let ((dotserver-url (server:read-dotserver->url areapath))
(server-file (conc areapath "/.server"))
(lock-file (conc areapath "/.server.lock")))
- (if (and dotserver (string-match (conc ".*:" hostport "$") dotserver)) ;; port matches, good enough info to decide to remove the file
+ (if (and dotserver-url (string-match (conc ".*:" hostport "$") dotserver-url)) ;; port matches, good enough info to decide to remove the file
(if (common:simple-file-lock lock-file)
(begin
(handle-exceptions
exn
#f
(delete-file* server-file))
(debug:print-info 0 *default-log-port* "server file " server-file " for " hostport " removed")
- (common:simple-file-release-lock lock-file))))))
+ (common:simple-file-release-lock lock-file))
+ (debug:print-info 0 *default-log-port* "server file " server-file " for " hostport " NOT removed - could not get lock."))
+ (debug:print-info 0 *default-log-port* "server file " server-file " for " hostport " NOT removed - dotserver-url("dotserver-url") did not match hostport pattern ("hostport")"))))
;; no longer care if multiple servers are started by accident. older servers will drop off in time.
;;
(define (server:check-if-running areapath)
- (let* ((dotserver (server:read-dotserver areapath))) ;; tdbdat (tasks:open-db)))
- (if dotserver
+ (let* ((dotserver-url (server:read-dotserver->url areapath))) ;; tdbdat (tasks:open-db)))
+ (if dotserver-url
(let* ((res (case *transport-type*
- ((http)(server:ping-server dotserver))
+ ((http)(server:ping-server dotserver-url))
;; ((nmsg)(nmsg-transport:ping (tasks:hostinfo-get-interface server)
)))
(if res
- dotserver
- #f))
+ dotserver-url
+ (begin
+ (server:remove-dotserver-file areapath ".*") ;; remove stale dotserver
+ #f)))
#f)))
;; called in megatest.scm, host-port is string hostname:port
;;
;; NOTE: This is NOT called directly from clients as not all transports support a client running
;; in the same process as the server.
;;
(define (server:ping host-port-in #!key (do-exit #f))
(let ((host:port (if (not host-port-in) ;; use read-dotserver to find
- (server:read-dotserver *toppath*)
+ (server:read-dotserver->url *toppath*)
(if (number? host-port-in) ;; we were handed a server-id
(let ((srec (tasks:get-server-by-id (db:delay-if-busy (tasks:open-db)) host-port-in)))
;; (print "srec: " srec " host-port-in: " host-port-in)
(if srec
(conc (vector-ref srec 3) ":" (vector-ref srec 4))
Index: tasks.scm
==================================================================
--- tasks.scm
+++ tasks.scm
@@ -323,12 +323,12 @@
(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','dbprep') ORDER BY start_time DESC;")
- run-id)
+ (conc "SELECT " selstr " FROM servers WHERE state in ('available','running','dbprep') ORDER BY start_time DESC;")
+ )
(vector header res)))
(define (tasks:get-server mdb run-id #!key (retries 10))
(let ((res #f)
(best #f))
@@ -402,11 +402,11 @@
(< delay-time delay-max-tries))
(begin
(if (common:low-noise-print 60 "tasks:start-and-wait-for-server" run-id)
(debug:print 0 *default-log-port* "Try starting server for run-id " run-id))
(thread-sleep! (/ (random 2000) 1000))
- (server:kind-run run-id)
+ (server:kind-run *toppath*)
(thread-sleep! (min delay-time 1))
(if (not (or (server:start-attempted? *toppath*)
(server:read-dotserver *toppath*))) ;; no point in trying
(loop (tasks:get-server (db:delay-if-busy tdbdat) run-id)(+ delay-time 1))
#f))
@@ -448,14 +448,16 @@
(reverse res)))
;; no elegance here ...
;;
(define (tasks:kill-server hostname pid #!key (kill-switch ""))
+ (server:remove-dotserver-file *toppath* ".*")
(debug:print-info 0 *default-log-port* "Attempting to kill server process " pid " on host " hostname)
(setenv "TARGETHOST" hostname)
(setenv "TARGETHOST_LOGF" "server-kills.log")
(system (conc "nbfake kill "kill-switch" "pid))
+
(unsetenv "TARGETHOST_LOGF")
(unsetenv "TARGETHOST"))
;; look up a server by run-id and send it a kill, also delete the record for that server
;;
@@ -466,10 +468,11 @@
(let ((hostname (vector-ref sdat 6))
(pid (vector-ref sdat 5))
(server-id (vector-ref sdat 0)))
(tasks:server-set-state! (db:delay-if-busy tdbdat) server-id "killed")
(debug:print-info 0 *default-log-port* "Killing server " server-id " for run-id " run-id " on host " hostname " with pid " pid)
+ (server:remove-dotserver-file *toppath* ".*")
(tasks:kill-server hostname pid)
(tasks:server-delete-record (db:delay-if-busy tdbdat) server-id tag) )
(debug:print-info 0 *default-log-port* "No server found for run-id " run-id ", nothing to kill"))
;; (sqlite3:finalize! tdb)
))
@@ -780,11 +783,11 @@
(define (tasks:find-task-queue-records dbstruct target run-name test-patt state-patt action-patt)
;; (handle-exceptions
;; exn
;; '()
;; (sqlite3:first-row
- (let ((db (db:delay-if-busy (db:get-db dbstruct #f)))
+ (let ((db (db:delay-if-busy (db:get-db dbstruct)))
(res '()))
(sqlite3:for-each-row
(lambda (a . b)
(set! res (cons (cons a b) res)))
db "SELECT id,action,owner,state,target,name,testpatt,keylock,params FROM tasks_queue
Index: tests.scm
==================================================================
--- tests.scm
+++ tests.scm
@@ -141,11 +141,11 @@
;; returns waitons waitors tconfigdat
;;
(define (tests:get-waitons test-name all-tests-registry)
- (let* ((config (tests:get-testconfig test-name all-tests-registry 'return-procs)))
+ (let* ((config (tests:get-testconfig test-name #f all-tests-registry 'return-procs)))
(let ((instr (if config
(config-lookup config "requirements" "waiton")
(begin ;; No config means this is a non-existant test
(debug:print-error 0 *default-log-port* "non-existent required test \"" test-name "\"")
(exit 1))))
@@ -291,11 +291,11 @@
;; 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))
+ (testconfig (tests:get-testconfig (db:test-get-testname testdat) (db:test-get-item-path testdat) test-registry #f))
(test-rundir ;; (sdb:qry 'passstr
(db:test-get-rundir testdat)) ;; )
(prev-rundir ;; (sdb:qry 'passstr
(db:test-get-rundir prev-testdat)) ;; )
(waivers (if testconfig (configf:section-vars testconfig "waivers") '()))
@@ -351,15 +351,10 @@
(loop (car tal)(cdr tal)))
#f))))))
(pop-directory)
result)))))
-(define (tests:test-force-state-status! run-id test-id state status)
- (rmt:test-set-status-state run-id test-id status state #f)
- ;; (rmt:roll-up-pass-fail-counts run-id test-name item
- (mt:process-triggers run-id test-id state status))
-
;; Do not rpc this one, do the underlying calls!!!
(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 (rmt:get-test-info-by-id run-id test-id))
@@ -396,12 +391,12 @@
(debug:print 4 *default-log-port* "real-status " real-status ", waived " waived ", status " status)
;; update the primary record IF state AND status are defined
(if (and state status)
(begin
- (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) ;; triggers are called in test-set-status-state
+ (rmt:set-state-status-and-roll-up-items run-id test-id item-path state real-status (if waived waived comment))
+ ;; (mt:process-triggers run-id test-id state real-status) ;; triggers are called in test-set-state-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"))
@@ -442,12 +437,12 @@
;; 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 ""))
- (rmt:roll-up-pass-fail-counts run-id test-name item-path state status #f))
+ ;;;;;; (if (not (equal? item-path ""))
+ ;;;;;; (rmt:set-state-status-and-roll-up-items run-id test-name item-path state status #f) ;;;;;)
(if (or (and (string? comment)
(string-match (regexp "\\S+") comment))
waived)
(let ((cmt (if waived waived comment)))
@@ -481,12 +476,11 @@
(lockf (conc outputfilename ".lock")))
(let loop ((have-lock (common:simple-file-lock lockf)))
(if have-lock
(let ((script (configf:lookup *configdat* "testrollup" test-name)))
(print "Obtained lock for " outputfilename)
- (rmt:roll-up-pass-fail-counts run-id test-name "" #f #f #f)
- ;; (rmt:test-set-status-state run-id test-name #f #f #f) ;; (rmt:top-test-set-per-pf-counts run-id test-name)
+ (rmt:set-state-status-and-roll-up-items run-id test-name "" #f #f #f)
(if script
(system (conc script " > " outputfilename " & "))
(tests:generate-html-summary-for-iterated-test run-id test-id test-name outputfilename))
(common:simple-file-release-lock lockf)
(change-directory orig-dir)
@@ -979,11 +973,11 @@
;; if .testconfig exists in test directory read and return it
;; else if have cached copy in *testconfigs* return it IFF there is a section "have fulldata"
;; else read the testconfig file
;; if have path to test directory save the config as .testconfig and return it
;;
-(define (tests:get-testconfig test-name test-registry system-allowed #!key (force-create #f))
+(define (tests:get-testconfig test-name item-path test-registry system-allowed #!key (force-create #f))
(let* ((cache-path (tests:get-test-path-from-environment))
(cache-file (and cache-path (conc cache-path "/.testconfig")))
(cache-exists (and cache-file
(not force-create) ;; if force-create then pretend there is no cache to read
(file-exists? cache-file)))
@@ -991,14 +985,17 @@
cache-exists)
(handle-exceptions
exn
#f ;; any issues, just give up with the cached version and re-read
(configf:read-alist cache-file))
- #f)))
+ #f))
+ (test-full-name (if (and item-path (not (string-null? item-path)))
+ (conc test-name "/" item-path)
+ test-name)))
(if cached-dat
cached-dat
- (let ((dat (hash-table-ref/default *testconfigs* test-name #f)))
+ (let ((dat (hash-table-ref/default *testconfigs* test-full-name #f)))
(if (and dat ;; have a locally cached version
(hash-table-ref/default dat "have fulldata" #f)) ;; marked as good data?
dat
;; no cached data available
(let* ((treg (or test-registry
@@ -1012,11 +1009,11 @@
environ-patt: (if system-allowed
"pre-launch-env-vars"
#f))
#f)))
(if (and tcfg cache-file) (hash-table-set! tcfg "have fulldata" #t)) ;; mark this as fully read data
- (if tcfg (hash-table-set! *testconfigs* test-name tcfg))
+ (if tcfg (hash-table-set! *testconfigs* test-full-name tcfg))
(if (and testexists
cache-file
(file-write-access? cache-path))
(let ((tpath (conc cache-path "/.testconfig")))
(debug:print-info 1 *default-log-port* "Caching testconfig for " test-name " in " tpath)
@@ -1240,11 +1237,12 @@
(define (tests:get-full-data test-names test-records required-tests all-tests-registry)
(if (not (null? test-names))
(let loop ((hed (car test-names))
(tal (cdr test-names))) ;; 'return-procs tells the config reader to prep running system but return a proc
(debug:print-info 4 *default-log-port* "hed=" hed " at top of loop")
- (let* ((config (tests:get-testconfig hed all-tests-registry 'return-procs))
+ ;; don't know item-path at this time, let the testconfig get the top level testconfig
+ (let* ((config (tests:get-testconfig hed #f all-tests-registry 'return-procs))
(waitons (let ((instr (if config
(config-lookup config "requirements" "waiton")
(begin ;; No config means this is a non-existant test
(debug:print-error 0 *default-log-port* "non-existent required test \"" hed "\", grep through your testconfigs to find and remove or create the test. Discarding and continuing.")
""))))
Index: tests/fdktestqa/testqa/Makefile
==================================================================
--- tests/fdktestqa/testqa/Makefile
+++ tests/fdktestqa/testqa/Makefile
@@ -5,16 +5,16 @@
NEWDASHBOARD = $(BINDIR)/newdashboard
RUNNAME = a
NUMTESTS = 20
all :
- $(MEGATEST) -remove-runs -target a/b :runname c -testpatt %/%
- $(MEGATEST) -runtests % -target a/b :runname c
+ $(MEGATEST) -remove-runs -target a/b -runname c -testpatt %/%
+ $(MEGATEST) -run -testpatt % -target a/b -runname c
bigbig :
for tn in a b c d;do \
- ($(MEGATEST) -runtests % -target a/b :runname $tn & ) ; \
+ ($(MEGATEST) -run -testpatt % -target a/b -runname $tn & ) ; \
done
waitonpatt :
megatest -remove-runs -runname waitonpatt -target a/b -testpatt %
NUMTESTS=15 megatest -run -target a/b -runname waitonpatt -testpatt bigrun3/%8
@@ -22,17 +22,17 @@
waitonall :
megatest -remove-runs -runname waitonall -target a/b -testpatt %
NUMTESTS=20 megatest -run -target a/b -runname waitonall -testpatt alltop
bigrun :
- NUMTESTS=$(NUMTESTS) $(MEGATEST) -runtests bigrun -target a/bigrun :runname a$(shell date +%V)
+ NUMTESTS=$(NUMTESTS) $(MEGATEST) -run -testpatt bigrun -target a/bigrun -runname a$(shell date +%V)
bigrun2 :
- NUMTESTS=$(NUMTESTS) $(MEGATEST) -runtests bigrun2 -target a/bigrun2 :runname a$(shell date +%V)
+ NUMTESTS=$(NUMTESTS) $(MEGATEST) -run -testpatt bigrun2 -target a/bigrun2 -runname a$(shell date +%V)
bigrun3 :
- NUMTESTS=$(NUMTESTS) $(MEGATEST) -runtests bigrun3 -target a/bigrun3 :runname $(RUNNAME)
+ NUMTESTS=$(NUMTESTS) $(MEGATEST) -run -testpatt bigrun3 -target a/bigrun3 -runname $(RUNNAME)
dashboard :
mkdir -p ../simpleruns
$(DASHBOARD) -rows 20 &
@@ -41,6 +41,6 @@
compile :
(cd ../../..;make -j && make install)
clean :
- rm -rf ../simple*/*/* megatest.db db/* ../simple*/.db/* logs/* monitor.db
+ rm -rf ../simple*/*/* megatest.db db/* ../simple*/.db/* logs/* monitor.db /tmp/$(USER)/megatest_localdb/testqa .server
ADDED tests/fdktestqa/testqa/local.config.example
Index: tests/fdktestqa/testqa/local.config.example
==================================================================
--- /dev/null
+++ tests/fdktestqa/testqa/local.config.example
@@ -0,0 +1,15 @@
+[host-types]
+general #MTLOWESTLOAD xena zeus
+
+[jobtools]
+launcher nbfake
+maxload 1.5
+flexi-launcher yes
+# useshell no
+
+[setup]
+launch-delay 1
+launchwait no
+
+[launchers]
+% general
Index: tests/fdktestqa/testqa/megatest.config
==================================================================
--- tests/fdktestqa/testqa/megatest.config
+++ tests/fdktestqa/testqa/megatest.config
@@ -1,11 +1,13 @@
[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
# launchwait no
+launch-delay 0
# All these are overridden in ../fdk.config
# [jobtools]
# launcher nbfake
# launcher bsub -q priority -o $MT_TEST_RUN_DIR/openlava.log
[include ../fdk.config]
+[include local.config]
Index: tests/fullrun/tests/all_toplevel/testconfig
==================================================================
--- tests/fullrun/tests/all_toplevel/testconfig
+++ tests/fullrun/tests/all_toplevel/testconfig
@@ -1,8 +1,8 @@
[ezsteps]
calcresults megatest -list-runs $MT_RUNNAME -target $MT_TARGET
-check_triggers cat $MT_RUN_AREA_HOME/triggers_$MT_RUN_NAME.dat
+check_triggers cat $MT_RUN_AREA_HOME/triggers_$MT_RUNNAME.dat
[logpro]
check_triggers ;;
(expect:error in "LogFileBody" = 0 "No errors" #/error/i)
ADDED thunk-utils.scm
Index: thunk-utils.scm
==================================================================
--- /dev/null
+++ thunk-utils.scm
@@ -0,0 +1,121 @@
+(use srfi-18)
+
+
+;; wrap a proc with a mutex so that two threads may not call proc simultaneously.
+;; will catch exceptions to ensure mutex is unlocked even if exception is thrown.
+;; will generate a unique mutex for proc unless one is specified with canned-mutex: option
+;;
+;; example 1: (define thread-safe-+ (make-synchronized-proc +))
+;; example 2: (define thread-safe-plus
+;; (make-synchronized-proc
+;; (lambda (x y)
+;; (+ x y))))
+
+(define (make-synchronized-proc proc
+ #!key (canned-mutex #f))
+ (let* ((guard-mutex (if canned-mutex canned-mutex (make-mutex)))
+ (guarded-proc ;; we are guarding the thunk against exceptions. We will record whether result of evaluation is an exception or a regular result.
+ (lambda args
+ (mutex-lock! guard-mutex)
+ (let* ((EXCEPTION (gensym)) ;; using gensym to avoid potential collision with a proc that returns a pair having the first element be our flag. gensym guarantees the symbol is unique.
+ (res
+ (condition-case
+ (apply proc args) ;; this is what we are guarding the execution of
+ [x () (cons EXCEPTION x)]
+ )))
+ (mutex-unlock! guard-mutex)
+ (cond
+ ((and (pair? res) (eq? (car res) EXCEPTION))
+ (raise (cdr res)))
+ (else
+ res))))))
+ guarded-proc))
+
+
+;; retry an operation (depends on srfi-18)
+;; ==================
+;; idea here is to avoid spending time on coding retrying something. Trying to be generic here.
+;;
+;; Exception handling:
+;; -------------------
+;; if evaluating the thunk results in exception, it will be retried.
+;; on last try, if final-failure-returns-actual is true, the exception will be re-thrown to caller.
+;;
+;; look at options below #!key to see how to configure behavior
+;;
+;;
+
+(define (retry-thunk
+ the-thunk
+ #!key ;;;; options below
+ (accept-result? (lambda (x) x)) ;; retry if predicate applied to thunk's result is false
+ (retries 4) ;; how many tries
+ (failure-value #f) ;; return this on final failure, unless following option is enabled:
+ (final-failure-returns-actual #f) ;; on failure, on the last try, just return the result, not failure-value
+
+ (retry-delay 0.1) ;; delay between tries
+ (back-off-factor 1) ;; multiply retry-delay by this factor on retry
+ (random-delay 0.1) ;; add a random portion of this value to wait
+
+ (chatty #f) ;; print status as we go, for debugging.
+ )
+
+ (when chatty (print) (print "Entered retry-thunk") (print "-=-=-=-=-=-"))
+ (let* ((guarded-thunk ;; we are guarding the thunk against exceptions. We will record whether result of evaluation is an exception or a regular result.
+ (lambda ()
+ (let* ((EXCEPTION (gensym)) ;; using gensym to avoid potential collision
+ (res
+ (condition-case
+ (the-thunk) ;; this is what we are guarding the execution of
+ [x () (cons EXCEPTION x)]
+ )))
+ (cond
+ ((and (pair? res) (eq? (car res) EXCEPTION))
+ (if chatty
+ (print " - the-thunk threw exception >"(cdr res)"<"))
+ (cons 'exception (cdr res)))
+ (else
+ (if chatty
+ (print " - the-thunk returned result >"res"<"))
+ (cons 'regular-result res)))))))
+
+ (let loop ((guarded-res (guarded-thunk))
+ (retries-left retries)
+ (fail-wait retry-delay))
+ (if chatty (print " =========="))
+ (let* ((wait-time (+ fail-wait (+ (* fail-wait back-off-factor)
+ (* random-delay
+ (/ (random 1024) 1024) ))))
+ (res-type (car guarded-res))
+ (res-value (cdr guarded-res)))
+ (cond
+ ((and (eq? res-type 'regular-result) (accept-result? res-value))
+ (if chatty (print " + return result that satisfied accept-result? >"res-value"<"))
+ res-value)
+
+ ((> retries-left 0)
+ (if chatty (print " - sleep "wait-time))
+ (thread-sleep! wait-time)
+ (if chatty (print " + retry ["retries-left" tries left]"))
+ (loop (guarded-thunk)
+ (sub1 retries-left)
+ wait-time))
+
+ ((eq? res-type 'regular-result)
+ (if final-failure-returns-actual
+ (begin
+ (if chatty (print " + last try failed- return the result >"res-value"<"))
+ res-value)
+ (begin
+ (if chatty (print " + last try failed- return canned failure value >"failure-value"<"))
+ failure-value)))
+
+ (else ;; no retries left; result was not accepted and res-type can only be 'exception
+ (if final-failure-returns-actual
+ (begin
+ (if chatty (print " + last try failed with exception- re-throw it >"res-value"<"))
+ (abort res-value)); re-raise the exception. TODO: find a way for call-history to show as though from entry to this function
+ (begin
+ (if chatty (print " + last try failed with exception- return canned failure value >"failure-value"<"))
+ failure-value))))))))
+
ADDED utils/homehost_check.sh
Index: utils/homehost_check.sh
==================================================================
--- /dev/null
+++ utils/homehost_check.sh
@@ -0,0 +1,17 @@
+#!/bin/sh
+
+#exits 1 when current host is not homehost.
+
+if [[ ! -e .homehost ]]; then
+ exit 0
+fi
+
+homehostname=$( host `cat .homehost` | awk '{print $NF}' | sed 's/\.$//' )
+hostname=$( hostname -f )
+
+if [[ $homehostname == $hostname ]]; then
+ exit 0
+fi
+echo "ERROR: this host ($homehostname) is not the megatest homehost ($hostname)"
+exit 1
+
Index: utils/nbfake
==================================================================
--- utils/nbfake
+++ utils/nbfake
@@ -70,7 +70,7 @@
if [[ -z "$MY_NBFAKE_HOST" ]]; then
# Run locally
sh -c "cd $CURRWD;export DISPLAY=$DISPLAY; export PATH=$PATH; nohup $* >> $MY_NBFAKE_LOG 2>&1 &"
else
# run remotely
- ssh -n -f $MY_NBFAKE_HOST "sh -c \"cd $CURRWD;export DISPLAY=$DISPLAY; export PATH=$PATH; nohup $* >> $MY_NBFAKE_LOG 2>&1 &\""
+ ssh -X -n -f $MY_NBFAKE_HOST "sh -c \"cd $CURRWD;export DISPLAY=$DISPLAY; export PATH=$PATH; nohup $* >> $MY_NBFAKE_LOG 2>&1 &\""
fi
Index: utils/plot-code.scm
==================================================================
--- utils/plot-code.scm
+++ utils/plot-code.scm
@@ -8,17 +8,19 @@
;; third param is list of files to scan
(use regex srfi-69 srfi-13)
(define targs #f)
-(define files (cddddr (argv)))
+(define files (cdr (cddddr (argv))))
(let ((targdat (cadddr (argv))))
(if (equal? targdat "-")
(set! targs files)
(set! targs (string-split targdat ","))))
+(define function-patt (car (cdr (cdddr (argv)))))
+(define function-rx (regexp function-patt))
(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))
@@ -32,10 +34,11 @@
(lambda ()
(apply print data))))
(print-err "Making graph for files: " (string-intersperse targs ", "))
(print-err "Looking at files: " (string-intersperse files ", "))
+(print-err "Function regex: " function-patt)
;; Gather the functions
;;
(for-each
(lambda (fname)
@@ -46,16 +49,18 @@
(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 '())))
- ))
+ (if (string-match function-rx fnname)
+ (begin
+ (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")