Index: Makefile
==================================================================
--- Makefile
+++ Makefile
@@ -20,21 +20,22 @@
SHELL=/bin/bash
PREFIX=$(PWD)
CSCOPTS=
INSTALL=install
SRCFILES = common.scm items.scm launch.scm runconfig.scm \
- server.scm configf.scm db.scm margs.scm \
- process.scm runs.scm tasks.scm tests.scm genexample.scm \
+ server.scm configf.scm db.scm \
+ process.scm runs.scm tests.scm genexample.scm \
http-transport.scm filedb.scm tdb.scm client.scm mt.scm \
ezsteps.scm lock-queue.scm sdb.scm rmt.scm api.scm \
subrun.scm archive.scm env.scm \
- diff-report.scm cgisetup/models/pgdb.scm
+ diff-report.scm
# module source files
-MSRCFILES = dbmod.scm servermod.scm apimod.scm commonmod.scm rmtmod.scm ods.scm configfmod.scm transport.scm portlogger.scm
+MSRCFILES = dbmod.scm servermod.scm apimod.scm commonmod.scm rmtmod.scm ods.scm configfmod.scm transport.scm portlogger.scm tasks.scm pgdb.scm margsmod.scm
MOFILES = $(addprefix mofiles/,$(MSRCFILES:%.scm=%.o))
MOIMPFILES = $(MSRCFILES:%.scm=%.import.o)
+
# ftail.scm rmtmod.scm commonmod.scm removed
# MSRCFILES = ducttape-lib.scm pkts.scm stml2.scm cookie.scm mutils.scm \
# mtargs.scm commonmod.scm dbmod.scm adjutant.scm ulex.scm \
# rmtmod.scm apimod.scm
@@ -112,18 +113,16 @@
env.o \
http-transport.o \
items.o \
launch.o \
lock-queue.o \
- margs.o \
mt.o \
process.o \
rmt.o \
runconfig.o \
runs.o \
server.o \
- tasks.o \
tdb.o \
tests.o \
subrun.o \
ezsteps.o
@@ -189,11 +188,11 @@
# # commonmod.o dashboard.o megatest.o tcmt.o apimod.o : megatest-fossil-hash.scm
#
# tests.o db.o launch.o runs.o dashboard-tests.o \
# # commonmod.o dashboard.o megatest.o tcmt.o apimod.o : megatest-fossil-hash.scm
#
-# tests.o db.o launch.o runs.o dashboard-tests.o \
+# tests.o db.o launch.o runs.o dashboard-tests.o
dashboard-context-menu.o dashboard-guimonitor.o dashboard-main.o \
monitor.o dashboard.o archive.o megatest.o : db_records.scm megatest-fossil-hash.scm
# dashboard.o : mofiles/apimod.o
@@ -200,11 +199,11 @@
tests.o runs.o dashboard.o dashboard-tests.o dashboard-context-menu.o dashboard-main.o : run_records.scm
db.o ezsteps.o launch.o megatest.o monitor.o runs-for-ref.o runs.o tests.o : key_records.scm
-tests.o tasks.o dashboard-tasks.o : task_records.scm
+tests.o mofiles/tasks.o dashboard-tasks.o : task_records.scm
runs.o : test_records.scm
# api.o rmt.o db.o : mofiles/apimod.o mofiles/dbmod.o mofiles/rmtmod.o mofiles/ods.o
mofiles/commonmod.o common.o megatest.o dashboard.o : megatest-fossil-hash.scm megatest-version.scm
@@ -461,18 +460,18 @@
xterm : sd
(export BASEPATH=/tmp/$(USER)/basepath ; export PATH="$(PWD)/datashare-testing:$(PATH)" ; xterm &)
datashare-testing/spublish : spublish.scm $(OFILES) megatest-version.scm
- csc $(CSCOPTS) spublish.scm margs.o process.o common.o -o datashare-testing/spublish
+ csc $(CSCOPTS) spublish.scm mofiles/margsmod.o process.o common.o -o datashare-testing/spublish
datashare-testing/sretrieve : sretrieve.scm $(OFILES) megatest-version.scm
- csc $(CSCOPTS) sretrieve.scm margs.o process.o common.o -o datashare-testing/sretrieve
+ csc $(CSCOPTS) sretrieve.scm mofiles/margsmod.o process.o common.o -o datashare-testing/sretrieve
datashare-testing/sauthorize : sauthorize.scm $(OFILES) megatest-version.scm
- csc $(CSCOPTS) sauthorize.scm margs.o process.o common.o -o datashare-testing/sauthorize
+ csc $(CSCOPTS) sauthorize.scm mofiles/margsmod.o process.o common.o -o datashare-testing/sauthorize
sauth-init:
mkdir -p datashare-testing
rm datashare-testing/sauthorize
rm datashare-testing/sretrieve
@@ -495,16 +494,18 @@
fi
if csi -ne '(use postgresql)';then \
echo "(use postgresql)(hash-table-set! *available-db* 'postgresql #t)" >> altdb.scm;\
fi
-portlogger-example : portlogger-example.scm api.o archive.o client.o common.o configf.o dashboard-tests.o dashboard-context-menu.o db.o dcommon.o ezsteps.o filedb.o genexample.o gutils.o http-transport.o items.o launch.o lock-queue.o margs.o mt.o mofiles/portlogger.o process.o rmt.o runconfig.o runs.o sdb.o server.o synchash.o tasks.o tdb.o tests.o tree.o
- csc $(CSCOPTS) portlogger-example.scm api.o archive.o client.o common.o configf.o dashboard-tests.o dashboard-context-menu.o db.o dcommon.o ezsteps.o filedb.o genexample.o gutils.o http-transport.o items.o launch.o lock-queue.o margs.o mt.o mofiles/portlogger.o process.o rmt.o runconfig.o runs.o sdb.o server.o synchash.o tasks.o tdb.o tests.o tree.o
+portlogger-example : portlogger-example.scm api.o archive.o client.o common.o configf.o dashboard-tests.o dashboard-context-menu.o db.o dcommon.o ezsteps.o filedb.o genexample.o gutils.o http-transport.o items.o launch.o lock-queue.o mofiles/margsmod.o mt.o mofiles/portlogger.o process.o rmt.o runconfig.o runs.o sdb.o server.o synchash.o mofiles/tasks.o tdb.o tests.o tree.o
+ csc $(CSCOPTS) portlogger-example.scm api.o archive.o client.o common.o configf.o dashboard-tests.o dashboard-context-menu.o db.o dcommon.o ezsteps.o filedb.o genexample.o gutils.o http-transport.o items.o launch.o lock-queue.o mofiles/margsmod.o mt.o mofiles/portlogger.o process.o rmt.o runconfig.o runs.o sdb.o server.o synchash.o mofiles/tasks.o tdb.o tests.o tree.o
+
+%.pdf : %.dot
+ dot -Tpdf $*.dot -o $*.pdf
-# create a pdf dot graphviz diagram from notations in rmt.scm
-rmt.pdf : rmt.scm
- grep ';;DOT' rmt.scm | sed -e 's/.*;;DOT //' > rmt.dot;dot -Tpdf rmt.dot -o rmt.pdf
+all.dot all-inc.dot : *.scm
+ gendeps all *.scm
buildmanual:
cd docs/manual && make
wikipage=plan
Index: api.scm
==================================================================
--- api.scm
+++ api.scm
@@ -20,293 +20,6 @@
;;
;;======================================================================
(use srfi-69 posix)
-(declare (unit api))
-(declare (uses rmt))
-(declare (uses db))
-(declare (uses tasks))
-
-(declare (uses commonmod))
-(import commonmod)
-
-(declare (uses apimod))
-(import apimod)
-
-(declare (uses dbmod))
-(import dbmod)
-
-;; These are called by the server on recipt of /api calls
-;; - keep it simple, only return the actual result of the call, i.e. no meta info here
-;;
-;; - returns #( flag result )
-;;
-(define (api:execute-requests dbstruct dat)
- (handle-exceptions
- exn
- (let ((call-chain (get-call-chain)))
- (debug:print 0 *default-log-port* "WARNING: api:execute-requests received an exception from peer, dat=" dat ", exn=" exn)
- (print-call-chain (current-error-port))
- (debug:print 0 *default-log-port* " message: " ((condition-property-accessor 'exn 'message) exn))
- (vector #f (vector exn call-chain dat))) ;; return some stuff for debug if an exception happens
- (cond
- ((not (vector? dat)) ;; it is an error to not receive a vector
- (vector #f (vector #f "remote must be called with a vector")))
- ((> *api-process-request-count* 20) ;; 20)
- (debug:print 0 *default-log-port* "WARNING: api:execute-requests received an overloaded message.")
- (set! *server-overloaded* #t)
- (vector #f (vector #f 'overloaded))) ;; the inner vector is what gets returned. nope, don't know why. please refactor!
- (else
- (let* ((cmd-in (vector-ref dat 0))
- (cmd (if (symbol? cmd-in)
- cmd-in
- (string->symbol cmd-in)))
- (params (vector-ref dat 1))
- (start-t (current-milliseconds))
- (readonly-mode (dbr:dbstruct-read-only dbstruct))
- (readonly-command (member cmd api:read-only-queries))
- (writecmd-in-readonly-mode (and readonly-mode (not readonly-command)))
- #;(foo (begin
- (common:telemetry-log (conc "api-in:"(->string cmd))
- payload: `((params . ,params)))
-
- #t))
- (res
- (if writecmd-in-readonly-mode
- (conc "attempt to run write command "cmd" on a read-only database")
- (case cmd
- ;;===============================================
- ;; READ/WRITE QUERIES
- ;;===============================================
-
- ((get-keys-write) (db:get-keys dbstruct)) ;; force a dummy "write" query to force server; for debug in -repl
-
- ;; SERVERS
- ((start-server) (apply server:kind-run params))
- ((kill-server) (set! *server-run* #f))
-
- ;; TESTS
-
- ;;((test-set-state-status-by-id) (apply mt:test-set-state-status-by-id dbstruct params))
- ;;BB - commented out above because it was calling below, eventually, incorrectly (dbstruct passed to mt:test-set-state-status-by-id, which previosly did more, but now only passes thru to db:set-state-status-and-roll-up-items.
- ((test-set-state-status-by-id)
-
- ;; (define (db:set-state-status-and-roll-up-items dbstruct run-id test-name item-path state status comment)
- (db:set-state-status-and-roll-up-items
- dbstruct
- (list-ref params 0) ; run-id
- (list-ref params 1) ; test-name
- #f ; item-path
- (list-ref params 2) ; state
- (list-ref params 3) ; status
- (list-ref params 4) ; comment
- ))
-
- ((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))
- ((set-state-status-and-roll-up-run) (apply db:set-state-status-and-roll-up-run 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))
- ((inc-var) (apply db:inc-var dbstruct params))
- ((dec-var) (apply db:dec-var dbstruct params))
- ((del-var) (apply db:del-var dbstruct params))
- ((add-var) (apply db:add-var dbstruct params))
-
- ;; STEPS
- ((teststep-set-status!) (apply db:teststep-set-status! dbstruct params))
- ((delete-steps-for-test!) (apply db:delete-steps-for-test! dbstruct params))
-
- ;; 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))
- ((create-all-triggers) (db:create-all-triggers dbstruct))
- ((drop-all-triggers) (db:drop-all-triggers dbstruct))
-
- ;; 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))
-
- ;; NO SYNC DB
- ((no-sync-set) (apply db:no-sync-set *no-sync-db* params))
- ((no-sync-get/default) (apply db:no-sync-get/default *no-sync-db* params))
- ((no-sync-del!) (apply db:no-sync-del! *no-sync-db* params))
- ((no-sync-get-lock) (apply db:no-sync-get-lock *no-sync-db* 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))
- ((get-not-completed-cnt) (apply db:get-not-completed-cnt dbstruct params))
- ;; ((synchash-get) (apply synchash:server-get dbstruct params))
- ((get-raw-run-stats) (apply db:get-raw-run-stats dbstruct params))
- ((get-test-times) (apply db:get-test-times dbstruct params))
-
- ;; RUNS
- ((get-run-info) (apply db:get-run-info dbstruct params))
- ((get-run-status) (apply db:get-run-status dbstruct params))
- ((get-run-state) (apply db:get-run-state dbstruct params))
- ((set-run-status) (apply db:set-run-status dbstruct params))
- ((set-run-state-status) (apply db:set-run-state-status dbstruct params))
- ((update-tesdata-on-repilcate-db) (apply db:update-tesdata-on-repilcate-db dbstruct params))
- ((get-tests-for-run) (apply db:get-tests-for-run dbstruct params))
- ((get-tests-for-run-state-status) (apply db:get-tests-for-run-state-status 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-tests-for-runs-mindata) (apply db:get-tests-for-runs-mindata dbstruct params))
- ((get-runs) (apply db:get-runs dbstruct params))
- ((simple-get-runs) (apply db:simple-get-runs dbstruct params))
- ((get-num-runs) (apply db:get-num-runs dbstruct params))
- ((get-runs-cnt-by-patt) (apply db:get-runs-cnt-by-patt 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))
- ((get-run-times) (apply db:get-run-times 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))
- ((get-steps-info-by-id) (apply db:get-steps-info-by-id dbstruct params))
-
- ;; TEST DATA
- ((read-test-data) (apply db:read-test-data dbstruct params))
- ((read-test-data-varpatt) (apply db:read-test-data-varpatt dbstruct params))
- ((get-data-info-by-id) (apply db:get-data-info-by-id 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))
- ((get-changed-record-ids) (apply db:get-changed-record-ids dbstruct params))
- ((get-run-record-ids) (apply db:get-run-record-ids dbstruct params))
- ;; TESTMETA
- ((testmeta-get-record) (apply db:testmeta-get-record dbstruct params))
-
- ;; TASKS
- ((find-task-queue-records) (apply tasks:find-task-queue-records dbstruct params))
- (else
- (debug:print 0 *default-log-port* "ERROR: bad api call " cmd)
- (conc "ERROR: BAD api call " cmd))))))
-
-
- ;; save all stats
- (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 '()))))
- (if writecmd-in-readonly-mode
- (begin
- #;(common:telemetry-log (conc "api-out:"(->string cmd))
- payload: `((params . ,params)
- (ok-res . #t)))
- (vector #f res))
- (begin
- #;(common:telemetry-log (conc "api-out:"(->string cmd))
- payload: `((params . ,params)
- (ok-res . #f)))
- (vector #t 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
- (debug:print 4 *default-log-port* "server-id:" *server-id*)
- (let* ((cmd ($ 'cmd))
- (paramsj ($ 'params))
- (key ($ 'key))
- (params (db:string->obj paramsj transport: 'http))) ;; incoming data from the POST (or is it a GET?)
- (debug:print 4 *default-log-port* "cmd:" cmd " with params " params "key " key)
- (if (equal? key *server-id*)
- (begin
- (set! *api-process-request-count* (+ *api-process-request-count* 1))
- (let* ((resdat (api:execute-requests dbstruct (vector cmd params))) ;; process the request, resdat = #( flag result )
- (success (vector-ref resdat 0))
- (res (vector-ref resdat 1))) ;; (vector flag payload), get the payload, ignore the flag (why?)
- (debug:print 4 *default-log-port* "res:" res)
- (if (not success)
- (debug:print 0 *default-log-port* "ERROR: success flag is #f for " cmd " with params " params))
- (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)
- ;; (boolean? res))
- ;; res
- ;; (list "ERROR, not string, list, number or boolean" 1 cmd params res)))))
- (db:obj->string res transport: 'http)))
- (begin
- (debug:print 0 *default-log-port* "Server refused to process request. Sever id mismatch. recived " key " expected: " *server-id* ".\nOther arguments recived: cmd=" cmd " params = " params)
- (db:obj->string (conc "Server refused to process request server-id mismatch: " key ", " *server-id*) transport: 'http)))))
Index: apimod.scm
==================================================================
--- apimod.scm
+++ apimod.scm
@@ -18,18 +18,21 @@
;;======================================================================
(declare (unit apimod))
(declare (uses commonmod))
-;; (declare (uses ulex))
+(declare (uses dbmod))
+(declare (uses tasks))
(module apimod
*
(import scheme chicken data-structures extras)
-(import (prefix sqlite3 sqlite3:) posix typed-records srfi-18)
+(import (prefix sqlite3 sqlite3:) posix typed-records srfi-18 srfi-69)
(import commonmod)
+(import dbmod)
+(import tasks)
;; allow these queries through without starting a server
;;
(define api:read-only-queries
'(get-key-val-pairs
@@ -136,6 +139,280 @@
;; TASKS
tasks-add
tasks-set-state-given-param-key
))
+;; These are called by the server on recipt of /api calls
+;; - keep it simple, only return the actual result of the call, i.e. no meta info here
+;;
+;; - returns #( flag result )
+;;
+(define (api:execute-requests dbstruct dat)
+ (handle-exceptions
+ exn
+ (let ((call-chain (get-call-chain)))
+ (debug:print 0 *default-log-port* "WARNING: api:execute-requests received an exception from peer, dat=" dat ", exn=" exn)
+ (print-call-chain (current-error-port))
+ (debug:print 0 *default-log-port* " message: " ((condition-property-accessor 'exn 'message) exn))
+ (vector #f (vector exn call-chain dat))) ;; return some stuff for debug if an exception happens
+ (cond
+ ((not (vector? dat)) ;; it is an error to not receive a vector
+ (vector #f (vector #f "remote must be called with a vector")))
+ ((> *api-process-request-count* 20) ;; 20)
+ (debug:print 0 *default-log-port* "WARNING: api:execute-requests received an overloaded message.")
+ (set! *server-overloaded* #t)
+ (vector #f (vector #f 'overloaded))) ;; the inner vector is what gets returned. nope, don't know why. please refactor!
+ (else
+ (let* ((cmd-in (vector-ref dat 0))
+ (cmd (if (symbol? cmd-in)
+ cmd-in
+ (string->symbol cmd-in)))
+ (params (vector-ref dat 1))
+ (start-t (current-milliseconds))
+ (readonly-mode (dbr:dbstruct-read-only dbstruct))
+ (readonly-command (member cmd api:read-only-queries))
+ (writecmd-in-readonly-mode (and readonly-mode (not readonly-command)))
+ #;(foo (begin
+ (common:telemetry-log (conc "api-in:"(->string cmd))
+ payload: `((params . ,params)))
+
+ #t))
+ (res
+ (if writecmd-in-readonly-mode
+ (conc "attempt to run write command "cmd" on a read-only database")
+ (case cmd
+ ;;===============================================
+ ;; READ/WRITE QUERIES
+ ;;===============================================
+
+ ((get-keys-write) (db:get-keys dbstruct)) ;; force a dummy "write" query to force server; for debug in -repl
+
+ ;; SERVERS
+ ((start-server) (apply server:kind-run params))
+ ((kill-server) (set! *server-run* #f))
+
+ ;; TESTS
+
+ ;;((test-set-state-status-by-id) (apply mt:test-set-state-status-by-id dbstruct params))
+ ;;BB - commented out above because it was calling below, eventually, incorrectly (dbstruct passed to mt:test-set-state-status-by-id, which previosly did more, but now only passes thru to db:set-state-status-and-roll-up-items.
+ ((test-set-state-status-by-id)
+
+ ;; (define (db:set-state-status-and-roll-up-items dbstruct run-id test-name item-path state status comment)
+ (db:set-state-status-and-roll-up-items
+ dbstruct
+ (list-ref params 0) ; run-id
+ (list-ref params 1) ; test-name
+ #f ; item-path
+ (list-ref params 2) ; state
+ (list-ref params 3) ; status
+ (list-ref params 4) ; comment
+ ))
+
+ ((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))
+ ((set-state-status-and-roll-up-run) (apply db:set-state-status-and-roll-up-run 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))
+ ((inc-var) (apply db:inc-var dbstruct params))
+ ((dec-var) (apply db:dec-var dbstruct params))
+ ((del-var) (apply db:del-var dbstruct params))
+ ((add-var) (apply db:add-var dbstruct params))
+
+ ;; STEPS
+ ((teststep-set-status!) (apply db:teststep-set-status! dbstruct params))
+ ((delete-steps-for-test!) (apply db:delete-steps-for-test! dbstruct params))
+
+ ;; 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))
+ ((create-all-triggers) (db:create-all-triggers dbstruct))
+ ((drop-all-triggers) (db:drop-all-triggers dbstruct))
+
+ ;; 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))
+
+ ;; NO SYNC DB
+ ((no-sync-set) (apply db:no-sync-set *no-sync-db* params))
+ ((no-sync-get/default) (apply db:no-sync-get/default *no-sync-db* params))
+ ((no-sync-del!) (apply db:no-sync-del! *no-sync-db* params))
+ ((no-sync-get-lock) (apply db:no-sync-get-lock *no-sync-db* 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))
+ ((get-not-completed-cnt) (apply db:get-not-completed-cnt dbstruct params))
+ ;; ((synchash-get) (apply synchash:server-get dbstruct params))
+ ((get-raw-run-stats) (apply db:get-raw-run-stats dbstruct params))
+ ((get-test-times) (apply db:get-test-times dbstruct params))
+
+ ;; RUNS
+ ((get-run-info) (apply db:get-run-info dbstruct params))
+ ((get-run-status) (apply db:get-run-status dbstruct params))
+ ((get-run-state) (apply db:get-run-state dbstruct params))
+ ((set-run-status) (apply db:set-run-status dbstruct params))
+ ((set-run-state-status) (apply db:set-run-state-status dbstruct params))
+ ((update-tesdata-on-repilcate-db) (apply db:update-tesdata-on-repilcate-db dbstruct params))
+ ((get-tests-for-run) (apply db:get-tests-for-run dbstruct params))
+ ((get-tests-for-run-state-status) (apply db:get-tests-for-run-state-status 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-tests-for-runs-mindata) (apply db:get-tests-for-runs-mindata dbstruct params))
+ ((get-runs) (apply db:get-runs dbstruct params))
+ ((simple-get-runs) (apply db:simple-get-runs dbstruct params))
+ ((get-num-runs) (apply db:get-num-runs dbstruct params))
+ ((get-runs-cnt-by-patt) (apply db:get-runs-cnt-by-patt 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))
+ ((get-run-times) (apply db:get-run-times 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))
+ ((get-steps-info-by-id) (apply db:get-steps-info-by-id dbstruct params))
+
+ ;; TEST DATA
+ ((read-test-data) (apply db:read-test-data dbstruct params))
+ ((read-test-data-varpatt) (apply db:read-test-data-varpatt dbstruct params))
+ ((get-data-info-by-id) (apply db:get-data-info-by-id 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))
+ ((get-changed-record-ids) (apply db:get-changed-record-ids dbstruct params))
+ ((get-run-record-ids) (apply db:get-run-record-ids dbstruct params))
+ ;; TESTMETA
+ ((testmeta-get-record) (apply db:testmeta-get-record dbstruct params))
+
+ ;; TASKS
+ ((find-task-queue-records) (apply tasks:find-task-queue-records dbstruct params))
+ (else
+ (debug:print 0 *default-log-port* "ERROR: bad api call " cmd)
+ (conc "ERROR: BAD api call " cmd))))))
+
+
+ ;; save all stats
+ (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 '()))))
+ (if writecmd-in-readonly-mode
+ (begin
+ #;(common:telemetry-log (conc "api-out:"(->string cmd))
+ payload: `((params . ,params)
+ (ok-res . #t)))
+ (vector #f res))
+ (begin
+ #;(common:telemetry-log (conc "api-out:"(->string cmd))
+ payload: `((params . ,params)
+ (ok-res . #f)))
+ (vector #t 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
+ (debug:print 4 *default-log-port* "server-id:" *server-id*)
+ (let* ((cmd ($ 'cmd))
+ (paramsj ($ 'params))
+ (key ($ 'key))
+ (params (db:string->obj paramsj transport: 'http))) ;; incoming data from the POST (or is it a GET?)
+ (debug:print 4 *default-log-port* "cmd:" cmd " with params " params "key " key)
+ (if (equal? key *server-id*)
+ (begin
+ (set! *api-process-request-count* (+ *api-process-request-count* 1))
+ (let* ((resdat (api:execute-requests dbstruct (vector cmd params))) ;; process the request, resdat = #( flag result )
+ (success (vector-ref resdat 0))
+ (res (vector-ref resdat 1))) ;; (vector flag payload), get the payload, ignore the flag (why?)
+ (debug:print 4 *default-log-port* "res:" res)
+ (if (not success)
+ (debug:print 0 *default-log-port* "ERROR: success flag is #f for " cmd " with params " params))
+ (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)
+ ;; (boolean? res))
+ ;; res
+ ;; (list "ERROR, not string, list, number or boolean" 1 cmd params res)))))
+ (db:obj->string res transport: 'http)))
+ (begin
+ (debug:print 0 *default-log-port* "Server refused to process request. Sever id mismatch. recived " key " expected: " *server-id* ".\nOther arguments recived: cmd=" cmd " params = " params)
+ (db:obj->string (conc "Server refused to process request server-id mismatch: " key ", " *server-id*) transport: 'http)))))
+
)
Index: archive.scm
==================================================================
--- archive.scm
+++ archive.scm
@@ -30,10 +30,13 @@
(declare (uses commonmod))
(import commonmod)
(declare (uses dbmod))
(import dbmod)
+
+(declare (uses margsmod))
+(import margsmod)
(include "common_records.scm")
(include "db_records.scm")
;;======================================================================
Index: build.inc
==================================================================
--- build.inc
+++ build.inc
@@ -4,10 +4,11 @@
#
api.o : mofiles/apimod.o
api.o : mofiles/commonmod.o
api.o : mofiles/dbmod.o
+api.o : mofiles/tasks.o
archive.o : mofiles/commonmod.o
archive.o : mofiles/configfmod.o
archive.o : mofiles/dbmod.o
client.o : mofiles/commonmod.o
client.o : mofiles/dbmod.o
@@ -21,10 +22,11 @@
dashboard-context-menu.o : mofiles/commonmod.o
dashboard-context-menu.o : mofiles/configfmod.o
dashboard-context-menu.o : mofiles/dbmod.o
dashboard-guimonitor.o : mofiles/commonmod.o
dashboard-guimonitor.o : mofiles/dbmod.o
+dashboard-guimonitor.o : mofiles/tasks.o
dashboard-tests.o : mofiles/commonmod.o
dashboard-tests.o : mofiles/configfmod.o
dashboard-tests.o : mofiles/dbmod.o
dashboard.o : mofiles/apimod.o
dashboard.o : mofiles/commonmod.o
@@ -58,18 +60,20 @@
items.o : mofiles/configfmod.o
launch.o : mofiles/commonmod.o
launch.o : mofiles/configfmod.o
launch.o : mofiles/dbmod.o
lock-queue.o : mofiles/commonmod.o
+lock-queue.o : mofiles/tasks.o
megatest.o : mofiles/apimod.o
megatest.o : mofiles/commonmod.o
megatest.o : mofiles/configfmod.o
megatest.o : mofiles/dbmod.o
megatest.o : mofiles/ods.o
megatest.o : mofiles/rmtmod.o
megatest.o : mofiles/servermod.o
mofiles/apimod.o : mofiles/commonmod.o
+mofiles/commonmod.o : mofiles/margsmod.o
mofiles/configfmod.o : mofiles/commonmod.o
mofiles/dbmod.o : mofiles/commonmod.o
mofiles/dbmod.o : mofiles/configfmod.o
mofiles/dbmod.o : mofiles/ods.o
mofiles/dcommonmod.o : mofiles/commonmod.o
@@ -76,16 +80,22 @@
mofiles/dcommonmod.o : mofiles/configfmod.o
mofiles/ods.o : mofiles/commonmod.o
mofiles/portlogger.o : mofiles/commonmod.o
mofiles/portlogger.o : mofiles/configfmod.o
mofiles/portlogger.o : mofiles/dbmod.o
+mofiles/rmtmod.o : mofiles/apimod.o
mofiles/rmtmod.o : mofiles/apimod.o
mofiles/rmtmod.o : mofiles/commonmod.o
mofiles/rmtmod.o : mofiles/dbmod.o
mofiles/servermod.o : mofiles/commonmod.o
mofiles/servermod.o : mofiles/configfmod.o
mofiles/servermod.o : mofiles/dbmod.o
+mofiles/tasks.o : mofiles/commonmod.o
+mofiles/tasks.o : mofiles/configfmod.o
+mofiles/tasks.o : mofiles/dbmod.o
+mofiles/tasks.o : mofiles/pgdb.o
+mofiles/tasks.o : mofiles/rmtmod.o
mofiles/transport.o : mofiles/commonmod.o
mofiles/transport.o : mofiles/configfmod.o
mofiles/transport.o : mofiles/portlogger.o
mt.o : mofiles/commonmod.o
mt.o : mofiles/configfmod.o
@@ -94,10 +104,11 @@
mtut.o : mofiles/commonmod.o
mtut.o : mofiles/configfmod.o
newdashboard.o : mofiles/commonmod.o
newdashboard.o : mofiles/configfmod.o
newdashboard.o : mofiles/dbmod.o
+mofiles/pgdb.o : mofiles/margsmod.o
process.o : mofiles/commonmod.o
rmt.o : mofiles/apimod.o
rmt.o : mofiles/commonmod.o
rmt.o : mofiles/configfmod.o
rmt.o : mofiles/dbmod.o
@@ -114,13 +125,10 @@
server.o : mofiles/servermod.o
subrun.o : mofiles/commonmod.o
subrun.o : mofiles/configfmod.o
subrun.o : mofiles/dbmod.o
synchash.o : mofiles/dbmod.o
-tasks.o : mofiles/commonmod.o
-tasks.o : mofiles/configfmod.o
-tasks.o : mofiles/dbmod.o
tcmt.o : mofiles/commonmod.o
tdb.o : mofiles/commonmod.o
tdb.o : mofiles/dbmod.o
tdb.o : mofiles/ods.o
tests.o : mofiles/commonmod.o
Index: cgisetup/models/pgdb.scm
==================================================================
--- cgisetup/models/pgdb.scm
+++ cgisetup/models/pgdb.scm
@@ -18,23 +18,25 @@
;;======================================================================
(declare (unit pgdb))
(declare (uses configf))
-
-;; I don't know how to mix compilation units and modules, so no module here.
-;;
-;; (module pgdb
-;; (
-;; open-pgdb
-;; )
-;;
-;; (import scheme)
-;; (import data-structures)
-;; (import chicken)
-
-(use typed-records (prefix dbi dbi:))
+(declare (uses configfmod))
+(declare (uses commonmod))
+(declare (uses margsmod))
+
+(module pgdb
+ *
+
+(import scheme)
+(import data-structures)
+(import chicken)
+(import commonmod)
+(import configfmod)
+(import margsmod)
+
+(import srfi-1 srfi-69 typed-records (prefix dbi dbi:))
;; given a configdat lookup the connection info and open the db
;;
(define (pgdb:open configdat #!key (dbname #f)(dbispec #f))
(let ((pgconf (or dbispec
@@ -652,5 +654,6 @@
((> i tab2-pages )
lst)
(else
(loop (+ i 1) (append lst (list i)))))))
+)
Index: client.scm
==================================================================
--- client.scm
+++ client.scm
@@ -26,11 +26,10 @@
(declare (unit client))
(declare (uses common))
(declare (uses db))
-(declare (uses tasks)) ;; tasks are where stuff is maintained about what is running.
(declare (uses commonmod))
(import commonmod)
(declare (uses dbmod))
Index: common.scm
==================================================================
--- common.scm
+++ common.scm
@@ -57,10 +57,13 @@
(declare (uses configfmod))
(import configfmod)
(declare (uses servermod))
(import servermod)
+
+(declare (uses margsmod))
+(import margsmod)
(include "common_records.scm")
;;======================================================================
;; (require-library margs)
Index: commonmod.scm
==================================================================
--- commonmod.scm
+++ commonmod.scm
@@ -17,16 +17,19 @@
;; along with Megatest. If not, see .
;;======================================================================
(declare (unit commonmod))
+(declare (uses margsmod))
(module commonmod
*
;;(import scheme chicken data-structures extras files ports)
(import scheme chicken)
+(import margsmod)
+
(use data-structures extras files ports)
(use
(prefix base64 base64:)
(prefix sqlite3 sqlite3:)
(srfi 18)
Index: configf.scm
==================================================================
--- configf.scm
+++ configf.scm
@@ -30,10 +30,13 @@
(declare (uses commonmod))
(import commonmod)
(declare (uses configfmod))
(import configfmod)
+
+(declare (uses margsmod))
+(import margsmod)
(include "common_records.scm")
;; return list (path fullpath configname)
(define (find-config configname #!key (toppath #f))
Index: dashboard-guimonitor.scm
==================================================================
--- dashboard-guimonitor.scm
+++ dashboard-guimonitor.scm
@@ -33,10 +33,11 @@
(declare (unit dashboard-guimonitor))
(declare (uses common))
(declare (uses db))
(declare (uses tasks))
+(import tasks)
(declare (uses commonmod))
(import commonmod)
(declare (uses dbmod))
Index: dashboard.scm
==================================================================
--- dashboard.scm
+++ dashboard.scm
@@ -30,11 +30,13 @@
matchable) ;; defstruct
(import (prefix sqlite3 sqlite3:))
(declare (uses common))
-(declare (uses margs))
+(declare (uses margsmod))
+(import margsmod)
+
(declare (uses items))
(declare (uses db))
(declare (uses configf))
(declare (uses process))
(declare (uses launch))
Index: db.scm
==================================================================
--- db.scm
+++ db.scm
@@ -32,10 +32,12 @@
(declare (unit db))
(declare (uses common))
(declare (uses client))
(declare (uses mt))
+(declare (uses margsmod))
+(import margsmod)
(declare (uses commonmod))
(import commonmod)
(declare (uses configfmod))
Index: env.scm
==================================================================
--- env.scm
+++ env.scm
@@ -17,10 +17,13 @@
;; along with Megatest. If not, see .
;;======================================================================
(declare (unit env))
+
+(declare (uses margsmod))
+(import margsmod)
(declare (uses commonmod))
(import commonmod)
(use sql-de-lite) ;; srfi-1 posix regex regex-case srfi-69 srfi-18 call-with-environment-variables)
Index: ezsteps.scm
==================================================================
--- ezsteps.scm
+++ ezsteps.scm
@@ -25,10 +25,14 @@
(declare (unit ezsteps))
(declare (uses db))
(declare (uses common))
(declare (uses items))
(declare (uses runconfig))
+
+(declare (uses margsmod))
+(import margsmod)
+
;; (declare (uses sdb))
;; (declare (uses filedb))
(declare (uses commonmod))
(import commonmod)
Index: genexample.scm
==================================================================
--- genexample.scm
+++ genexample.scm
@@ -21,10 +21,13 @@
(declare (unit genexample))
(use posix regex matchable)
(declare (uses commonmod))
(import commonmod)
+
+(declare (uses margsmod))
+(import margsmod)
(include "db_records.scm")
(define genexample:example-logpro
#<.
-
-
-(declare (unit margs))
-;; (declare (uses common))
-
-(define args:arg-hash (make-hash-table))
-
-(define (args:get-arg arg . default)
- (if (null? default)
- (hash-table-ref/default args:arg-hash arg #f)
- (hash-table-ref/default args:arg-hash arg (car default))))
-
-(define (args:any? . args)
- (not (null? (filter (lambda (x) x)
- (map args:get-arg args)))))
-
-(define (args:get-arg-from ht arg . default)
- (if (null? default)
- (hash-table-ref/default ht arg #f)
- (hash-table-ref/default ht arg (car default))))
-
-(define (args:usage . args)
- (if (> (length args) 0)
- (apply print "ERROR: " args))
- (if (string? help)
- (print help)
- (print "Usage: " (car (argv)) " ... "))
- (exit 0))
-
- ;; one-of args defined
-(define (args:any-defined? . param)
- (let ((res #f))
- (for-each
- (lambda (arg)
- (if (args:get-arg arg)(set! res #t)))
- param)
- res))
-
-;; args:
-(define (args:get-args args params switches arg-hash num-needed)
- (let* ((numargs (length args))
- (adj-num-needed (if num-needed (+ num-needed 2) #f)))
- (if (< numargs (if adj-num-needed adj-num-needed 2))
- (if (>= num-needed 1)
- (args:usage "No arguments provided")
- '())
- (let loop ((arg (cadr args))
- (tail (cddr args))
- (remargs '()))
- (cond
- ((member arg params) ;; args with params
- (if (< (length tail) 1)
- (args:usage "param given without argument " arg)
- (let ((val (car tail))
- (newtail (cdr tail)))
- (hash-table-set! arg-hash arg val)
- (if (null? newtail) remargs
- (loop (car newtail)(cdr newtail) remargs)))))
- ((member arg switches) ;; args with no params (i.e. switches)
- (hash-table-set! arg-hash arg #t)
- (if (null? tail) remargs
- (loop (car tail)(cdr tail) remargs)))
- (else
- (if (null? tail)(append remargs (list arg)) ;; return the non-used args
- (loop (car tail)(cdr tail)(append remargs (list arg))))))))
- ))
-
-(define (args:print-args remargs arg-hash)
- (print "ARGS: " remargs)
- (for-each (lambda (arg)
- (print " " arg " " (hash-table-ref/default arg-hash arg #f)))
- (hash-table-keys arg-hash)))
ADDED margsmod.scm
Index: margsmod.scm
==================================================================
--- /dev/null
+++ margsmod.scm
@@ -0,0 +1,99 @@
+;; Copyright 2007-2010, Matthew Welland.
+;;
+;; This file is part of Megatest.
+;;
+;; Megatest is free software: you can redistribute it and/or modify
+;; it under the terms of the GNU General Public License as published by
+;; the Free Software Foundation, either version 3 of the License, or
+;; (at your option) any later version.
+;;
+;; Megatest is distributed in the hope that it will be useful,
+;; but WITHOUT ANY WARRANTY; without even the implied warranty of
+;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
+;; GNU General Public License for more details.
+;;
+;; You should have received a copy of the GNU General Public License
+;; along with Megatest. If not, see .
+
+
+(declare (unit margsmod))
+
+(module margsmod
+ *
+
+(import scheme chicken data-structures extras)
+(import srfi-69 srfi-1)
+
+(define args:help #f)
+
+(define (args:set-help help)
+ (set! args:help help))
+
+(define args:arg-hash (make-hash-table))
+
+(define (args:get-arg arg . default)
+ (if (null? default)
+ (hash-table-ref/default args:arg-hash arg #f)
+ (hash-table-ref/default args:arg-hash arg (car default))))
+
+(define (args:any? . args)
+ (not (null? (filter (lambda (x) x)
+ (map args:get-arg args)))))
+
+(define (args:get-arg-from ht arg . default)
+ (if (null? default)
+ (hash-table-ref/default ht arg #f)
+ (hash-table-ref/default ht arg (car default))))
+
+(define (args:usage . args)
+ (if (> (length args) 0)
+ (apply print "ERROR: " args))
+ (if (string? args:help)
+ (print args:help)
+ (print "Usage: " (car (argv)) " ... "))
+ (exit 0))
+
+ ;; one-of args defined
+(define (args:any-defined? . param)
+ (let ((res #f))
+ (for-each
+ (lambda (arg)
+ (if (args:get-arg arg)(set! res #t)))
+ param)
+ res))
+
+;; args:
+(define (args:get-args args params switches arg-hash num-needed)
+ (let* ((numargs (length args))
+ (adj-num-needed (if num-needed (+ num-needed 2) #f)))
+ (if (< numargs (if adj-num-needed adj-num-needed 2))
+ (if (>= num-needed 1)
+ (args:usage "No arguments provided")
+ '())
+ (let loop ((arg (cadr args))
+ (tail (cddr args))
+ (remargs '()))
+ (cond
+ ((member arg params) ;; args with params
+ (if (< (length tail) 1)
+ (args:usage "param given without argument " arg)
+ (let ((val (car tail))
+ (newtail (cdr tail)))
+ (hash-table-set! arg-hash arg val)
+ (if (null? newtail) remargs
+ (loop (car newtail)(cdr newtail) remargs)))))
+ ((member arg switches) ;; args with no params (i.e. switches)
+ (hash-table-set! arg-hash arg #t)
+ (if (null? tail) remargs
+ (loop (car tail)(cdr tail) remargs)))
+ (else
+ (if (null? tail)(append remargs (list arg)) ;; return the non-used args
+ (loop (car tail)(cdr tail)(append remargs (list arg))))))))
+ ))
+
+(define (args:print-args remargs arg-hash)
+ (print "ARGS: " remargs)
+ (for-each (lambda (arg)
+ (print " " arg " " (hash-table-ref/default arg-hash arg #f)))
+ (hash-table-keys arg-hash)))
+)
Index: megatest.scm
==================================================================
--- megatest.scm
+++ megatest.scm
@@ -22,29 +22,30 @@
;; fake out readline usage of toplevel-command
(define (toplevel-command . a) #f)
(declare (uses common))
;; (declare (uses megatest-version))
-(declare (uses margs))
+(declare (uses margsmod))
+(import margsmod)
+
(declare (uses runs))
(declare (uses launch))
(declare (uses server))
(declare (uses client))
(declare (uses tests))
(declare (uses genexample))
-;; (declare (uses daemon))
(declare (uses db))
-;; (declare (uses dcommon))
(declare (uses tdb))
(declare (uses mt))
-(declare (uses api))
+
(declare (uses tasks)) ;; only used for debugging.
+(import tasks)
+(declare (uses tasks.import))
+
(declare (uses env))
(declare (uses diff-report))
-;; (declare (uses ftail))
-;; (import ftail)
;; Needed for repl even if not used here in megatest.scm
;; ORDER MATTERS!
(declare (uses commonmod))
Index: mtexec.scm
==================================================================
--- mtexec.scm
+++ mtexec.scm
@@ -26,11 +26,13 @@
srfi-19 srfi-18 extras format pkts regex regex-case
(prefix dbi dbi:)
)
;; (declare (uses common))
-(declare (uses margs))
+(declare (uses margsmod))
+(import margsmod)
+
(declare (uses configf))
;; (declare (uses rmt))
(declare (uses configfmod))
(import configfmod)
Index: mtut.scm
==================================================================
--- mtut.scm
+++ mtut.scm
@@ -27,11 +27,13 @@
(prefix dbi dbi:)
(prefix sqlite3 sqlite3:)
nanomsg)
(declare (uses common))
-(declare (uses margs))
+(declare (uses margsmod))
+(import margsmod)
+
(declare (uses configf))
;; (declare (uses rmt))
(declare (uses commonmod))
(import commonmod)
Index: newdashboard.scm
==================================================================
--- newdashboard.scm
+++ newdashboard.scm
@@ -28,11 +28,12 @@
(use sql-de-lite srfi-1 posix regex regex-case srfi-69 typed-records sparse-vectors ;; defstruct
(prefix dbi dbi:))
(declare (uses common))
(declare (uses megatest-version))
-(declare (uses margs))
+(declare (uses margsmod))
+(import margsmod)
(declare (uses commonmod))
(import commonmod)
(declare (uses dbmod))
ADDED pgdb.scm
Index: pgdb.scm
==================================================================
--- /dev/null
+++ pgdb.scm
@@ -0,0 +1,1 @@
+(include "cgisetup/models/pgdb.scm")
Index: rmt.scm
==================================================================
--- rmt.scm
+++ rmt.scm
@@ -19,1038 +19,5 @@
;;======================================================================
(use format typed-records) ;; RADT => purpose of json format??
(declare (unit rmt))
-(declare (uses api))
-(declare (uses http-transport))
-
-(declare (uses commonmod))
-(import commonmod)
-
-(declare (uses apimod))
-(import apimod)
-
-(declare (uses rmtmod))
-(import rmtmod)
-
-;; should not be here
-(declare (uses dbmod))
-(import dbmod)
-
-(declare (uses configfmod))
-(import configfmod)
-
-(declare (uses servermod))
-(import servermod)
-
-(include "common_records.scm")
-;; (declare (uses rmtmod))
-
-;; (import rmtmod)
-
-;;
-;; THESE ARE ALL CALLED ON THE CLIENT SIDE!!!
-;;
-
-;; generate entries for ~/.megatestrc with the following
-;;
-;; grep define ../rmt.scm | grep rmt: |perl -pi -e 's/\(define\s+\((\S+)\W.*$/\1/'|sort -u
-
-;;======================================================================
-;; 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 areapath #!key (area-dat #f)) ;; TODO: push areapath down.
- (let* ((runremote (or area-dat *runremote*))
- (cinfo (if (remote? runremote)
- (remote-conndat runremote)
- #f)))
- (if cinfo
- cinfo
- (if (server:check-if-running areapath)
- (client:setup areapath)
- #f))))
-
-;;======================================================================
-
-(define (create-remote-record)
- (let ((rr (make-remote)))
- (rmt:init-remote rr)
- rr))
-
-(define (rmt:init-remote rr)
- (remote-hh-dat-set! rr (common:get-homehost)) ;
- (remote-server-info-set! rr (if *toppath* (server:check-if-running *toppath*) #f))
- (remote-transport-set! rr *transport-type*)
- (remote-server-timeout-set! rr (server:expiration-timeout))
- rr)
-
-;; RA => e.g. usage (rmt:send-receive 'get-var #f (list varname))
-;;
-(define (rmt:send-receive cmd rid params #!key (attemptnum 1)(area-dat #f)) ;; start attemptnum at 1 so the modulo below works as expected
-
- #;(common:telemetry-log (conc "rmt:"(->string cmd))
- payload: `((rid . ,rid)
- (params . ,params)))
-
- (if (> attemptnum 2)
- (debug:print 0 *default-log-port* "INFO: attemptnum in rmt:send-receive is " attemptnum))
-
- (cond
- ((> attemptnum 2) (thread-sleep! 0.05))
- ((> attemptnum 10) (thread-sleep! 0.5))
- ((> attemptnum 20) (thread-sleep! 1)))
- (if (and (> attemptnum 5) (= 0 (modulo attemptnum 15)))
- (begin (server:run *toppath*) (thread-sleep! 3)))
-
-
- ;;DOT digraph megatest_state_status {
- ;;DOT ranksep=0;
- ;;DOT // rankdir=LR;
- ;;DOT node [shape="box"];
- ;;DOT "rmt:send-receive" -> MUTEXLOCK;
- ;;DOT { edge [style=invis];"case 1" -> "case 2" -> "case 3" -> "case 4" -> "case 5" -> "case 6" -> "case 7" -> "case 8" -> "case 9" -> "case 10" -> "case 11"; }
- ;; do all the prep locked under the rmt-mutex
- (mutex-lock! *rmt-mutex*)
-
- ;; set up runremote record earlier than the loop below
- (if (not *runremote*) ;; can remove this one. should never get here.
- (begin
- (set! *runremote* (create-remote-record))
- (let* ((server-info (remote-server-info *runremote*)))
- (if server-info
- (begin
- (remote-server-url-set! *runremote* (server:record->url server-info))
- (remote-server-id-set! *runremote* (server:record->id server-info)))))
- #;(set! area-dat *runremote*))) ;; new runremote will come from this on next iteration
-
- ;; 1. check if server is started IFF cmd is a write OR if we are not on the homehost, store in runremote
- ;; 2. check the age of the connections. refresh the connection if it is older than timeout-20 seconds.
- ;; 3. do the query, if on homehost use local access
- ;;
- (let* ((start-time (current-seconds)) ;; snapshot time so all use cases get same value
- (areapath *toppath*);; TODO - resolve from dbstruct to be compatible with multiple areas
- (runremote (or area-dat
- *runremote*))
- (attemptnum (+ 1 attemptnum))
- (readonly-mode (rmtmod:calc-ro-mode runremote *toppath*)))
-
- ;; DOT INIT_RUNREMOTE; // leaving off - doesn't really add to the clarity
- ;; DOT MUTEXLOCK -> INIT_RUNREMOTE [label="no remote?"];
- ;; DOT INIT_RUNREMOTE -> MUTEXLOCK;
- ;; ensure we have a record for our connection for given area
- ;; DOT SET_HOMEHOST; // leaving off - doesn't really add to the clarity
- ;; DOT MUTEXLOCK -> SET_HOMEHOST [label="no homehost?"];
- ;; DOT SET_HOMEHOST -> MUTEXLOCK;
- ;; ensure we have a homehost record
- (if (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)))
-
- ;;(print "BB> readonly-mode is "readonly-mode" dbfile is "dbfile)
- (cond
- ;;DOT EXIT;
- ;;DOT MUTEXLOCK -> EXIT [label="> 15 attempts"]; {rank=same "case 1" "EXIT" }
- ;; give up if more than 150 attempts
- ((> attemptnum 150)
- (debug:print 0 *default-log-port* "ERROR: 150 tries to start/connect to server. Giving up.")
- (exit 1))
-
- ;;DOT CASE2 [label="local\nreadonly\nquery"];
- ;;DOT MUTEXLOCK -> CASE2; {rank=same "case 2" CASE2}
- ;;DOT CASE2 -> "rmt:open-qry-close-locally";
- ;; readonly mode, read request- handle it - case 2
- ((and readonly-mode
- (member cmd api:read-only-queries))
- (mutex-unlock! *rmt-mutex*)
- (debug:print-info 12 *default-log-port* "rmt:send-receive, case 2")
- (rmt:open-qry-close-locally cmd 0 params)
- )
-
- ;;DOT CASE3 [label="write in\nread-only mode"];
- ;;DOT MUTEXLOCK -> CASE3 [label="readonly\nmode?"]; {rank=same "case 3" CASE3}
- ;;DOT CASE3 -> "#f";
- ;; readonly mode, write request. Do nothing, return #f
- (readonly-mode (extras-readonly-mode *rmt-mutex* *default-log-port* cmd params))
-
- ;; This block was for pre-emptively resetting the connection if there had been no communication for some time.
- ;; I don't think it adds any value. If the server is not there, just fail and start a new connection.
- ;; also, the expire-time calculation might not be correct. We want, time-since-last-server-access > (server:get-timeout)
- ;;
- ;;DOT CASE4 [label="reset\nconnection"];
- ;;DOT MUTEXLOCK -> CASE4 [label="have connection,\nlast_access > expire_time"]; {rank=same "case 4" CASE4}
- ;;DOT CASE4 -> "rmt:send-receive";
- ;; reset the connection if it has been unused too long
- ((and runremote
- (remote-conndat runremote)
- (> (current-seconds) ;; if it has been more than server-timeout seconds since last contact, close this connection and start a new on
- (+ (http-transport:server-dat-get-last-access (remote-conndat runremote))
- (remote-server-timeout runremote))))
- (debug:print-info 0 *default-log-port* "Connection to " (remote-server-url runremote) " expired due to no accesses, forcing new connection.")
- (http-transport:close-connections area-dat: runremote)
- (remote-conndat-set! runremote #f) ;; invalidate the connection, thus forcing a new connection.
- (mutex-unlock! *rmt-mutex*)
- (rmt:send-receive cmd rid params attemptnum: attemptnum))
-
- ;;DOT CASE5 [label="local\nread"];
- ;;DOT MUTEXLOCK -> CASE5 [label="server not required,\non homehost,\nread-only query"]; {rank=same "case 5" CASE5};
- ;;DOT CASE5 -> "rmt:open-qry-close-locally";
-
- ;; on homehost and this is a read
- ((and (not (remote-force-server runremote)) ;; honor forced use of server, i.e. server NOT required
- (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 5")
- (rmt:open-qry-close-locally cmd 0 params))
-
- ;;DOT CASE6 [label="init\nremote"];
- ;;DOT MUTEXLOCK -> CASE6 [label="on homehost,\nwrite query,\nhave server,\ncan't reach it"]; {rank=same "case 6" CASE6};
- ;;DOT CASE6 -> "rmt:send-receive";
- ;; 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:ping (remote-server-url runremote) (remote-server-id runremote)))) ;; server has died. NOTE: this is not a cheap call! Need better approach.
- (set! *runremote* (create-remote-record))
- (let* ((server-info (remote-server-info *runremote*)))
- (if server-info
- (begin
- (remote-server-url-set! *runremote* (server:record->url server-info))
- (remote-server-id-set! *runremote* (server:record->id server-info)))))
- (remote-force-server-set! runremote (common:force-server?))
- (mutex-unlock! *rmt-mutex*)
- (debug:print-info 12 *default-log-port* "rmt:send-receive, case 6")
- (rmt:send-receive cmd rid params attemptnum: attemptnum))
-
- ;;DOT CASE7 [label="homehost\nwrite"];
- ;;DOT MUTEXLOCK -> CASE7 [label="server not required,\non homehost,\na write,\nhave a server"]; {rank=same "case 7" CASE7};
- ;;DOT CASE7 -> "rmt:open-qry-close-locally";
- ;; on homehost and this is a write, we already have a server
- ((and (not (remote-force-server runremote)) ;; honor forced use of server, i.e. server NOT required
- (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.1")
- (rmt:open-qry-close-locally cmd 0 params))
-
- ;;DOT CASE8 [label="force\nserver"];
- ;;DOT MUTEXLOCK -> CASE8 [label="server not required,\nhave homehost info,\nno connection yet,\nnot a read-only query"]; {rank=same "case 8" CASE8};
- ;;DOT CASE8 -> "rmt:open-qry-close-locally";
- ;; on homehost, no server contact made and this is a write, passively start a server
- ((and (not (remote-force-server runremote)) ;; honor forced use of server, i.e. server NOT required
- (cdr (remote-hh-dat runremote)) ;; have homehost
- (not (remote-server-url runremote)) ;; no connection yet
- (not (member cmd api:read-only-queries))) ;; not a read-only query
- (debug:print-info 12 *default-log-port* "rmt:send-receive, case 8")
- (let ((server-info (server:check-if-running *toppath*))) ;; (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-info
- (begin
- (remote-server-url-set! runremote (server:record->url server-info)) ;; the string can be consumed by the client setup if needed
- (remote-server-id-set! runremote (server:record->id server-info)))
- (if (common:force-server?)
- (server:start-and-wait *toppath*)
- (server:kind-run *toppath*)))
- (remote-force-server-set! runremote (common:force-server?))
- (mutex-unlock! *rmt-mutex*)
- (debug:print-info 12 *default-log-port* "rmt:send-receive, case 8.1")
- (rmt:open-qry-close-locally cmd 0 params)))
-
- ;;DOT CASE9 [label="force server\nnot on homehost"];
- ;;DOT MUTEXLOCK -> CASE9 [label="no connection\nand either require server\nor not on homehost"]; {rank=same "case 9" CASE9};
- ;;DOT CASE9 -> "start\nserver" -> "rmt:send-receive";
- ((or (and (remote-force-server runremote) ;; we are forcing a server and don't yet have a connection to one
- (not (remote-conndat runremote)))
- (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 9, hh-dat: " (remote-hh-dat runremote) " conndat: " (remote-conndat runremote))
- (mutex-unlock! *rmt-mutex*)
- (if (not (server:check-if-running *toppath*)) ;; who knows, maybe one has started up?
- (server:start-and-wait *toppath*))
- (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
-
- ;;DOT CASE10 [label="on homehost"];
- ;;DOT MUTEXLOCK -> CASE10 [label="server not required,\non homehost"]; {rank=same "case 10" CASE10};
- ;;DOT CASE10 -> "rmt:open-qry-close-locally";
- ;; all set up if get this far, dispatch the query
- ((and (not (remote-force-server runremote))
- (cdr (remote-hh-dat runremote))) ;; we are on homehost
- (mutex-unlock! *rmt-mutex*)
- (debug:print-info 12 *default-log-port* "rmt:send-receive, case 10")
- (rmt:open-qry-close-locally cmd (if rid rid 0) params))
-
- ;;DOT CASE11 [label="send_receive"];
- ;;DOT MUTEXLOCK -> CASE11 [label="else"]; {rank=same "case 11" CASE11};
- ;;DOT CASE11 -> "rmt:send-receive" [label="call failed"];
- ;;DOT CASE11 -> "RESULT" [label="call succeeded"];
- ;; not on homehost, do server query
- (else (extras-case-11 *default-log-port* runremote cmd params attemptnum rid)))))
- ;;DOT }
-
-;; bunch of small functions factored out of send-receive to make debug easier
-;;
-
-(define (extras-case-11 *default-log-port* runremote cmd params attemptnum rid)
- ;; (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-in (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)
- ((servermismatch) (vector #f "Server id mismatch" ))
- ((commfail)(vector #f "communications fail"))
- ((exn)(vector #f "other fail" (print-call-chain)))))
- (else
- (debug:print 0 *default-log-port* "ERROR: transport " (remote-transport runremote) " not supported")
- (exit))))
-
-;; No Title
-;; Error: (vector-ref) out of range
-;; #(# (#("db.scm:3740: regex#regexp" #f #f) #("db.scm:3739: regex#string-substitute" #f #f) #("db.scm:3738: base64#base64-decode" #f #f) #("db.scm:3737: z3#z3:decode-buffer" #f #f) #("db.scm:3736: with-input-from-string" #f #f) #("db.scm:3741: s11n#deserialize" #f #f) #("api.scm:374: api:execute-requests" #f #f) #("api.scm:139: call-with-current-continuation" #f #f) #("api.scm:139: with-exception-handler" #f #f) #("api.scm:139: ##sys#call-with-values" #f #f) #("api.scm:158: string->symbol" #f #f) #("api.scm:160: current-milliseconds" #f #f) #("api.scm:161: dbr:dbstruct-read-only" #f #f) #("api.scm:139: k15" #f #f) #("api.scm:139: g19" #f #f) #("api.scm:142: get-call-chain" #f #f)) #("get-test-info-by-id" (1102 507299)))
-;; 6
-;;
-;; Call history:
-;;
-;; http-transport.scm:306: thread-terminate!
-;; http-transport.scm:307: debug:print-info
-;; common_records.scm:235: debug:debug-mode
-;; rmt.scm:259: k587
-;; rmt.scm:259: g591
-;; rmt.scm:276: http-transport:server-dat-update-last-access
-;; http-transport.scm:364: current-seconds
-;; rmt.scm:282: debug:print-info
-;; common_records.scm:235: debug:debug-mode
-;; rmt.scm:283: mutex-unlock!
-;; rmt.scm:287: extras-transport-succeded <--
-;; +-----------------------------------------------------------------------------+
-;; | Exit Status : 70
-;;
-
- (dat (if (and (vector? dat-in) ;; ... check it is a correct size
- (> (vector-length dat-in) 1))
- dat-in
- (vector #f (conc "communications fail (type 2), dat-in=" dat-in))))
- (success (if (vector? dat) (vector-ref dat 0) #f))
- (res (if (vector? dat) (vector-ref dat 1) #f)))
- (if (and (vector? conninfo) (< 5 (vector-length conninfo)))
- (http-transport:server-dat-update-last-access conninfo) ;; refresh access time
- (begin
- (debug:print 0 *default-log-port* "INFO: Should not get here! conninfo=" conninfo)
- (set! conninfo #f)
- (remote-conndat-set! *runremote* #f) ;; NOTE: *runremote* is global copy of runremote. Purpose: factor out global.
- (http-transport:close-connections area-dat: runremote)))
- (debug:print-info 13 *default-log-port* "rmt:send-receive, case 9. conninfo=" conninfo " dat=" dat " runremote = " runremote)
- (mutex-unlock! *rmt-mutex*)
- (if success ;; success only tells us that the transport was
- ;; successful, have to examine the data to see if
- ;; there was a detected issue at the other end
- (extras-transport-succeded *default-log-port* *rmt-mutex* attemptnum runremote res params rid cmd)
- (begin
- (debug:print-error 0 *default-log-port* " dat=" dat)
- (extras-transport-failed *default-log-port* *rmt-mutex* attemptnum runremote cmd rid params))
- )))
-
-(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"))
- (for-each (lambda (cmd)
- (let ((cmd-dat (hash-table-ref *db-stats* cmd)))
- (debug:print 18 *default-log-port* (format #f fmtstr cmd (vector-ref cmd-dat 0) (vector-ref cmd-dat 1) (/ (vector-ref cmd-dat 1)(vector-ref cmd-dat 0))))))
- (sort (hash-table-keys *db-stats*)
- (lambda (a b)
- (> (vector-ref (hash-table-ref *db-stats* a) 0)
- (vector-ref (hash-table-ref *db-stats* b) 0)))))))
-
-(define (rmt:get-max-query-average run-id)
- (mutex-lock! *db-stats-mutex*)
- (let* ((runkey (conc "run-id=" run-id " "))
- (cmds (filter (lambda (x)
- (substring-index runkey x))
- (hash-table-keys *db-stats*)))
- (res (if (null? cmds)
- (cons 'none 0)
- (let loop ((cmd (car cmds))
- (tal (cdr cmds))
- (max-cmd (car cmds))
- (res 0))
- (let* ((cmd-dat (hash-table-ref *db-stats* cmd))
- (tot (vector-ref cmd-dat 0))
- (curravg (/ (vector-ref cmd-dat 1) (vector-ref cmd-dat 0))) ;; count is never zero by construction
- (currmax (max res curravg))
- (newmax-cmd (if (> curravg res) cmd max-cmd)))
- (if (null? tal)
- (if (> tot 10)
- (cons newmax-cmd currmax)
- (cons 'none 0))
- (loop (car tal)(cdr tal) newmax-cmd currmax)))))))
- (mutex-unlock! *db-stats-mutex*)
- res))
-
-(define (rmt:open-qry-close-locally cmd run-id params #!key (remretries 5))
- (let* ((qry-is-write (not (member cmd api:read-only-queries)))
- (db-file-path (common:get-db-tmp-area)) ;; db:dbfile-path)) ;; 0))
- (dbstruct-local (db:setup #t)) ;; make-dbr:dbstruct path: dbdir local: #t)))
- (read-only (not (file-write-access? db-file-path)))
- (start (current-milliseconds))
- (resdat (if (not (and read-only qry-is-write))
- (let ((v (api:execute-requests dbstruct-local (vector (symbol->string cmd) params))))
- (handle-exceptions ;; there has been a long history of receiving strange errors from values returned by the client when things go wrong..
- exn ;; This is an attempt to detect that situation and recover gracefully
- (begin
- (debug:print 0 *default-log-port* "ERROR: bad data from server " v " message: " ((condition-property-accessor 'exn 'message) exn) ", exn=" exn)
- (vector #t '())) ;; should always get a vector but if something goes wrong return a dummy
- (if (and (vector? v)
- (> (vector-length v) 1))
- (let ((newvec (vector (vector-ref v 0)(vector-ref v 1))))
- newvec) ;; by copying the vector while inside the error handler we should force the detection of a corrupted record
- (vector #t '())))) ;; we could also check that the returned types are valid
- (vector #t '())))
- (success (vector-ref resdat 0))
- (res (vector-ref resdat 1))
- (duration (- (current-milliseconds) start)))
- (if (and read-only qry-is-write)
- (debug:print 0 *default-log-port* "ERROR: attempt to write to read-only database ignored. cmd=" cmd))
- (if (not success)
- (if (> remretries 0)
- (begin
- (debug:print-error 0 *default-log-port* "local query failed. Trying again.")
- (thread-sleep! (/ (random 5000) 1000)) ;; some random delay
- (rmt:open-qry-close-locally cmd run-id params remretries: (- remretries 1)))
- (begin
- (debug:print-error 0 *default-log-port* "too many retries in rmt:open-qry-close-locally, giving up")
- #f))
- (begin
- ;; (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-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))
- (res (handle-exceptions
- exn
- (begin
- (print "transport failed. exn=" exn)
- #f)
- (http-transport:client-api-send-receive run-id connection-info cmd params))))
- (if (and res (vector-ref res 0))
- (vector-ref res 1) ;;; YES!! THIS IS CORRECT!! CHANGE IT HERE, THEN CHANGE rmt:send-receive ALSO!!!
- #f)))
-
-;;======================================================================
-;;
-;; A C T U A L A P I C A L L S
-;;
-;;======================================================================
-
-;;======================================================================
-;; S E R V E R
-;;======================================================================
-
-(define (rmt:kill-server run-id)
- (rmt:send-receive 'kill-server run-id (list run-id)))
-
-(define (rmt:start-server run-id)
- (rmt:send-receive 'start-server 0 (list run-id)))
-
-;;======================================================================
-;; M I S C
-;;======================================================================
-
-(define (rmt:login run-id)
- (assert *my-client-signature* "ERROR: login attempted without first calling (client:get-signature).")
- (rmt:send-receive 'login run-id (list *toppath* megatest-version *my-client-signature*)))
-
-;; This login does no retries under the hood - it acts a bit like a ping.
-;; Deprecated for nmsg-transport.
-;;
-(define (rmt:login-no-auto-client-setup connection-info)
- (case *transport-type* ;; run-id of 0 is just a placeholder
- ((http)(rmt:send-receive-no-auto-client-setup connection-info 'login 0 (list *toppath* megatest-version *my-client-signature*)))
- ;;((nmsg)(nmsg-transport:client-api-send-receive run-id connection-info 'login (list *toppath* megatest-version run-id *my-client-signature*)))
- ))
-
-;; hand off a call to one of the db:queries statements
-;; added run-id to make looking up the correct db possible
-;;
-(define (rmt:general-call stmtname run-id . params)
- (rmt:send-receive 'general-call run-id (append (list stmtname run-id) params)))
-
-
-;; 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:sdb-qry qry val run-id)
- ;; add caching if qry is 'getid or 'getstr
- (rmt:send-receive 'sdb-qry run-id (list qry val)))
-
-;; NOT COMPLETED
-(define (rmt:runtests user run-id testpatt params)
- (rmt:send-receive 'runtests run-id testpatt))
-
-(define (rmt:get-run-record-ids target run keynames test-patt)
- (rmt:send-receive 'get-run-record-ids #f (list target run keynames test-patt)))
-
-(define (rmt:get-changed-record-ids since-time)
- (rmt:send-receive 'get-changed-record-ids #f (list since-time)) )
-
-(define (rmt:drop-all-triggers)
- (rmt:send-receive 'drop-all-triggers #f '()))
-
-(define (rmt:create-all-triggers)
- (rmt:send-receive 'create-all-triggers #f '()))
-
-;;======================================================================
-;; T E S T M E T A
-;;======================================================================
-
-(define (rmt:get-tests-tags)
- (rmt:send-receive 'get-tests-tags #f '()))
-
-;;======================================================================
-;; K E Y S
-;;======================================================================
-
-;; These require run-id because the values come from the run!
-;;
-(define (rmt:get-key-val-pairs run-id)
- (rmt:send-receive 'get-key-val-pairs run-id (list run-id)))
-
-(define (rmt:get-keys)
- (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)
- (or (hash-table-ref/default *keyvals* run-id #f)
- (let ((res (rmt:send-receive 'get-key-vals #f (list run-id))))
- (hash-table-set! *keyvals* run-id res)
- res)))
-
-(define (rmt:get-targets)
- (rmt:send-receive 'get-targets #f '()))
-
-(define (rmt:get-target run-id)
- (rmt:send-receive 'get-target run-id (list run-id)))
-
-(define (rmt:get-run-times runpatt targetpatt)
- (rmt:send-receive 'get-run-times #f (list runpatt targetpatt )))
-
-
-;;======================================================================
-;; T E S T S
-;;======================================================================
-
-;; Just some syntatic sugar
-(define (rmt:register-test run-id test-name item-path)
- (rmt:general-call 'register-test run-id run-id test-name item-path))
-
-(define (rmt:get-test-id run-id testname item-path)
- (rmt:send-receive 'get-test-id run-id (list run-id testname item-path)))
-
-;; run-id is NOT used
-;;
-(define (rmt:get-test-info-by-id run-id test-id)
- (if (number? test-id)
- (rmt:send-receive 'get-test-info-by-id run-id (list run-id test-id))
- (begin
- (debug:print 0 *default-log-port* "WARNING: Bad data handed to rmt:get-test-info-by-id run-id=" run-id ", test-id=" test-id)
- (print-call-chain (current-error-port))
- #f)))
-
-(define (rmt:test-get-rundir-from-test-id run-id test-id)
- (rmt:send-receive 'test-get-rundir-from-test-id run-id (list run-id test-id)))
-
-(define (rmt:open-test-db-by-test-id run-id test-id #!key (work-area #f))
- (let* ((test-path (if (string? work-area)
- work-area
- (rmt:test-get-rundir-from-test-id run-id test-id))))
- (debug:print 3 *default-log-port* "TEST PATH: " test-path)
- (open-test-db test-path)))
-
-;; WARNING: This currently bypasses the transaction wrapped writes system
-(define (rmt:test-set-state-status-by-id run-id test-id newstate newstatus newcomment)
- (rmt:send-receive 'test-set-state-status-by-id run-id (list run-id test-id newstate newstatus newcomment)))
-
-(define (rmt:set-tests-state-status run-id testnames currstate currstatus newstate newstatus)
- (rmt:send-receive 'set-tests-state-status run-id (list run-id testnames currstate currstatus newstate newstatus)))
-
-(define (rmt:get-tests-for-run run-id testpatt states statuses offset limit not-in sort-by sort-order qryvals last-update mode)
- ;; (if (number? run-id)
- (rmt:send-receive 'get-tests-for-run run-id (list run-id testpatt states statuses offset limit not-in sort-by sort-order qryvals last-update mode)))
- ;; (begin
- ;; (debug:print-error 0 *default-log-port* "rmt:get-tests-for-run called with bad run-id=" run-id)
- ;; (print-call-chain (current-error-port))
- ;; '())))
-
-(define (rmt:get-tests-for-run-state-status run-id testpatt last-update)
- (rmt:send-receive 'get-tests-for-run-state-status run-id (list run-id testpatt last-update)))
-
-;; get stuff via synchash
-(define (rmt:synchash-get run-id proc synckey keynum params)
- (rmt:send-receive 'synchash-get run-id (list run-id proc synckey keynum params)))
-
-(define (rmt:get-tests-for-run-mindata run-id testpatt states status not-in)
- (rmt:send-receive 'get-tests-for-run-mindata run-id (list run-id testpatt states status not-in)))
-
-;; IDEA: Threadify these - they spend a lot of time waiting ...
-;;
-(define (rmt:get-tests-for-runs-mindata run-ids testpatt states status not-in)
- (let ((multi-run-mutex (make-mutex))
- (run-id-list (if run-ids
- run-ids
- (rmt:get-all-run-ids)))
- (result '()))
- (if (null? run-id-list)
- '()
- (let loop ((hed (car run-id-list))
- (tal (cdr run-id-list))
- (threads '()))
- (if (> (length threads) 5)
- (loop hed tal (filter (lambda (th)(not (member (thread-state th) '(terminated dead)))) threads))
- (let* ((newthread (make-thread
- (lambda ()
- (let ((res (rmt:send-receive 'get-tests-for-run-mindata hed (list hed testpatt states status not-in))))
- (if (list? res)
- (begin
- (mutex-lock! multi-run-mutex)
- (set! result (append result res))
- (mutex-unlock! multi-run-mutex))
- (debug:print-error 0 *default-log-port* "get-tests-for-run-mindata failed for run-id " hed ", testpatt " testpatt ", states " states ", status " status ", not-in " not-in))))
- (conc "multi-run-thread for run-id " hed)))
- (newthreads (cons newthread threads)))
- (thread-start! newthread)
- (thread-sleep! 0.05) ;; give that thread some time to start
- (if (null? tal)
- newthreads
- (loop (car tal)(cdr tal) newthreads))))))
- result))
-
-;; ;; IDEA: Threadify these - they spend a lot of time waiting ...
-;; ;;
-;; (define (rmt:get-tests-for-runs-mindata run-ids testpatt states status not-in)
-;; (let ((run-id-list (if run-ids
-;; run-ids
-;; (rmt:get-all-run-ids))))
-;; (apply append (map (lambda (run-id)
-;; (rmt:send-receive 'get-tests-for-run-mindata run-id (list run-ids testpatt states status not-in)))
-;; run-id-list))))
-
-(define (rmt:delete-test-records run-id test-id)
- (rmt:send-receive 'delete-test-records run-id (list run-id test-id)))
-
-(define (rmt:test-set-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)
-;; (rmt:send-receive 'get-previous-test-run-record run-id (list run-id test-name item-path)))
-
-(define (rmt:get-matching-previous-test-run-records run-id test-name item-path)
- (rmt:send-receive 'get-matching-previous-test-run-records run-id (list run-id test-name item-path)))
-
-(define (rmt:test-get-logfile-info run-id test-name)
- (rmt:send-receive 'test-get-logfile-info run-id (list run-id test-name)))
-
-(define (rmt:test-get-records-for-index-file run-id test-name)
- (rmt:send-receive 'test-get-records-for-index-file run-id (list run-id test-name)))
-
-(define (rmt:get-testinfo-state-status run-id test-id)
- (rmt:send-receive 'get-testinfo-state-status run-id (list run-id test-id)))
-
-(define (rmt:test-set-log! run-id test-id logf)
- (if (string? logf)(rmt:general-call 'test-set-log run-id logf test-id)))
-
-(define (rmt:test-set-top-process-pid run-id test-id pid)
- (rmt:send-receive 'test-set-top-process-pid run-id (list run-id test-id pid)))
-
-(define (rmt:test-get-top-process-pid run-id test-id)
- (rmt:send-receive 'test-get-top-process-pid run-id (list run-id test-id)))
-
-(define (rmt:get-run-ids-matching-target keynames target res runname testpatt statepatt statuspatt)
- (rmt:send-receive 'get-run-ids-matching-target #f (list keynames target res runname testpatt statepatt statuspatt)))
-
-;; NOTE: This will open and access ALL run databases.
-;;
-(define (rmt:test-get-paths-matching-keynames-target-new keynames target res testpatt statepatt statuspatt runname)
- (let ((run-ids (rmt:get-run-ids-matching-target keynames target res runname testpatt statepatt statuspatt)))
- (apply append
- (map (lambda (run-id)
- (rmt:send-receive 'test-get-paths-matching-keynames-target-new run-id (list run-id keynames target res testpatt statepatt statuspatt runname)))
- run-ids))))
-
-(define (rmt:get-prereqs-not-met run-id waitons ref-test-name ref-item-path #!key (mode '(normal))(itemmaps #f))
- (rmt:send-receive 'get-prereqs-not-met run-id (list run-id waitons ref-test-name ref-item-path mode itemmaps)))
-
-(define (rmt:get-count-tests-running-for-run-id run-id)
- (if (number? run-id)
- (rmt:send-receive 'get-count-tests-running-for-run-id run-id (list run-id))
- 0))
-
-(define (rmt:get-not-completed-cnt run-id)
- (rmt:send-receive 'get-not-completed-cnt run-id (list run-id)))
-
-
-;; Statistical queries
-
-(define (rmt:get-count-tests-running run-id)
- (rmt:send-receive 'get-count-tests-running run-id (list run-id)))
-
-(define (rmt:get-count-tests-running-for-testname run-id testname)
- (rmt:send-receive 'get-count-tests-running-for-testname run-id (list run-id testname)))
-
-(define (rmt:get-count-tests-running-in-jobgroup run-id jobgroup)
- (rmt:send-receive 'get-count-tests-running-in-jobgroup run-id (list run-id jobgroup)))
-
-;; state and status are extra hints not usually used in the calculation
-;;
-(define (rmt:set-state-status-and-roll-up-items run-id test-name item-path state status comment)
- (rmt:send-receive 'set-state-status-and-roll-up-items run-id (list run-id test-name item-path state status comment)))
-
-(define (rmt:set-state-status-and-roll-up-run run-id state status)
- (rmt:send-receive 'set-state-status-and-roll-up-run run-id (list run-id state status)))
-
-
-(define (rmt:update-pass-fail-counts run-id test-name)
- (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)
- (rmt:send-receive 'top-test-set-per-pf-counts run-id (list run-id test-name)))
-
-(define (rmt:get-raw-run-stats run-id)
- (rmt:send-receive 'get-raw-run-stats run-id (list run-id)))
-
-(define (rmt:get-test-times runname target)
- (rmt:send-receive 'get-test-times #f (list runname target )))
-
-;;======================================================================
-;; R U N S
-;;======================================================================
-
-(define (rmt:get-run-info run-id)
- (rmt:send-receive 'get-run-info run-id (list run-id)))
-
-(define (rmt:get-num-runs runpatt)
- (rmt:send-receive 'get-num-runs #f (list runpatt)))
-
-(define (rmt:get-runs-cnt-by-patt runpatt targetpatt keys)
- (rmt:send-receive 'get-runs-cnt-by-patt #f (list runpatt targetpatt keys)))
-
-;; Use the special run-id == #f scenario here since there is no run yet
-(define (rmt:register-run keyvals runname state status user contour)
- (rmt:send-receive 'register-run #f (list keyvals runname state status user contour)))
-
-(define (rmt:get-run-name-from-id run-id)
- (rmt:send-receive 'get-run-name-from-id run-id (list run-id)))
-
-(define (rmt:delete-run run-id)
- (rmt:send-receive 'delete-run run-id (list run-id)))
-
-(define (rmt:update-run-stats run-id stats)
- (rmt:send-receive 'update-run-stats #f (list run-id stats)))
-
-(define (rmt:delete-old-deleted-test-records)
- (rmt:send-receive 'delete-old-deleted-test-records #f '()))
-
-(define (rmt:get-runs runpatt count offset keypatts)
- (rmt:send-receive 'get-runs #f (list runpatt count offset keypatts)))
-
-(define (rmt:simple-get-runs runpatt count offset target last-update)
- (rmt:send-receive 'simple-get-runs #f (list runpatt count offset target last-update)))
-
-(define (rmt:get-all-run-ids)
- (rmt:send-receive 'get-all-run-ids #f '()))
-
-(define (rmt:get-prev-run-ids run-id)
- (rmt:send-receive 'get-prev-run-ids #f (list run-id)))
-
-(define (rmt:lock/unlock-run run-id lock unlock user)
- (rmt:send-receive 'lock/unlock-run #f (list run-id lock unlock user)))
-
-;; set/get status
-(define (rmt:get-run-status run-id)
- (rmt:send-receive 'get-run-status #f (list run-id)))
-
-(define (rmt:get-run-state run-id)
- (rmt:send-receive 'get-run-state #f (list run-id)))
-
-
-(define (rmt:set-run-status run-id run-status #!key (msg #f))
- (rmt:send-receive 'set-run-status #f (list run-id run-status msg)))
-
-(define (rmt:set-run-state-status run-id state status )
- (rmt:send-receive 'set-run-state-status #f (list run-id state status)))
-
-(define (rmt:update-tesdata-on-repilcate-db old-lt new-lt)
-(rmt:send-receive 'update-tesdata-on-repilcate-db #f (list old-lt new-lt)))
-
-(define (rmt:update-run-event_time run-id)
- (rmt:send-receive 'update-run-event_time #f (list run-id)))
-
-(define (rmt:get-runs-by-patt keys runnamepatt targpatt offset limit fields last-runs-update #!key (sort-order "asc")) ;; fields of #f uses default
- (rmt:send-receive 'get-runs-by-patt #f (list keys runnamepatt targpatt offset limit fields last-runs-update sort-order)))
-
-(define (rmt:find-and-mark-incomplete run-id ovr-deadtime)
- ;; (if (rmt:send-receive 'have-incompletes? run-id (list run-id ovr-deadtime))
- (rmt:send-receive 'mark-incomplete run-id (list run-id ovr-deadtime))) ;; )
-
-(define (rmt:get-main-run-stats run-id)
- (rmt:send-receive 'get-main-run-stats #f (list run-id)))
-
-(define (rmt:get-var varname)
- (rmt:send-receive 'get-var #f (list varname)))
-
-(define (rmt:del-var varname)
- (rmt:send-receive 'del-var #f (list varname)))
-
-(define (rmt:set-var varname value)
- (rmt:send-receive 'set-var #f (list varname value)))
-
-(define (rmt:inc-var varname)
- (rmt:send-receive 'inc-var #f (list varname)))
-
-(define (rmt:dec-var varname)
- (rmt:send-receive 'dec-var #f (list varname)))
-
-(define (rmt:add-var varname value)
- (rmt:send-receive 'add-var #f (list varname value)))
-
-;;======================================================================
-;; M U L T I R U N Q U E R I E S
-;;======================================================================
-
-;; Need to move this to multi-run section and make associated changes
-(define (rmt:find-and-mark-incomplete-all-runs #!key (ovr-deadtime #f))
- (let ((run-ids (rmt:get-all-run-ids)))
- (for-each (lambda (run-id)
- (rmt:find-and-mark-incomplete run-id ovr-deadtime))
- run-ids)))
-
-;; get the previous record for when this test was run where all keys match but runname
-;; returns #f if no such test found, returns a single test record if found
-;;
-;; Run this at the client end since we have to connect to multiple run-id dbs
-;;
-(define (rmt:get-previous-test-run-record run-id test-name item-path)
- (let* ((keyvals (rmt:get-key-val-pairs run-id))
- (keys (rmt:get-keys))
- (selstr (string-intersperse keys ","))
- (qrystr (string-intersperse (map (lambda (x)(conc x "=?")) keys) " AND ")))
- (if (not keyvals)
- #f
- (let ((prev-run-ids (rmt:get-prev-run-ids run-id)))
- ;; for each run starting with the most recent look to see if there is a matching test
- ;; if found then return that matching test record
- (debug:print 4 *default-log-port* "selstr: " selstr ", qrystr: " qrystr ", keyvals: " keyvals ", previous run ids found: " prev-run-ids)
- (if (null? prev-run-ids) #f
- (let loop ((hed (car prev-run-ids))
- (tal (cdr prev-run-ids)))
- (let ((results (rmt:get-tests-for-run hed (conc test-name "/" item-path) '() '() ;; run-id testpatt states statuses
- #f #f #f ;; offset limit not-in hide/not-hide
- #f #f #f #f 'normal))) ;; sort-by sort-order qryvals last-update mode
- (debug:print 4 *default-log-port* "Got tests for run-id " run-id ", test-name " test-name ", item-path " item-path ": " results)
- (if (and (null? results)
- (not (null? tal)))
- (loop (car tal)(cdr tal))
- (if (null? results) #f
- (car results))))))))))
-
-(define (rmt:get-run-stats)
- (rmt:send-receive 'get-run-stats #f '()))
-
-;;======================================================================
-;; S T E P S
-;;======================================================================
-
-;; Getting steps is more complicated.
-;;
-;; If given work area
-;; 1. Find the testdat.db file
-;; 2. Open the testdat.db file and do the query
-;; If not given the work area
-;; 1. Do a remote call to get the test path
-;; 2. Continue as above
-;;
-;;(define (rmt:get-steps-for-test run-id test-id)
-;; (rmt:send-receive 'get-steps-data run-id (list test-id)))
-
-(define (rmt:teststep-set-status! run-id test-id teststep-name state-in status-in comment logfile)
- (let* ((state (items:check-valid-items "state" state-in))
- (status (items:check-valid-items "status" status-in)))
- (if (or (not state)(not status))
- (debug:print 3 *default-log-port* "WARNING: Invalid " (if status "status" "state")
- " value \"" (if status state-in status-in) "\", update your validvalues section in megatest.config"))
- (rmt:send-receive 'teststep-set-status! run-id (list run-id test-id teststep-name state-in status-in comment logfile))))
-
-
-(define (rmt:delete-steps-for-test! run-id test-id)
- (rmt:send-receive 'delete-steps-for-test! run-id (list run-id test-id)))
-
-(define (rmt:get-steps-for-test run-id test-id)
- (rmt:send-receive 'get-steps-for-test run-id (list run-id test-id)))
-
-(define (rmt:get-steps-info-by-id test-step-id)
- (rmt:send-receive 'get-steps-info-by-id #f (list test-step-id)))
-
-;;======================================================================
-;; T E S T D A T A
-;;======================================================================
-
-(define (rmt:read-test-data run-id test-id categorypatt #!key (work-area #f))
- (rmt:send-receive 'read-test-data run-id (list run-id test-id categorypatt)))
-
-(define (rmt:read-test-data-varpatt run-id test-id categorypatt varpatt #!key (work-area #f))
- (rmt:send-receive 'read-test-data-varpatt run-id (list run-id test-id categorypatt varpatt)))
-
-(define (rmt:get-data-info-by-id test-data-id)
- (rmt:send-receive 'get-data-info-by-id #f (list test-data-id)))
-
-(define (rmt:testmeta-add-record testname)
- (rmt:send-receive 'testmeta-add-record #f (list testname)))
-
-(define (rmt:testmeta-get-record testname)
- (rmt:send-receive 'testmeta-get-record #f (list testname)))
-
-(define (rmt:testmeta-update-field test-name fld val)
- (rmt:send-receive 'testmeta-update-field #f (list test-name fld val)))
-
-(define (rmt:test-data-rollup run-id test-id status)
- (rmt:send-receive 'test-data-rollup run-id (list run-id test-id status)))
-
-(define (rmt:csv->test-data run-id test-id csvdata)
- (rmt:send-receive 'csv->test-data run-id (list run-id test-id csvdata)))
-
-;;======================================================================
-;; T A S K S
-;;======================================================================
-
-(define (rmt:tasks-find-task-queue-records target run-name test-patt state-patt action-patt)
- (rmt:send-receive 'find-task-queue-records #f (list target run-name test-patt state-patt action-patt)))
-
-(define (rmt:tasks-add action owner target runname testpatt params)
- (rmt:send-receive 'tasks-add #f (list action owner target runname testpatt params)))
-
-(define (rmt:tasks-set-state-given-param-key param-key new-state)
- (rmt:send-receive 'tasks-set-state-given-param-key #f (list param-key new-state)))
-
-(define (rmt:tasks-get-last target runname)
- (rmt:send-receive 'tasks-get-last #f (list target runname)))
-
-;;======================================================================
-;; N O S Y N C D B
-;;======================================================================
-
-(define (rmt:no-sync-set var val)
- (rmt:send-receive 'no-sync-set #f `(,var ,val)))
-
-(define (rmt:no-sync-get/default var default)
- (rmt:send-receive 'no-sync-get/default #f `(,var ,default)))
-
-(define (rmt:no-sync-del! var)
- (rmt:send-receive 'no-sync-del! #f `(,var)))
-
-(define (rmt:no-sync-get-lock keyname)
- (rmt:send-receive 'no-sync-get-lock #f `(,keyname)))
-
-;;======================================================================
-;; A R C H I V E S
-;;======================================================================
-
-(define (rmt:archive-get-allocations testname itempath dneeded)
- (rmt:send-receive 'archive-get-allocations #f (list testname itempath dneeded)))
-
-(define (rmt:archive-register-block-name bdisk-id archive-path)
- (rmt:send-receive 'archive-register-block-name #f (list bdisk-id archive-path)))
-
-(define (rmt:archive-allocate-testsuite/area-to-block block-id testsuite-name areakey)
- (rmt:send-receive 'archive-allocate-test-to-block #f (list block-id testsuite-name areakey)))
-
-(define (rmt:archive-register-disk bdisk-name bdisk-path df)
- (rmt:send-receive 'archive-register-disk #f (list bdisk-name bdisk-path df)))
-
-(define (rmt:test-set-archive-block-id run-id test-id archive-block-id)
- (rmt:send-receive 'test-set-archive-block-id run-id (list run-id test-id archive-block-id)))
-
-(define (rmt:test-get-archive-block-info archive-block-id)
- (rmt:send-receive 'test-get-archive-block-info #f (list archive-block-id)))
-
-(define (extras-readonly-mode rmt-mutex log-port cmd params)
- (mutex-unlock! rmt-mutex)
- (debug:print-info 12 log-port "rmt:send-receive, case 3")
- (debug:print 0 log-port "WARNING: write transaction requested on a readonly area. cmd="cmd" params="params)
- #f)
-
-(define (extras-transport-failed *default-log-port* *rmt-mutex* attemptnum runremote cmd rid params)
- (debug:print 0 *default-log-port* "WARNING: communication failed. Trying again, try num: " attemptnum)
- (mutex-lock! *rmt-mutex*)
- (remote-conndat-set! runremote #f)
- (http-transport:close-connections area-dat: runremote)
- (remote-server-url-set! runremote #f)
- (mutex-unlock! *rmt-mutex*)
- (debug:print-info 12 *default-log-port* "rmt:send-receive, case 9.1")
- (rmt:send-receive cmd rid params attemptnum: (+ attemptnum 1)))
-
-(define (extras-transport-succeded *default-log-port* *rmt-mutex* attemptnum runremote res params rid cmd)
- (if (and (vector? res)
- (eq? (vector-length res) 2)
- (eq? (vector-ref res 1) 'overloaded)) ;; since we are
- ;; looking at the
- ;; data to carry the
- ;; error we'll use a
- ;; fairly obtuse
- ;; combo to minimise
- ;; the chances of
- ;; some sort of
- ;; collision. this
- ;; is the case where
- ;; the returned data
- ;; is bad or the
- ;; server is
- ;; overloaded and we
- ;; want to ease off
- ;; the queries
- (let ((wait-delay (+ attemptnum (* attemptnum 10))))
- (debug:print 0 *default-log-port* "WARNING: server is overloaded. Delaying " wait-delay " seconds and trying call again.")
- (mutex-lock! *rmt-mutex*)
- (http-transport:close-connections area-dat: runremote)
- (set! *runremote* #f) ;; force starting over
- (mutex-unlock! *rmt-mutex*)
- (thread-sleep! wait-delay)
- (rmt:send-receive cmd rid params attemptnum: (+ attemptnum 1)))
- res)) ;; All good, return res
-
-#;(set-functions rmt:send-receive remote-server-url-set!
- http-transport:close-connections remote-conndat-set!
- debug:print debug:print-info
- remote-ro-mode remote-ro-mode-set!
- remote-ro-mode-checked-set! remote-ro-mode-checked)
Index: rmtmod.scm
==================================================================
--- rmtmod.scm
+++ rmtmod.scm
@@ -46,7 +46,1015 @@
(begin
(remote-ro-mode-set! runremote ro-mode)
(remote-ro-mode-checked-set! runremote #t)
ro-mode)
ro-mode))))
+
+;;
+;; THESE ARE ALL CALLED ON THE CLIENT SIDE!!!
+;;
+
+;; generate entries for ~/.megatestrc with the following
+;;
+;; grep define ../rmt.scm | grep rmt: |perl -pi -e 's/\(define\s+\((\S+)\W.*$/\1/'|sort -u
+
+;;======================================================================
+;; 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 areapath #!key (area-dat #f)) ;; TODO: push areapath down.
+ (let* ((runremote (or area-dat *runremote*))
+ (cinfo (if (remote? runremote)
+ (remote-conndat runremote)
+ #f)))
+ (if cinfo
+ cinfo
+ (if (server:check-if-running areapath)
+ (client:setup areapath)
+ #f))))
+
+;;======================================================================
+
+(define (create-remote-record)
+ (let ((rr (make-remote)))
+ (rmt:init-remote rr)
+ rr))
+
+(define (rmt:init-remote rr)
+ (remote-hh-dat-set! rr (common:get-homehost)) ;
+ (remote-server-info-set! rr (if *toppath* (server:check-if-running *toppath*) #f))
+ (remote-transport-set! rr *transport-type*)
+ (remote-server-timeout-set! rr (server:expiration-timeout))
+ rr)
+
+;; RA => e.g. usage (rmt:send-receive 'get-var #f (list varname))
+;;
+(define (rmt:send-receive cmd rid params #!key (attemptnum 1)(area-dat #f)) ;; start attemptnum at 1 so the modulo below works as expected
+
+ #;(common:telemetry-log (conc "rmt:"(->string cmd))
+ payload: `((rid . ,rid)
+ (params . ,params)))
+
+ (if (> attemptnum 2)
+ (debug:print 0 *default-log-port* "INFO: attemptnum in rmt:send-receive is " attemptnum))
+
+ (cond
+ ((> attemptnum 2) (thread-sleep! 0.05))
+ ((> attemptnum 10) (thread-sleep! 0.5))
+ ((> attemptnum 20) (thread-sleep! 1)))
+ (if (and (> attemptnum 5) (= 0 (modulo attemptnum 15)))
+ (begin (server:run *toppath*) (thread-sleep! 3)))
+
+
+ ;;DOT digraph megatest_state_status {
+ ;;DOT ranksep=0;
+ ;;DOT // rankdir=LR;
+ ;;DOT node [shape="box"];
+ ;;DOT "rmt:send-receive" -> MUTEXLOCK;
+ ;;DOT { edge [style=invis];"case 1" -> "case 2" -> "case 3" -> "case 4" -> "case 5" -> "case 6" -> "case 7" -> "case 8" -> "case 9" -> "case 10" -> "case 11"; }
+ ;; do all the prep locked under the rmt-mutex
+ (mutex-lock! *rmt-mutex*)
+
+ ;; set up runremote record earlier than the loop below
+ (if (not *runremote*) ;; can remove this one. should never get here.
+ (begin
+ (set! *runremote* (create-remote-record))
+ (let* ((server-info (remote-server-info *runremote*)))
+ (if server-info
+ (begin
+ (remote-server-url-set! *runremote* (server:record->url server-info))
+ (remote-server-id-set! *runremote* (server:record->id server-info)))))
+ #;(set! area-dat *runremote*))) ;; new runremote will come from this on next iteration
+
+ ;; 1. check if server is started IFF cmd is a write OR if we are not on the homehost, store in runremote
+ ;; 2. check the age of the connections. refresh the connection if it is older than timeout-20 seconds.
+ ;; 3. do the query, if on homehost use local access
+ ;;
+ (let* ((start-time (current-seconds)) ;; snapshot time so all use cases get same value
+ (areapath *toppath*);; TODO - resolve from dbstruct to be compatible with multiple areas
+ (runremote (or area-dat
+ *runremote*))
+ (attemptnum (+ 1 attemptnum))
+ (readonly-mode (rmtmod:calc-ro-mode runremote *toppath*)))
+
+ ;; DOT INIT_RUNREMOTE; // leaving off - doesn't really add to the clarity
+ ;; DOT MUTEXLOCK -> INIT_RUNREMOTE [label="no remote?"];
+ ;; DOT INIT_RUNREMOTE -> MUTEXLOCK;
+ ;; ensure we have a record for our connection for given area
+ ;; DOT SET_HOMEHOST; // leaving off - doesn't really add to the clarity
+ ;; DOT MUTEXLOCK -> SET_HOMEHOST [label="no homehost?"];
+ ;; DOT SET_HOMEHOST -> MUTEXLOCK;
+ ;; ensure we have a homehost record
+ (if (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)))
+
+ ;;(print "BB> readonly-mode is "readonly-mode" dbfile is "dbfile)
+ (cond
+ ;;DOT EXIT;
+ ;;DOT MUTEXLOCK -> EXIT [label="> 15 attempts"]; {rank=same "case 1" "EXIT" }
+ ;; give up if more than 150 attempts
+ ((> attemptnum 150)
+ (debug:print 0 *default-log-port* "ERROR: 150 tries to start/connect to server. Giving up.")
+ (exit 1))
+
+ ;;DOT CASE2 [label="local\nreadonly\nquery"];
+ ;;DOT MUTEXLOCK -> CASE2; {rank=same "case 2" CASE2}
+ ;;DOT CASE2 -> "rmt:open-qry-close-locally";
+ ;; readonly mode, read request- handle it - case 2
+ ((and readonly-mode
+ (member cmd api:read-only-queries))
+ (mutex-unlock! *rmt-mutex*)
+ (debug:print-info 12 *default-log-port* "rmt:send-receive, case 2")
+ (rmt:open-qry-close-locally cmd 0 params)
+ )
+
+ ;;DOT CASE3 [label="write in\nread-only mode"];
+ ;;DOT MUTEXLOCK -> CASE3 [label="readonly\nmode?"]; {rank=same "case 3" CASE3}
+ ;;DOT CASE3 -> "#f";
+ ;; readonly mode, write request. Do nothing, return #f
+ (readonly-mode (extras-readonly-mode *rmt-mutex* *default-log-port* cmd params))
+
+ ;; This block was for pre-emptively resetting the connection if there had been no communication for some time.
+ ;; I don't think it adds any value. If the server is not there, just fail and start a new connection.
+ ;; also, the expire-time calculation might not be correct. We want, time-since-last-server-access > (server:get-timeout)
+ ;;
+ ;;DOT CASE4 [label="reset\nconnection"];
+ ;;DOT MUTEXLOCK -> CASE4 [label="have connection,\nlast_access > expire_time"]; {rank=same "case 4" CASE4}
+ ;;DOT CASE4 -> "rmt:send-receive";
+ ;; reset the connection if it has been unused too long
+ ((and runremote
+ (remote-conndat runremote)
+ (> (current-seconds) ;; if it has been more than server-timeout seconds since last contact, close this connection and start a new on
+ (+ (http-transport:server-dat-get-last-access (remote-conndat runremote))
+ (remote-server-timeout runremote))))
+ (debug:print-info 0 *default-log-port* "Connection to " (remote-server-url runremote) " expired due to no accesses, forcing new connection.")
+ (http-transport:close-connections area-dat: runremote)
+ (remote-conndat-set! runremote #f) ;; invalidate the connection, thus forcing a new connection.
+ (mutex-unlock! *rmt-mutex*)
+ (rmt:send-receive cmd rid params attemptnum: attemptnum))
+
+ ;;DOT CASE5 [label="local\nread"];
+ ;;DOT MUTEXLOCK -> CASE5 [label="server not required,\non homehost,\nread-only query"]; {rank=same "case 5" CASE5};
+ ;;DOT CASE5 -> "rmt:open-qry-close-locally";
+
+ ;; on homehost and this is a read
+ ((and (not (remote-force-server runremote)) ;; honor forced use of server, i.e. server NOT required
+ (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 5")
+ (rmt:open-qry-close-locally cmd 0 params))
+
+ ;;DOT CASE6 [label="init\nremote"];
+ ;;DOT MUTEXLOCK -> CASE6 [label="on homehost,\nwrite query,\nhave server,\ncan't reach it"]; {rank=same "case 6" CASE6};
+ ;;DOT CASE6 -> "rmt:send-receive";
+ ;; 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:ping (remote-server-url runremote) (remote-server-id runremote)))) ;; server has died. NOTE: this is not a cheap call! Need better approach.
+ (set! *runremote* (create-remote-record))
+ (let* ((server-info (remote-server-info *runremote*)))
+ (if server-info
+ (begin
+ (remote-server-url-set! *runremote* (server:record->url server-info))
+ (remote-server-id-set! *runremote* (server:record->id server-info)))))
+ (remote-force-server-set! runremote (common:force-server?))
+ (mutex-unlock! *rmt-mutex*)
+ (debug:print-info 12 *default-log-port* "rmt:send-receive, case 6")
+ (rmt:send-receive cmd rid params attemptnum: attemptnum))
+
+ ;;DOT CASE7 [label="homehost\nwrite"];
+ ;;DOT MUTEXLOCK -> CASE7 [label="server not required,\non homehost,\na write,\nhave a server"]; {rank=same "case 7" CASE7};
+ ;;DOT CASE7 -> "rmt:open-qry-close-locally";
+ ;; on homehost and this is a write, we already have a server
+ ((and (not (remote-force-server runremote)) ;; honor forced use of server, i.e. server NOT required
+ (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.1")
+ (rmt:open-qry-close-locally cmd 0 params))
+
+ ;;DOT CASE8 [label="force\nserver"];
+ ;;DOT MUTEXLOCK -> CASE8 [label="server not required,\nhave homehost info,\nno connection yet,\nnot a read-only query"]; {rank=same "case 8" CASE8};
+ ;;DOT CASE8 -> "rmt:open-qry-close-locally";
+ ;; on homehost, no server contact made and this is a write, passively start a server
+ ((and (not (remote-force-server runremote)) ;; honor forced use of server, i.e. server NOT required
+ (cdr (remote-hh-dat runremote)) ;; have homehost
+ (not (remote-server-url runremote)) ;; no connection yet
+ (not (member cmd api:read-only-queries))) ;; not a read-only query
+ (debug:print-info 12 *default-log-port* "rmt:send-receive, case 8")
+ (let ((server-info (server:check-if-running *toppath*))) ;; (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-info
+ (begin
+ (remote-server-url-set! runremote (server:record->url server-info)) ;; the string can be consumed by the client setup if needed
+ (remote-server-id-set! runremote (server:record->id server-info)))
+ (if (common:force-server?)
+ (server:start-and-wait *toppath*)
+ (server:kind-run *toppath*)))
+ (remote-force-server-set! runremote (common:force-server?))
+ (mutex-unlock! *rmt-mutex*)
+ (debug:print-info 12 *default-log-port* "rmt:send-receive, case 8.1")
+ (rmt:open-qry-close-locally cmd 0 params)))
+
+ ;;DOT CASE9 [label="force server\nnot on homehost"];
+ ;;DOT MUTEXLOCK -> CASE9 [label="no connection\nand either require server\nor not on homehost"]; {rank=same "case 9" CASE9};
+ ;;DOT CASE9 -> "start\nserver" -> "rmt:send-receive";
+ ((or (and (remote-force-server runremote) ;; we are forcing a server and don't yet have a connection to one
+ (not (remote-conndat runremote)))
+ (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 9, hh-dat: " (remote-hh-dat runremote) " conndat: " (remote-conndat runremote))
+ (mutex-unlock! *rmt-mutex*)
+ (if (not (server:check-if-running *toppath*)) ;; who knows, maybe one has started up?
+ (server:start-and-wait *toppath*))
+ (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
+
+ ;;DOT CASE10 [label="on homehost"];
+ ;;DOT MUTEXLOCK -> CASE10 [label="server not required,\non homehost"]; {rank=same "case 10" CASE10};
+ ;;DOT CASE10 -> "rmt:open-qry-close-locally";
+ ;; all set up if get this far, dispatch the query
+ ((and (not (remote-force-server runremote))
+ (cdr (remote-hh-dat runremote))) ;; we are on homehost
+ (mutex-unlock! *rmt-mutex*)
+ (debug:print-info 12 *default-log-port* "rmt:send-receive, case 10")
+ (rmt:open-qry-close-locally cmd (if rid rid 0) params))
+
+ ;;DOT CASE11 [label="send_receive"];
+ ;;DOT MUTEXLOCK -> CASE11 [label="else"]; {rank=same "case 11" CASE11};
+ ;;DOT CASE11 -> "rmt:send-receive" [label="call failed"];
+ ;;DOT CASE11 -> "RESULT" [label="call succeeded"];
+ ;; not on homehost, do server query
+ (else (extras-case-11 *default-log-port* runremote cmd params attemptnum rid)))))
+ ;;DOT }
+
+;; bunch of small functions factored out of send-receive to make debug easier
+;;
+
+(define (extras-case-11 *default-log-port* runremote cmd params attemptnum rid)
+ ;; (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-in (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)
+ ((servermismatch) (vector #f "Server id mismatch" ))
+ ((commfail)(vector #f "communications fail"))
+ ((exn)(vector #f "other fail" (print-call-chain)))))
+ (else
+ (debug:print 0 *default-log-port* "ERROR: transport " (remote-transport runremote) " not supported")
+ (exit))))
+
+;; No Title
+;; Error: (vector-ref) out of range
+;; #(# (#("db.scm:3740: regex#regexp" #f #f) #("db.scm:3739: regex#string-substitute" #f #f) #("db.scm:3738: base64#base64-decode" #f #f) #("db.scm:3737: z3#z3:decode-buffer" #f #f) #("db.scm:3736: with-input-from-string" #f #f) #("db.scm:3741: s11n#deserialize" #f #f) #("api.scm:374: api:execute-requests" #f #f) #("api.scm:139: call-with-current-continuation" #f #f) #("api.scm:139: with-exception-handler" #f #f) #("api.scm:139: ##sys#call-with-values" #f #f) #("api.scm:158: string->symbol" #f #f) #("api.scm:160: current-milliseconds" #f #f) #("api.scm:161: dbr:dbstruct-read-only" #f #f) #("api.scm:139: k15" #f #f) #("api.scm:139: g19" #f #f) #("api.scm:142: get-call-chain" #f #f)) #("get-test-info-by-id" (1102 507299)))
+;; 6
+;;
+;; Call history:
+;;
+;; http-transport.scm:306: thread-terminate!
+;; http-transport.scm:307: debug:print-info
+;; common_records.scm:235: debug:debug-mode
+;; rmt.scm:259: k587
+;; rmt.scm:259: g591
+;; rmt.scm:276: http-transport:server-dat-update-last-access
+;; http-transport.scm:364: current-seconds
+;; rmt.scm:282: debug:print-info
+;; common_records.scm:235: debug:debug-mode
+;; rmt.scm:283: mutex-unlock!
+;; rmt.scm:287: extras-transport-succeded <--
+;; +-----------------------------------------------------------------------------+
+;; | Exit Status : 70
+;;
+
+ (dat (if (and (vector? dat-in) ;; ... check it is a correct size
+ (> (vector-length dat-in) 1))
+ dat-in
+ (vector #f (conc "communications fail (type 2), dat-in=" dat-in))))
+ (success (if (vector? dat) (vector-ref dat 0) #f))
+ (res (if (vector? dat) (vector-ref dat 1) #f)))
+ (if (and (vector? conninfo) (< 5 (vector-length conninfo)))
+ (http-transport:server-dat-update-last-access conninfo) ;; refresh access time
+ (begin
+ (debug:print 0 *default-log-port* "INFO: Should not get here! conninfo=" conninfo)
+ (set! conninfo #f)
+ (remote-conndat-set! *runremote* #f) ;; NOTE: *runremote* is global copy of runremote. Purpose: factor out global.
+ (http-transport:close-connections area-dat: runremote)))
+ (debug:print-info 13 *default-log-port* "rmt:send-receive, case 9. conninfo=" conninfo " dat=" dat " runremote = " runremote)
+ (mutex-unlock! *rmt-mutex*)
+ (if success ;; success only tells us that the transport was
+ ;; successful, have to examine the data to see if
+ ;; there was a detected issue at the other end
+ (extras-transport-succeded *default-log-port* *rmt-mutex* attemptnum runremote res params rid cmd)
+ (begin
+ (debug:print-error 0 *default-log-port* " dat=" dat)
+ (extras-transport-failed *default-log-port* *rmt-mutex* attemptnum runremote cmd rid params))
+ )))
+
+(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"))
+ (for-each (lambda (cmd)
+ (let ((cmd-dat (hash-table-ref *db-stats* cmd)))
+ (debug:print 18 *default-log-port* (format #f fmtstr cmd (vector-ref cmd-dat 0) (vector-ref cmd-dat 1) (/ (vector-ref cmd-dat 1)(vector-ref cmd-dat 0))))))
+ (sort (hash-table-keys *db-stats*)
+ (lambda (a b)
+ (> (vector-ref (hash-table-ref *db-stats* a) 0)
+ (vector-ref (hash-table-ref *db-stats* b) 0)))))))
+
+(define (rmt:get-max-query-average run-id)
+ (mutex-lock! *db-stats-mutex*)
+ (let* ((runkey (conc "run-id=" run-id " "))
+ (cmds (filter (lambda (x)
+ (substring-index runkey x))
+ (hash-table-keys *db-stats*)))
+ (res (if (null? cmds)
+ (cons 'none 0)
+ (let loop ((cmd (car cmds))
+ (tal (cdr cmds))
+ (max-cmd (car cmds))
+ (res 0))
+ (let* ((cmd-dat (hash-table-ref *db-stats* cmd))
+ (tot (vector-ref cmd-dat 0))
+ (curravg (/ (vector-ref cmd-dat 1) (vector-ref cmd-dat 0))) ;; count is never zero by construction
+ (currmax (max res curravg))
+ (newmax-cmd (if (> curravg res) cmd max-cmd)))
+ (if (null? tal)
+ (if (> tot 10)
+ (cons newmax-cmd currmax)
+ (cons 'none 0))
+ (loop (car tal)(cdr tal) newmax-cmd currmax)))))))
+ (mutex-unlock! *db-stats-mutex*)
+ res))
+
+(define (rmt:open-qry-close-locally cmd run-id params #!key (remretries 5))
+ (let* ((qry-is-write (not (member cmd api:read-only-queries)))
+ (db-file-path (common:get-db-tmp-area)) ;; db:dbfile-path)) ;; 0))
+ (dbstruct-local (db:setup #t)) ;; make-dbr:dbstruct path: dbdir local: #t)))
+ (read-only (not (file-write-access? db-file-path)))
+ (start (current-milliseconds))
+ (resdat (if (not (and read-only qry-is-write))
+ (let ((v (api:execute-requests dbstruct-local (vector (symbol->string cmd) params))))
+ (handle-exceptions ;; there has been a long history of receiving strange errors from values returned by the client when things go wrong..
+ exn ;; This is an attempt to detect that situation and recover gracefully
+ (begin
+ (debug:print 0 *default-log-port* "ERROR: bad data from server " v " message: " ((condition-property-accessor 'exn 'message) exn) ", exn=" exn)
+ (vector #t '())) ;; should always get a vector but if something goes wrong return a dummy
+ (if (and (vector? v)
+ (> (vector-length v) 1))
+ (let ((newvec (vector (vector-ref v 0)(vector-ref v 1))))
+ newvec) ;; by copying the vector while inside the error handler we should force the detection of a corrupted record
+ (vector #t '())))) ;; we could also check that the returned types are valid
+ (vector #t '())))
+ (success (vector-ref resdat 0))
+ (res (vector-ref resdat 1))
+ (duration (- (current-milliseconds) start)))
+ (if (and read-only qry-is-write)
+ (debug:print 0 *default-log-port* "ERROR: attempt to write to read-only database ignored. cmd=" cmd))
+ (if (not success)
+ (if (> remretries 0)
+ (begin
+ (debug:print-error 0 *default-log-port* "local query failed. Trying again.")
+ (thread-sleep! (/ (random 5000) 1000)) ;; some random delay
+ (rmt:open-qry-close-locally cmd run-id params remretries: (- remretries 1)))
+ (begin
+ (debug:print-error 0 *default-log-port* "too many retries in rmt:open-qry-close-locally, giving up")
+ #f))
+ (begin
+ ;; (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-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))
+ (res (handle-exceptions
+ exn
+ (begin
+ (print "transport failed. exn=" exn)
+ #f)
+ (http-transport:client-api-send-receive run-id connection-info cmd params))))
+ (if (and res (vector-ref res 0))
+ (vector-ref res 1) ;;; YES!! THIS IS CORRECT!! CHANGE IT HERE, THEN CHANGE rmt:send-receive ALSO!!!
+ #f)))
+
+;;======================================================================
+;;
+;; A C T U A L A P I C A L L S
+;;
+;;======================================================================
+
+;;======================================================================
+;; S E R V E R
+;;======================================================================
+
+(define (rmt:kill-server run-id)
+ (rmt:send-receive 'kill-server run-id (list run-id)))
+
+(define (rmt:start-server run-id)
+ (rmt:send-receive 'start-server 0 (list run-id)))
+
+;;======================================================================
+;; M I S C
+;;======================================================================
+
+(define (rmt:login run-id)
+ (assert *my-client-signature* "ERROR: login attempted without first calling (client:get-signature).")
+ (rmt:send-receive 'login run-id (list *toppath* megatest-version *my-client-signature*)))
+
+;; This login does no retries under the hood - it acts a bit like a ping.
+;; Deprecated for nmsg-transport.
+;;
+(define (rmt:login-no-auto-client-setup connection-info)
+ (case *transport-type* ;; run-id of 0 is just a placeholder
+ ((http)(rmt:send-receive-no-auto-client-setup connection-info 'login 0 (list *toppath* megatest-version *my-client-signature*)))
+ ;;((nmsg)(nmsg-transport:client-api-send-receive run-id connection-info 'login (list *toppath* megatest-version run-id *my-client-signature*)))
+ ))
+
+;; hand off a call to one of the db:queries statements
+;; added run-id to make looking up the correct db possible
+;;
+(define (rmt:general-call stmtname run-id . params)
+ (rmt:send-receive 'general-call run-id (append (list stmtname run-id) params)))
+
+
+;; 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:sdb-qry qry val run-id)
+ ;; add caching if qry is 'getid or 'getstr
+ (rmt:send-receive 'sdb-qry run-id (list qry val)))
+
+;; NOT COMPLETED
+(define (rmt:runtests user run-id testpatt params)
+ (rmt:send-receive 'runtests run-id testpatt))
+
+(define (rmt:get-run-record-ids target run keynames test-patt)
+ (rmt:send-receive 'get-run-record-ids #f (list target run keynames test-patt)))
+
+(define (rmt:get-changed-record-ids since-time)
+ (rmt:send-receive 'get-changed-record-ids #f (list since-time)) )
+
+(define (rmt:drop-all-triggers)
+ (rmt:send-receive 'drop-all-triggers #f '()))
+
+(define (rmt:create-all-triggers)
+ (rmt:send-receive 'create-all-triggers #f '()))
+
+;;======================================================================
+;; T E S T M E T A
+;;======================================================================
+
+(define (rmt:get-tests-tags)
+ (rmt:send-receive 'get-tests-tags #f '()))
+
+;;======================================================================
+;; K E Y S
+;;======================================================================
+
+;; These require run-id because the values come from the run!
+;;
+(define (rmt:get-key-val-pairs run-id)
+ (rmt:send-receive 'get-key-val-pairs run-id (list run-id)))
+
+(define (rmt:get-keys)
+ (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)
+ (or (hash-table-ref/default *keyvals* run-id #f)
+ (let ((res (rmt:send-receive 'get-key-vals #f (list run-id))))
+ (hash-table-set! *keyvals* run-id res)
+ res)))
+
+(define (rmt:get-targets)
+ (rmt:send-receive 'get-targets #f '()))
+
+(define (rmt:get-target run-id)
+ (rmt:send-receive 'get-target run-id (list run-id)))
+
+(define (rmt:get-run-times runpatt targetpatt)
+ (rmt:send-receive 'get-run-times #f (list runpatt targetpatt )))
+
+
+;;======================================================================
+;; T E S T S
+;;======================================================================
+
+;; Just some syntatic sugar
+(define (rmt:register-test run-id test-name item-path)
+ (rmt:general-call 'register-test run-id run-id test-name item-path))
+
+(define (rmt:get-test-id run-id testname item-path)
+ (rmt:send-receive 'get-test-id run-id (list run-id testname item-path)))
+
+;; run-id is NOT used
+;;
+(define (rmt:get-test-info-by-id run-id test-id)
+ (if (number? test-id)
+ (rmt:send-receive 'get-test-info-by-id run-id (list run-id test-id))
+ (begin
+ (debug:print 0 *default-log-port* "WARNING: Bad data handed to rmt:get-test-info-by-id run-id=" run-id ", test-id=" test-id)
+ (print-call-chain (current-error-port))
+ #f)))
+
+(define (rmt:test-get-rundir-from-test-id run-id test-id)
+ (rmt:send-receive 'test-get-rundir-from-test-id run-id (list run-id test-id)))
+
+(define (rmt:open-test-db-by-test-id run-id test-id #!key (work-area #f))
+ (let* ((test-path (if (string? work-area)
+ work-area
+ (rmt:test-get-rundir-from-test-id run-id test-id))))
+ (debug:print 3 *default-log-port* "TEST PATH: " test-path)
+ (open-test-db test-path)))
+
+;; WARNING: This currently bypasses the transaction wrapped writes system
+(define (rmt:test-set-state-status-by-id run-id test-id newstate newstatus newcomment)
+ (rmt:send-receive 'test-set-state-status-by-id run-id (list run-id test-id newstate newstatus newcomment)))
+
+(define (rmt:set-tests-state-status run-id testnames currstate currstatus newstate newstatus)
+ (rmt:send-receive 'set-tests-state-status run-id (list run-id testnames currstate currstatus newstate newstatus)))
+
+(define (rmt:get-tests-for-run run-id testpatt states statuses offset limit not-in sort-by sort-order qryvals last-update mode)
+ ;; (if (number? run-id)
+ (rmt:send-receive 'get-tests-for-run run-id (list run-id testpatt states statuses offset limit not-in sort-by sort-order qryvals last-update mode)))
+ ;; (begin
+ ;; (debug:print-error 0 *default-log-port* "rmt:get-tests-for-run called with bad run-id=" run-id)
+ ;; (print-call-chain (current-error-port))
+ ;; '())))
+
+(define (rmt:get-tests-for-run-state-status run-id testpatt last-update)
+ (rmt:send-receive 'get-tests-for-run-state-status run-id (list run-id testpatt last-update)))
+
+;; get stuff via synchash
+(define (rmt:synchash-get run-id proc synckey keynum params)
+ (rmt:send-receive 'synchash-get run-id (list run-id proc synckey keynum params)))
+
+(define (rmt:get-tests-for-run-mindata run-id testpatt states status not-in)
+ (rmt:send-receive 'get-tests-for-run-mindata run-id (list run-id testpatt states status not-in)))
+
+;; IDEA: Threadify these - they spend a lot of time waiting ...
+;;
+(define (rmt:get-tests-for-runs-mindata run-ids testpatt states status not-in)
+ (let ((multi-run-mutex (make-mutex))
+ (run-id-list (if run-ids
+ run-ids
+ (rmt:get-all-run-ids)))
+ (result '()))
+ (if (null? run-id-list)
+ '()
+ (let loop ((hed (car run-id-list))
+ (tal (cdr run-id-list))
+ (threads '()))
+ (if (> (length threads) 5)
+ (loop hed tal (filter (lambda (th)(not (member (thread-state th) '(terminated dead)))) threads))
+ (let* ((newthread (make-thread
+ (lambda ()
+ (let ((res (rmt:send-receive 'get-tests-for-run-mindata hed (list hed testpatt states status not-in))))
+ (if (list? res)
+ (begin
+ (mutex-lock! multi-run-mutex)
+ (set! result (append result res))
+ (mutex-unlock! multi-run-mutex))
+ (debug:print-error 0 *default-log-port* "get-tests-for-run-mindata failed for run-id " hed ", testpatt " testpatt ", states " states ", status " status ", not-in " not-in))))
+ (conc "multi-run-thread for run-id " hed)))
+ (newthreads (cons newthread threads)))
+ (thread-start! newthread)
+ (thread-sleep! 0.05) ;; give that thread some time to start
+ (if (null? tal)
+ newthreads
+ (loop (car tal)(cdr tal) newthreads))))))
+ result))
+
+;; ;; IDEA: Threadify these - they spend a lot of time waiting ...
+;; ;;
+;; (define (rmt:get-tests-for-runs-mindata run-ids testpatt states status not-in)
+;; (let ((run-id-list (if run-ids
+;; run-ids
+;; (rmt:get-all-run-ids))))
+;; (apply append (map (lambda (run-id)
+;; (rmt:send-receive 'get-tests-for-run-mindata run-id (list run-ids testpatt states status not-in)))
+;; run-id-list))))
+
+(define (rmt:delete-test-records run-id test-id)
+ (rmt:send-receive 'delete-test-records run-id (list run-id test-id)))
+
+(define (rmt:test-set-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)
+;; (rmt:send-receive 'get-previous-test-run-record run-id (list run-id test-name item-path)))
+
+(define (rmt:get-matching-previous-test-run-records run-id test-name item-path)
+ (rmt:send-receive 'get-matching-previous-test-run-records run-id (list run-id test-name item-path)))
+
+(define (rmt:test-get-logfile-info run-id test-name)
+ (rmt:send-receive 'test-get-logfile-info run-id (list run-id test-name)))
+
+(define (rmt:test-get-records-for-index-file run-id test-name)
+ (rmt:send-receive 'test-get-records-for-index-file run-id (list run-id test-name)))
+
+(define (rmt:get-testinfo-state-status run-id test-id)
+ (rmt:send-receive 'get-testinfo-state-status run-id (list run-id test-id)))
+
+(define (rmt:test-set-log! run-id test-id logf)
+ (if (string? logf)(rmt:general-call 'test-set-log run-id logf test-id)))
+
+(define (rmt:test-set-top-process-pid run-id test-id pid)
+ (rmt:send-receive 'test-set-top-process-pid run-id (list run-id test-id pid)))
+
+(define (rmt:test-get-top-process-pid run-id test-id)
+ (rmt:send-receive 'test-get-top-process-pid run-id (list run-id test-id)))
+
+(define (rmt:get-run-ids-matching-target keynames target res runname testpatt statepatt statuspatt)
+ (rmt:send-receive 'get-run-ids-matching-target #f (list keynames target res runname testpatt statepatt statuspatt)))
+
+;; NOTE: This will open and access ALL run databases.
+;;
+(define (rmt:test-get-paths-matching-keynames-target-new keynames target res testpatt statepatt statuspatt runname)
+ (let ((run-ids (rmt:get-run-ids-matching-target keynames target res runname testpatt statepatt statuspatt)))
+ (apply append
+ (map (lambda (run-id)
+ (rmt:send-receive 'test-get-paths-matching-keynames-target-new run-id (list run-id keynames target res testpatt statepatt statuspatt runname)))
+ run-ids))))
+
+(define (rmt:get-prereqs-not-met run-id waitons ref-test-name ref-item-path #!key (mode '(normal))(itemmaps #f))
+ (rmt:send-receive 'get-prereqs-not-met run-id (list run-id waitons ref-test-name ref-item-path mode itemmaps)))
+
+(define (rmt:get-count-tests-running-for-run-id run-id)
+ (if (number? run-id)
+ (rmt:send-receive 'get-count-tests-running-for-run-id run-id (list run-id))
+ 0))
+
+(define (rmt:get-not-completed-cnt run-id)
+ (rmt:send-receive 'get-not-completed-cnt run-id (list run-id)))
+
+
+;; Statistical queries
+
+(define (rmt:get-count-tests-running run-id)
+ (rmt:send-receive 'get-count-tests-running run-id (list run-id)))
+
+(define (rmt:get-count-tests-running-for-testname run-id testname)
+ (rmt:send-receive 'get-count-tests-running-for-testname run-id (list run-id testname)))
+
+(define (rmt:get-count-tests-running-in-jobgroup run-id jobgroup)
+ (rmt:send-receive 'get-count-tests-running-in-jobgroup run-id (list run-id jobgroup)))
+
+;; state and status are extra hints not usually used in the calculation
+;;
+(define (rmt:set-state-status-and-roll-up-items run-id test-name item-path state status comment)
+ (rmt:send-receive 'set-state-status-and-roll-up-items run-id (list run-id test-name item-path state status comment)))
+
+(define (rmt:set-state-status-and-roll-up-run run-id state status)
+ (rmt:send-receive 'set-state-status-and-roll-up-run run-id (list run-id state status)))
+
+
+(define (rmt:update-pass-fail-counts run-id test-name)
+ (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)
+ (rmt:send-receive 'top-test-set-per-pf-counts run-id (list run-id test-name)))
+
+(define (rmt:get-raw-run-stats run-id)
+ (rmt:send-receive 'get-raw-run-stats run-id (list run-id)))
+
+(define (rmt:get-test-times runname target)
+ (rmt:send-receive 'get-test-times #f (list runname target )))
+
+;;======================================================================
+;; R U N S
+;;======================================================================
+
+(define (rmt:get-run-info run-id)
+ (rmt:send-receive 'get-run-info run-id (list run-id)))
+
+(define (rmt:get-num-runs runpatt)
+ (rmt:send-receive 'get-num-runs #f (list runpatt)))
+
+(define (rmt:get-runs-cnt-by-patt runpatt targetpatt keys)
+ (rmt:send-receive 'get-runs-cnt-by-patt #f (list runpatt targetpatt keys)))
+
+;; Use the special run-id == #f scenario here since there is no run yet
+(define (rmt:register-run keyvals runname state status user contour)
+ (rmt:send-receive 'register-run #f (list keyvals runname state status user contour)))
+
+(define (rmt:get-run-name-from-id run-id)
+ (rmt:send-receive 'get-run-name-from-id run-id (list run-id)))
+
+(define (rmt:delete-run run-id)
+ (rmt:send-receive 'delete-run run-id (list run-id)))
+
+(define (rmt:update-run-stats run-id stats)
+ (rmt:send-receive 'update-run-stats #f (list run-id stats)))
+
+(define (rmt:delete-old-deleted-test-records)
+ (rmt:send-receive 'delete-old-deleted-test-records #f '()))
+
+(define (rmt:get-runs runpatt count offset keypatts)
+ (rmt:send-receive 'get-runs #f (list runpatt count offset keypatts)))
+
+(define (rmt:simple-get-runs runpatt count offset target last-update)
+ (rmt:send-receive 'simple-get-runs #f (list runpatt count offset target last-update)))
+
+(define (rmt:get-all-run-ids)
+ (rmt:send-receive 'get-all-run-ids #f '()))
+
+(define (rmt:get-prev-run-ids run-id)
+ (rmt:send-receive 'get-prev-run-ids #f (list run-id)))
+
+(define (rmt:lock/unlock-run run-id lock unlock user)
+ (rmt:send-receive 'lock/unlock-run #f (list run-id lock unlock user)))
+
+;; set/get status
+(define (rmt:get-run-status run-id)
+ (rmt:send-receive 'get-run-status #f (list run-id)))
+
+(define (rmt:get-run-state run-id)
+ (rmt:send-receive 'get-run-state #f (list run-id)))
+
+
+(define (rmt:set-run-status run-id run-status #!key (msg #f))
+ (rmt:send-receive 'set-run-status #f (list run-id run-status msg)))
+
+(define (rmt:set-run-state-status run-id state status )
+ (rmt:send-receive 'set-run-state-status #f (list run-id state status)))
+
+(define (rmt:update-tesdata-on-repilcate-db old-lt new-lt)
+(rmt:send-receive 'update-tesdata-on-repilcate-db #f (list old-lt new-lt)))
+
+(define (rmt:update-run-event_time run-id)
+ (rmt:send-receive 'update-run-event_time #f (list run-id)))
+
+(define (rmt:get-runs-by-patt keys runnamepatt targpatt offset limit fields last-runs-update #!key (sort-order "asc")) ;; fields of #f uses default
+ (rmt:send-receive 'get-runs-by-patt #f (list keys runnamepatt targpatt offset limit fields last-runs-update sort-order)))
+
+(define (rmt:find-and-mark-incomplete run-id ovr-deadtime)
+ ;; (if (rmt:send-receive 'have-incompletes? run-id (list run-id ovr-deadtime))
+ (rmt:send-receive 'mark-incomplete run-id (list run-id ovr-deadtime))) ;; )
+
+(define (rmt:get-main-run-stats run-id)
+ (rmt:send-receive 'get-main-run-stats #f (list run-id)))
+
+(define (rmt:get-var varname)
+ (rmt:send-receive 'get-var #f (list varname)))
+
+(define (rmt:del-var varname)
+ (rmt:send-receive 'del-var #f (list varname)))
+
+(define (rmt:set-var varname value)
+ (rmt:send-receive 'set-var #f (list varname value)))
+
+(define (rmt:inc-var varname)
+ (rmt:send-receive 'inc-var #f (list varname)))
+
+(define (rmt:dec-var varname)
+ (rmt:send-receive 'dec-var #f (list varname)))
+
+(define (rmt:add-var varname value)
+ (rmt:send-receive 'add-var #f (list varname value)))
+
+;;======================================================================
+;; M U L T I R U N Q U E R I E S
+;;======================================================================
+
+;; Need to move this to multi-run section and make associated changes
+(define (rmt:find-and-mark-incomplete-all-runs #!key (ovr-deadtime #f))
+ (let ((run-ids (rmt:get-all-run-ids)))
+ (for-each (lambda (run-id)
+ (rmt:find-and-mark-incomplete run-id ovr-deadtime))
+ run-ids)))
+
+;; get the previous record for when this test was run where all keys match but runname
+;; returns #f if no such test found, returns a single test record if found
+;;
+;; Run this at the client end since we have to connect to multiple run-id dbs
+;;
+(define (rmt:get-previous-test-run-record run-id test-name item-path)
+ (let* ((keyvals (rmt:get-key-val-pairs run-id))
+ (keys (rmt:get-keys))
+ (selstr (string-intersperse keys ","))
+ (qrystr (string-intersperse (map (lambda (x)(conc x "=?")) keys) " AND ")))
+ (if (not keyvals)
+ #f
+ (let ((prev-run-ids (rmt:get-prev-run-ids run-id)))
+ ;; for each run starting with the most recent look to see if there is a matching test
+ ;; if found then return that matching test record
+ (debug:print 4 *default-log-port* "selstr: " selstr ", qrystr: " qrystr ", keyvals: " keyvals ", previous run ids found: " prev-run-ids)
+ (if (null? prev-run-ids) #f
+ (let loop ((hed (car prev-run-ids))
+ (tal (cdr prev-run-ids)))
+ (let ((results (rmt:get-tests-for-run hed (conc test-name "/" item-path) '() '() ;; run-id testpatt states statuses
+ #f #f #f ;; offset limit not-in hide/not-hide
+ #f #f #f #f 'normal))) ;; sort-by sort-order qryvals last-update mode
+ (debug:print 4 *default-log-port* "Got tests for run-id " run-id ", test-name " test-name ", item-path " item-path ": " results)
+ (if (and (null? results)
+ (not (null? tal)))
+ (loop (car tal)(cdr tal))
+ (if (null? results) #f
+ (car results))))))))))
+
+(define (rmt:get-run-stats)
+ (rmt:send-receive 'get-run-stats #f '()))
+
+;;======================================================================
+;; S T E P S
+;;======================================================================
+
+;; Getting steps is more complicated.
+;;
+;; If given work area
+;; 1. Find the testdat.db file
+;; 2. Open the testdat.db file and do the query
+;; If not given the work area
+;; 1. Do a remote call to get the test path
+;; 2. Continue as above
+;;
+;;(define (rmt:get-steps-for-test run-id test-id)
+;; (rmt:send-receive 'get-steps-data run-id (list test-id)))
+
+(define (rmt:teststep-set-status! run-id test-id teststep-name state-in status-in comment logfile)
+ (let* ((state (items:check-valid-items "state" state-in))
+ (status (items:check-valid-items "status" status-in)))
+ (if (or (not state)(not status))
+ (debug:print 3 *default-log-port* "WARNING: Invalid " (if status "status" "state")
+ " value \"" (if status state-in status-in) "\", update your validvalues section in megatest.config"))
+ (rmt:send-receive 'teststep-set-status! run-id (list run-id test-id teststep-name state-in status-in comment logfile))))
+
+
+(define (rmt:delete-steps-for-test! run-id test-id)
+ (rmt:send-receive 'delete-steps-for-test! run-id (list run-id test-id)))
+
+(define (rmt:get-steps-for-test run-id test-id)
+ (rmt:send-receive 'get-steps-for-test run-id (list run-id test-id)))
+
+(define (rmt:get-steps-info-by-id test-step-id)
+ (rmt:send-receive 'get-steps-info-by-id #f (list test-step-id)))
+
+;;======================================================================
+;; T E S T D A T A
+;;======================================================================
+
+(define (rmt:read-test-data run-id test-id categorypatt #!key (work-area #f))
+ (rmt:send-receive 'read-test-data run-id (list run-id test-id categorypatt)))
+
+(define (rmt:read-test-data-varpatt run-id test-id categorypatt varpatt #!key (work-area #f))
+ (rmt:send-receive 'read-test-data-varpatt run-id (list run-id test-id categorypatt varpatt)))
+
+(define (rmt:get-data-info-by-id test-data-id)
+ (rmt:send-receive 'get-data-info-by-id #f (list test-data-id)))
+
+(define (rmt:testmeta-add-record testname)
+ (rmt:send-receive 'testmeta-add-record #f (list testname)))
+
+(define (rmt:testmeta-get-record testname)
+ (rmt:send-receive 'testmeta-get-record #f (list testname)))
+
+(define (rmt:testmeta-update-field test-name fld val)
+ (rmt:send-receive 'testmeta-update-field #f (list test-name fld val)))
+
+(define (rmt:test-data-rollup run-id test-id status)
+ (rmt:send-receive 'test-data-rollup run-id (list run-id test-id status)))
+
+(define (rmt:csv->test-data run-id test-id csvdata)
+ (rmt:send-receive 'csv->test-data run-id (list run-id test-id csvdata)))
+
+;;======================================================================
+;; T A S K S
+;;======================================================================
+
+(define (rmt:tasks-find-task-queue-records target run-name test-patt state-patt action-patt)
+ (rmt:send-receive 'find-task-queue-records #f (list target run-name test-patt state-patt action-patt)))
+
+(define (rmt:tasks-add action owner target runname testpatt params)
+ (rmt:send-receive 'tasks-add #f (list action owner target runname testpatt params)))
+
+(define (rmt:tasks-set-state-given-param-key param-key new-state)
+ (rmt:send-receive 'tasks-set-state-given-param-key #f (list param-key new-state)))
+
+(define (rmt:tasks-get-last target runname)
+ (rmt:send-receive 'tasks-get-last #f (list target runname)))
+
+;;======================================================================
+;; N O S Y N C D B
+;;======================================================================
+
+(define (rmt:no-sync-set var val)
+ (rmt:send-receive 'no-sync-set #f `(,var ,val)))
+
+(define (rmt:no-sync-get/default var default)
+ (rmt:send-receive 'no-sync-get/default #f `(,var ,default)))
+
+(define (rmt:no-sync-del! var)
+ (rmt:send-receive 'no-sync-del! #f `(,var)))
+
+(define (rmt:no-sync-get-lock keyname)
+ (rmt:send-receive 'no-sync-get-lock #f `(,keyname)))
+
+;;======================================================================
+;; A R C H I V E S
+;;======================================================================
+
+(define (rmt:archive-get-allocations testname itempath dneeded)
+ (rmt:send-receive 'archive-get-allocations #f (list testname itempath dneeded)))
+
+(define (rmt:archive-register-block-name bdisk-id archive-path)
+ (rmt:send-receive 'archive-register-block-name #f (list bdisk-id archive-path)))
+
+(define (rmt:archive-allocate-testsuite/area-to-block block-id testsuite-name areakey)
+ (rmt:send-receive 'archive-allocate-test-to-block #f (list block-id testsuite-name areakey)))
+
+(define (rmt:archive-register-disk bdisk-name bdisk-path df)
+ (rmt:send-receive 'archive-register-disk #f (list bdisk-name bdisk-path df)))
+
+(define (rmt:test-set-archive-block-id run-id test-id archive-block-id)
+ (rmt:send-receive 'test-set-archive-block-id run-id (list run-id test-id archive-block-id)))
+
+(define (rmt:test-get-archive-block-info archive-block-id)
+ (rmt:send-receive 'test-get-archive-block-info #f (list archive-block-id)))
+
+(define (extras-readonly-mode rmt-mutex log-port cmd params)
+ (mutex-unlock! rmt-mutex)
+ (debug:print-info 12 log-port "rmt:send-receive, case 3")
+ (debug:print 0 log-port "WARNING: write transaction requested on a readonly area. cmd="cmd" params="params)
+ #f)
+
+(define (extras-transport-failed *default-log-port* *rmt-mutex* attemptnum runremote cmd rid params)
+ (debug:print 0 *default-log-port* "WARNING: communication failed. Trying again, try num: " attemptnum)
+ (mutex-lock! *rmt-mutex*)
+ (remote-conndat-set! runremote #f)
+ (http-transport:close-connections area-dat: runremote)
+ (remote-server-url-set! runremote #f)
+ (mutex-unlock! *rmt-mutex*)
+ (debug:print-info 12 *default-log-port* "rmt:send-receive, case 9.1")
+ (rmt:send-receive cmd rid params attemptnum: (+ attemptnum 1)))
+
+(define (extras-transport-succeded *default-log-port* *rmt-mutex* attemptnum runremote res params rid cmd)
+ (if (and (vector? res)
+ (eq? (vector-length res) 2)
+ (eq? (vector-ref res 1) 'overloaded)) ;; since we are
+ ;; looking at the
+ ;; data to carry the
+ ;; error we'll use a
+ ;; fairly obtuse
+ ;; combo to minimise
+ ;; the chances of
+ ;; some sort of
+ ;; collision. this
+ ;; is the case where
+ ;; the returned data
+ ;; is bad or the
+ ;; server is
+ ;; overloaded and we
+ ;; want to ease off
+ ;; the queries
+ (let ((wait-delay (+ attemptnum (* attemptnum 10))))
+ (debug:print 0 *default-log-port* "WARNING: server is overloaded. Delaying " wait-delay " seconds and trying call again.")
+ (mutex-lock! *rmt-mutex*)
+ (http-transport:close-connections area-dat: runremote)
+ (set! *runremote* #f) ;; force starting over
+ (mutex-unlock! *rmt-mutex*)
+ (thread-sleep! wait-delay)
+ (rmt:send-receive cmd rid params attemptnum: (+ attemptnum 1)))
+ res)) ;; All good, return res
+
+#;(set-functions rmt:send-receive remote-server-url-set!
+ http-transport:close-connections remote-conndat-set!
+ debug:print debug:print-info
+ remote-ro-mode remote-ro-mode-set!
+ remote-ro-mode-checked-set! remote-ro-mode-checked)
+
)
Index: runs.scm
==================================================================
--- runs.scm
+++ runs.scm
@@ -42,10 +42,13 @@
(import dbmod)
(declare (uses servermod))
(import servermod)
+(declare (uses margsmod))
+(import margsmod)
+
(include "common_records.scm")
(include "key_records.scm")
(include "db_records.scm")
(include "run_records.scm")
(include "test_records.scm")
@@ -3086,5 +3089,418 @@
(debug:print 0 *default-log-port* "WARNING: Failed to remove file " f ", exn=" exn)
(delete-file f)))
files))))
(debug:print-error 0 *default-log-port* "-clean-cache requires -runname."))
(debug:print-error 0 *default-log-port* "-clean-cache requires -target or -reqtarg")))
+
+
+;;======================================================================
+;; escaping dependecy challenges - moves some tasks stuff here
+;;======================================================================
+
+;; kill any runner processes (i.e. processes handling -runtests) that match target/runname
+;;
+;; do a remote call to get the task queue info but do the killing as self here.
+;;
+(define (tasks:kill-runner target run-name testpatt)
+ (let ((records (rmt:tasks-find-task-queue-records target run-name testpatt "running" "run-tests"))
+ (hostpid-rx (regexp "\\s+(\\w+)\\s+(\\d+)$"))) ;; host pid is at end of param string
+ (if (null? records)
+ (debug:print 0 *default-log-port* "No run launching processes found for " target " / " run-name " with testpatt " (or testpatt "* no testpatt specified! *"))
+ (debug:print 0 *default-log-port* "Found " (length records) " run(s) to kill."))
+ (for-each
+ (lambda (record)
+ (let* ((param-key (list-ref record 8))
+ (match-dat (string-search hostpid-rx param-key)))
+ (if match-dat
+ (let ((hostname (cadr match-dat))
+ (pid (string->number (caddr match-dat))))
+ (debug:print 0 *default-log-port* "Sending SIGINT to process " pid " on host " hostname)
+ (if (equal? (get-host-name) hostname)
+ (if (process:alive? pid)
+ (begin
+ (handle-exceptions
+ exn
+ (begin
+ (debug:print 0 *default-log-port* "Kill of process " pid " on host " hostname " failed.")
+ (debug:print 0 *default-log-port* " message: " ((condition-property-accessor 'exn 'message) exn))
+ #t)
+ (process-signal pid signal/int)
+ (thread-sleep! 5)
+ (if (process:alive? pid)
+ (process-signal pid signal/kill)))))
+ ;; (call-with-environment-variables
+ (let ((old-targethost (getenv "TARGETHOST")))
+ (setenv "TARGETHOST" hostname)
+ (setenv "TARGETHOST_LOGF" "server-kills.log")
+ (system (conc "nbfake kill " pid))
+ (if old-targethost (setenv "TARGETHOST" old-targethost))
+ (unsetenv "TARGETHOST")
+ (unsetenv "TARGETHOST_LOGF"))))
+ (debug:print-error 0 *default-log-port* "no record or improper record for " target "/" run-name " in tasks_queue in main.db"))))
+ records)))
+
+(define (task:get-run-times)
+ (let* (
+ (run-patt (if (args:get-arg "-run-patt")
+ (args:get-arg "-run-patt")
+ "%"))
+ (target-patt (if (args:get-arg "-target-patt")
+ (args:get-arg "-target-patt")
+ "%"))
+
+ (run-times (rmt:get-run-times run-patt target-patt )))
+ (if (eq? (length run-times) 0)
+ (begin
+ (print "Data not found!!")
+ (exit)))
+ (if (equal? (args:get-arg "-dumpmode") "json")
+ (task:print-runtime-as-json run-times)
+ (if (equal? (args:get-arg "-dumpmode") "csv")
+ (task:print-runtime run-times ",")
+ (task:print-runtime run-times " ")))))
+
+ (define (task:get-test-times)
+ (let* ((runname (if (args:get-arg "-runname")
+ (args:get-arg "-runname")
+ #f))
+ (target (if (args:get-arg "-target")
+ (args:get-arg "-target")
+ #f))
+
+ (test-times (rmt:get-test-times runname target )))
+ (if (not runname)
+ (begin
+ (print "Error: Missing argument -runname")
+ (exit)))
+ (if (string-contains runname "%")
+ (begin
+ (print "Error: Invalid runname, '%' not allowed (" runname ") ")
+ (exit)))
+ (if (not target)
+ (begin
+ (print "Error: Missing argument -target")
+ (exit)))
+ (if (string-contains target "%")
+ (begin
+ (print "Error: Invalid target, '%' not allowed (" target ") ")
+ (exit)))
+
+ (if (eq? (length test-times) 0)
+ (begin
+ (print "Data not found!!")
+ (exit)))
+ (if (equal? (args:get-arg "-dumpmode") "json")
+ (task:print-testtime-as-json test-times)
+ (if (equal? (args:get-arg "-dumpmode") "csv")
+ (task:print-testtime test-times ",")
+ (task:print-testtime test-times " ")))))
+
+
+;; gets mtpg-run-id and syncs the record if different
+;;
+(define (tasks:run-id->mtpg-run-id dbh cached-info run-id area-info smallest-last-update-time)
+ (let* ((runs-ht (hash-table-ref cached-info 'runs))
+ (runinf (hash-table-ref/default runs-ht run-id #f))
+ (area-id (vector-ref area-info 0)))
+ (if runinf
+ runinf ;; already cached
+ (let* ((run-dat (rmt:get-run-info run-id)) ;; NOTE: get-run-info returns a vector < row header >
+ (run-name (rmt:get-run-name-from-id run-id))
+ (row (db:get-rows run-dat)) ;; yes, this returns a single row
+ (header (db:get-header run-dat))
+ (state (db:get-value-by-header row header "state"))
+ (status (db:get-value-by-header row header "status"))
+ (owner (db:get-value-by-header row header "owner"))
+ (event-time (db:get-value-by-header row header "event_time"))
+ (comment (db:get-value-by-header row header "comment"))
+ (fail-count (db:get-value-by-header row header "fail_count"))
+ (pass-count (db:get-value-by-header row header "pass_count"))
+ (db-contour (db:get-value-by-header row header "contour"))
+ (contour (if (args:get-arg "-prepend-contour")
+ (if (and db-contour (not (equal? db-contour "")) (string? db-contour ))
+ (begin
+ (debug:print-info 10 *default-log-port* "db-contour" db-contour)
+ db-contour)
+ (args:get-arg "-contour"))))
+ (run-tag (if (args:get-arg "-run-tag")
+ (args:get-arg "-run-tag")
+ ""))
+ (last-update (db:get-value-by-header row header "last_update"))
+ (keytarg (if (or (args:get-arg "-prepend-contour") (args:get-arg "-prefix-target"))
+ (conc "MT_CONTOUR/MT_AREA/" (string-intersperse (rmt:get-keys) "/")) (string-intersperse (rmt:get-keys) "/"))) ;; e.g. version/iteration/platform
+ (base-target (rmt:get-target run-id))
+ (target (if (or (args:get-arg "-prepend-contour") (args:get-arg "-prefix-target"))
+ (conc (or (args:get-arg "-prefix-target") (conc contour "/" (common:get-area-name) "/")) base-target) base-target)) ;; e.g. v1.63/a3e1/ubuntu
+ (spec-id (pgdb:get-ttype dbh keytarg))
+ (publish-time (if (args:get-arg "-cp-eventtime-to-publishtime")
+ event-time
+ (current-seconds)))
+ (new-run-id (if (and run-name base-target) (pgdb:get-run-id dbh spec-id target run-name area-id) #f)))
+ (if new-run-id
+ (begin ;; let ((run-record (pgdb:get-run-info dbh new-run-id))
+ (hash-table-set! runs-ht run-id new-run-id)
+ ;; ensure key fields are up to date
+ ;; if last_update == pgdb_last_update do not update smallest-last-update-time
+ (let* ((pgdb-last-update (pgdb:get-run-last-update dbh new-run-id))
+ (smallest-time (hash-table-ref/default smallest-last-update-time "smallest-time" #f)))
+ (if (and (> last-update pgdb-last-update) (or (not smallest-time) (< last-update smallest-time)))
+ (hash-table-set! smallest-last-update-time "smallest-time" last-update)))
+ (pgdb:refresh-run-info
+ dbh
+ new-run-id
+ state status owner event-time comment fail-count pass-count area-id last-update publish-time)
+ (debug:print-info 4 *default-log-port* "Working on run-id " run-id " pgdb-id " new-run-id )
+ (if (not (equal? run-tag ""))
+ (task:add-run-tag dbh new-run-id run-tag))
+ new-run-id)
+
+ (if (or (not state) (equal? state "deleted"))
+ (begin
+ (debug:print-info 1 *default-log-port* "Warning: Run with id " run-id " was created after previous sync and deleted before the sync") #f)
+ (if (handle-exceptions
+ exn
+ (begin (print-call-chain)
+ (print ((condition-property-accessor 'exn 'message) exn))
+ #f)
+
+ (pgdb:insert-run
+ dbh
+ spec-id target run-name state status owner event-time comment fail-count pass-count area-id last-update publish-time))
+ (let* ((smallest-time (hash-table-ref/default smallest-last-update-time "smallest-time" #f)))
+ (if (or (not smallest-time) (< last-update smallest-time))
+ (hash-table-set! smallest-last-update-time "smallest-time" last-update))
+ (tasks:run-id->mtpg-run-id dbh cached-info run-id area-info smallest-last-update-time))
+ #f)))))))
+(define (tasks:sync-test-steps dbh cached-info test-step-ids smallest-last-update-time)
+ ; (print "Sync Steps " test-step-ids )
+ (let ((test-ht (hash-table-ref cached-info 'tests))
+ (step-ht (hash-table-ref cached-info 'steps)))
+ (for-each
+ (lambda (test-step-id)
+ (let* ((test-step-info (rmt:get-steps-info-by-id test-step-id))
+ (step-id (tdb:step-get-id test-step-info))
+ (test-id (tdb:step-get-test_id test-step-info))
+ (stepname (tdb:step-get-stepname test-step-info))
+ (state (tdb:step-get-state test-step-info))
+ (status (tdb:step-get-status test-step-info))
+ (event_time (tdb:step-get-event_time test-step-info))
+ (comment (tdb:step-get-comment test-step-info))
+ (logfile (tdb:step-get-logfile test-step-info))
+ (last-update (tdb:step-get-last_update test-step-info))
+ (pgdb-test-id (hash-table-ref/default test-ht test-id #f))
+ (smallest-time (hash-table-ref/default smallest-last-update-time "smallest-time" #f))
+ (pgdb-step-id (if pgdb-test-id
+ (pgdb:get-test-step-id dbh pgdb-test-id stepname state)
+ #f)))
+ (if step-id
+ (begin
+ (if pgdb-test-id
+ (begin
+ (if pgdb-step-id
+ (begin
+ (debug:print-info 4 *default-log-port* "Updating existing test-step with test-id: " test-id " and step-id " step-id " pgdb test id: " pgdb-test-id " pgdb step id " pgdb-step-id )
+ (let* ((pgdb-last-update (pgdb:get-test-step-last-update dbh pgdb-step-id)))
+ (if (and (> last-update pgdb-last-update) (or (not smallest-time) (< last-update smallest-time)))
+ (hash-table-set! smallest-last-update-time "smallest-time" last-update)))
+ (pgdb:update-test-step dbh pgdb-step-id pgdb-test-id stepname state status event_time comment logfile last-update))
+ (begin
+ (debug:print-info 4 *default-log-port* "Inserting test-step with test-id: " test-id " and step-id " step-id " pgdb test id: " pgdb-test-id)
+ (if (or (not smallest-time) (< last-update smallest-time))
+ (hash-table-set! smallest-last-update-time "smallest-time" last-update))
+ (pgdb:insert-test-step dbh pgdb-test-id stepname state status event_time comment logfile last-update )
+ (set! pgdb-step-id (pgdb:get-test-step-id dbh pgdb-test-id stepname state))))
+ (hash-table-set! step-ht step-id pgdb-step-id ))
+ (debug:print-info 1 *default-log-port* "Error: Test not cashed")))
+ (debug:print-info 1 *default-log-port* "Error: Could not get test step info for step id " test-step-id )))) ;; this is a wierd senario need to debug
+ test-step-ids)))
+
+(define (tasks:sync-test-gen-data dbh cached-info test-data-ids smallest-last-update-time)
+ (let ((test-ht (hash-table-ref cached-info 'tests))
+ (data-ht (hash-table-ref cached-info 'data)))
+ (for-each
+ (lambda (test-data-id)
+ (let* ((test-data-info (rmt:get-data-info-by-id test-data-id))
+ (data-id (db:test-data-get-id test-data-info))
+ (test-id (db:test-data-get-test_id test-data-info))
+ (category (db:test-data-get-category test-data-info))
+ (variable (db:test-data-get-variable test-data-info))
+ (value (db:test-data-get-value test-data-info))
+ (expected (db:test-data-get-expected test-data-info))
+ (tol (db:test-data-get-tol test-data-info))
+ (units (db:test-data-get-units test-data-info))
+ (comment (db:test-data-get-comment test-data-info))
+ (status (db:test-data-get-status test-data-info))
+ (type (db:test-data-get-type test-data-info))
+ (last-update (db:test-data-get-last_update test-data-info))
+ (smallest-time (hash-table-ref/default smallest-last-update-time "smallest-time" #f))
+
+ (pgdb-test-id (hash-table-ref/default test-ht test-id #f))
+ (pgdb-data-id (if pgdb-test-id
+ (pgdb:get-test-data-id dbh pgdb-test-id category variable)
+ #f)))
+ (if data-id
+ (begin
+ (if pgdb-test-id
+ (begin
+ (if pgdb-data-id
+ (begin
+ (debug:print-info 4 *default-log-port* "Updating existing test-data with test-id: " test-id " and data-id " data-id " pgdb test id: " pgdb-test-id " pgdb data id " pgdb-data-id)
+ (let* ((pgdb-last-update (pgdb:get-test-data-last-update dbh pgdb-data-id)))
+ (if (and (> last-update pgdb-last-update) (or (not smallest-time) (< last-update smallest-time)))
+ (hash-table-set! smallest-last-update-time "smallest-time" last-update)))
+ (pgdb:update-test-data dbh pgdb-data-id pgdb-test-id category variable value expected tol units comment status type last-update))
+ (begin
+ (debug:print-info 4 *default-log-port* "Inserting test-data with test-id: " test-id " and data-id " data-id " pgdb test id: " pgdb-test-id)
+ (if (handle-exceptions
+ exn
+ (begin (print-call-chain)
+ (print ((condition-property-accessor 'exn 'message) exn))
+ #f)
+
+ (pgdb:insert-test-data dbh pgdb-test-id category variable value expected tol units comment status type last-update))
+ ;(tasks:run-id->mtpg-run-id dbh cached-info run-id area-info)
+ (begin
+ ;(pgdb:insert-test-data dbh pgdb-test-id category variable value expected tol units comment status type )
+ (if (or (not smallest-time) (< last-update smallest-time))
+ (hash-table-set! smallest-last-update-time "smallest-time" last-update))
+ (set! pgdb-data-id (pgdb:get-test-data-id dbh pgdb-test-id category variable)))
+ #f)))
+ (hash-table-set! data-ht data-id pgdb-data-id ))
+ (begin
+ (debug:print-info 1 *default-log-port* "Error: Test not in pgdb"))))
+
+ (debug:print-info 1 *default-log-port* "Error: Could not get test data info for data id " test-data-id )))) ;; this is a wierd senario need to debug
+ test-data-ids)))
+
+
+
+(define (tasks:sync-tests-data dbh cached-info test-ids area-info smallest-last-update-time)
+ (let ((test-ht (hash-table-ref cached-info 'tests)))
+ (for-each
+ (lambda (test-id)
+ ; (print test-id)
+ (let* ((test-info (rmt:get-test-info-by-id #f test-id))
+ (run-id (db:test-get-run_id test-info)) ;; look these up in db_records.scm
+ (test-id (db:test-get-id test-info))
+ (test-name (db:test-get-testname test-info))
+ (item-path (db:test-get-item-path test-info))
+ (state (db:test-get-state test-info))
+ (status (db:test-get-status test-info))
+ (host (db:test-get-host test-info))
+ (pid (db:test-get-process_id test-info))
+ (cpuload (db:test-get-cpuload test-info))
+ (diskfree (db:test-get-diskfree test-info))
+ (uname (db:test-get-uname test-info))
+ (run-dir (db:test-get-rundir test-info))
+ (log-file (db:test-get-final_logf test-info))
+ (run-duration (db:test-get-run_duration test-info))
+ (comment (db:test-get-comment test-info))
+ (event-time (db:test-get-event_time test-info))
+ (archived (db:test-get-archived test-info))
+ (last-update (db:test-get-last_update test-info))
+ (pgdb-run-id (tasks:run-id->mtpg-run-id dbh cached-info run-id area-info smallest-last-update-time))
+ (smallest-time (hash-table-ref/default smallest-last-update-time "smallest-time" #f))
+ (pgdb-test-id (if pgdb-run-id
+ (begin
+ ;(print pgdb-run-id)
+ (pgdb:get-test-id dbh pgdb-run-id test-name item-path))
+ #f)))
+ ;; "id" "run_id" "testname" "state" "status" "event_time"
+ ;; "host" "cpuload" "diskfree" "uname" "rundir" "item_path"
+ ;; "run_duration" "final_logf" "comment" "shortdir" "attemptnum" "archived"
+ (if (or (not item-path) (string-null? item-path))
+ (debug:print-info 0 *default-log-port* "Working on Run id : " run-id "and test name : " test-name))
+ (if pgdb-run-id
+ (begin
+ (if pgdb-test-id ;; have a record
+ (begin ;; let ((key-name (conc run-id "/" test-name "/" item-path)))
+ (debug:print-info 4 *default-log-port* "Updating existing test with run-id: " run-id " and test-id: " test-id " pgdb run id: " pgdb-run-id " pgdb-test-id " pgdb-test-id)
+ (let* ((pgdb-last-update (pgdb:get-test-last-update dbh pgdb-test-id)))
+ (if (and (> last-update pgdb-last-update) (or (not smallest-time) (< last-update smallest-time))) ;;if last-update is same as pgdb-last-update then it is safe to assume the records are identical and we can use a larger last update time.
+ (hash-table-set! smallest-last-update-time "smallest-time" last-update)))
+ (pgdb:update-test dbh pgdb-test-id pgdb-run-id test-name item-path state status host cpuload diskfree uname run-dir log-file run-duration comment event-time archived last-update pid))
+ (begin
+ (debug:print-info 4 *default-log-port* "Inserting test with run-id: " run-id " and test-id: " test-id " pgdb run id: " pgdb-run-id)
+ (pgdb:insert-test dbh pgdb-run-id test-name item-path state status host cpuload diskfree uname run-dir log-file run-duration comment event-time archived last-update pid)
+ (if (or (not smallest-time) (< last-update smallest-time))
+ (hash-table-set! smallest-last-update-time "smallest-time" last-update))
+ (set! pgdb-test-id (pgdb:get-test-id dbh pgdb-run-id test-name item-path))))
+ (hash-table-set! test-ht test-id pgdb-test-id))
+ (debug:print-info 1 *default-log-port* "WARNING: Skipping run with run-id:" run-id ". This run was created after privious sync and removed before this sync."))))
+ test-ids)))
+
+
+;; get runs changed since last sync
+;; (define (tasks:sync-test-data dbh cached-info area-info)
+;; (let* ((
+
+(define (tasks:sync-to-postgres configdat dest)
+ (print "In sync")
+ (let* ((dbh (pgdb:open configdat dbname: dest))
+ (area-info (pgdb:get-area-by-path dbh *toppath*))
+ (cached-info (make-hash-table))
+ (start (current-seconds))
+ (test-patt (if (args:get-arg "-testpatt")
+ (args:get-arg "-testpatt")
+ "%"))
+ (target (if (args:get-arg "-target")
+ (args:get-arg "-target")
+ #f))
+ (run-name (if (args:get-arg "-runname")
+ (args:get-arg "-runname")
+ #f)))
+ (if (and target (not run-name))
+ (begin
+ (print "Error: Provide runname")
+ (exit 1)))
+ (if (and (not target) run-name)
+ (begin
+ (print "Error: Provide target")
+ (exit 1)))
+ ;(print "123")
+ ;(exit 1)
+ (for-each (lambda (dtype)
+ (hash-table-set! cached-info dtype (make-hash-table)))
+ '(runs targets tests steps data))
+ (hash-table-set! cached-info 'start start) ;; when done we'll set sync times to this
+ (if area-info
+ (let* ((last-sync-time (vector-ref area-info 3))
+ (smallest-last-update-time (make-hash-table))
+ (changed (if (and target run-name)
+ (rmt:get-run-record-ids target run-name (rmt:get-keys) test-patt)
+ (rmt:get-changed-record-ids last-sync-time)))
+ (run-ids (alist-ref 'runs changed))
+ (test-ids (alist-ref 'tests changed))
+ (test-step-ids (alist-ref 'test_steps changed))
+ (test-data-ids (alist-ref 'test_data changed))
+ (run-stat-ids (alist-ref 'run_stats changed))
+ (area-tag (if (args:get-arg "-area-tag")
+ (args:get-arg "-area-tag")
+ (if (args:get-arg "-area")
+ (args:get-arg "-area")
+ ""))))
+ (if (and (equal? area-tag "") (not (pgdb:is-area-taged dbh (vector-ref area-info 0))))
+ (set! area-tag *default-area-tag*))
+ (if (not (equal? area-tag ""))
+ (task:add-area-tag dbh area-info area-tag))
+ (if (or (not (null? test-ids)) (not (null? run-ids)))
+ (begin
+ (debug:print-info 0 *default-log-port* "syncing runs")
+ (tasks:sync-run-data dbh cached-info run-ids area-info smallest-last-update-time)
+ (debug:print-info 0 *default-log-port* "syncing tests")
+ (tasks:sync-tests-data dbh cached-info test-ids area-info smallest-last-update-time)
+ (debug:print-info 0 *default-log-port* "syncing test steps")
+ (tasks:sync-test-steps dbh cached-info test-step-ids smallest-last-update-time)
+ (debug:print-info 0 *default-log-port* "syncing test data")
+ (tasks:sync-test-gen-data dbh cached-info test-data-ids smallest-last-update-time)
+ (print "----------done---------------")))
+ (let* ((smallest-time (hash-table-ref/default smallest-last-update-time "smallest-time" (current-seconds))))
+ (debug:print-info 0 "smallest-time :" smallest-time " last-sync-time " last-sync-time)
+ (if (not (and target run-name))
+ (if (or (and smallest-time (> smallest-time last-sync-time)) (and smallest-time (eq? last-sync-time 0)))
+ (pgdb:write-sync-time dbh area-info smallest-time))))) ;;this needs to be changed
+ (if (tasks:set-area dbh configdat)
+ (tasks:sync-to-postgres configdat dest)
+ (begin
+ (debug:print 0 *default-log-port* "ERROR: unable to create an area record")
+ #f)))))
Index: server.scm
==================================================================
--- server.scm
+++ server.scm
@@ -25,16 +25,15 @@
(declare (unit server))
(declare (uses common))
(declare (uses db))
-(declare (uses tasks)) ;; tasks are where stuff is maintained about what is running.
-;; (declare (uses synchash))
+(declare (uses margsmod))
+(import margsmod)
+
(declare (uses http-transport))
-;;(declare (uses rpc-transport))
(declare (uses launch))
-;; (declare (uses daemon))
(declare (uses commonmod))
(import commonmod)
(declare (uses dbmod))
Index: sharedat.scm
==================================================================
--- sharedat.scm
+++ sharedat.scm
@@ -37,11 +37,11 @@
(use sql-de-lite srfi-1 posix regex regex-case srfi-69)
;; (import (prefix sqlite3 sqlite3:))
;;
(declare (uses configf))
;; (declare (uses tree))
-(declare (uses margs))
+(declare (uses margsmod))
;; (declare (uses dcommon))
;; (declare (uses launch))
;; (declare (uses gutils))
;; (declare (uses db))
;; (declare (uses synchash))
Index: spublish.scm
==================================================================
--- spublish.scm
+++ spublish.scm
@@ -24,11 +24,11 @@
(use format)
(use sql-de-lite srfi-1 posix regex regex-case srfi-69)
;(declare (uses configf))
;; (declare (uses tree))
-(declare (uses margs))
+(declare (uses margsmod))
(include "megatest-version.scm")
(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")
Index: tasks.scm
==================================================================
--- tasks.scm
+++ tasks.scm
@@ -16,32 +16,32 @@
;; along with Megatest. If not, see .
;;
;; strftime('%m/%d/%Y %H:%M:%S','now','localtime')
-(use sqlite3 srfi-1 posix regex regex-case srfi-69 dot-locking format)
-(import (prefix sqlite3 sqlite3:))
-
(declare (unit tasks))
-(declare (uses db))
-(declare (uses rmt))
-(declare (uses common))
(declare (uses pgdb))
-
-;; (import pgdb) ;; pgdb is a module
-
(declare (uses commonmod))
-(import commonmod)
-
(declare (uses configfmod))
+(declare (uses dbmod))
+(declare (uses margsmod))
+
+(module tasks
+*
+
+(import scheme chicken data-structures extras)
+(use sqlite3 srfi-1 posix regex regex-case
+ srfi-69 dot-locking format srfi-18)
+(import (prefix sqlite3 sqlite3:))
+(import commonmod)
(import configfmod)
-
-(declare (uses dbmod))
(import dbmod)
+(import margsmod)
+(import pgdb)
(include "task_records.scm")
-(include "db_records.scm")
+;; (include "db_records.scm")
;;======================================================================
;; Tasks db
;;======================================================================
@@ -488,52 +488,10 @@
WHERE
target = ? AND name = ? AND state LIKE ? AND action LIKE ? AND testpatt LIKE ?;"
target run-name state-patt action-patt test-patt)
res)))) ;; )
-;; kill any runner processes (i.e. processes handling -runtests) that match target/runname
-;;
-;; do a remote call to get the task queue info but do the killing as self here.
-;;
-(define (tasks:kill-runner target run-name testpatt)
- (let ((records (rmt:tasks-find-task-queue-records target run-name testpatt "running" "run-tests"))
- (hostpid-rx (regexp "\\s+(\\w+)\\s+(\\d+)$"))) ;; host pid is at end of param string
- (if (null? records)
- (debug:print 0 *default-log-port* "No run launching processes found for " target " / " run-name " with testpatt " (or testpatt "* no testpatt specified! *"))
- (debug:print 0 *default-log-port* "Found " (length records) " run(s) to kill."))
- (for-each
- (lambda (record)
- (let* ((param-key (list-ref record 8))
- (match-dat (string-search hostpid-rx param-key)))
- (if match-dat
- (let ((hostname (cadr match-dat))
- (pid (string->number (caddr match-dat))))
- (debug:print 0 *default-log-port* "Sending SIGINT to process " pid " on host " hostname)
- (if (equal? (get-host-name) hostname)
- (if (process:alive? pid)
- (begin
- (handle-exceptions
- exn
- (begin
- (debug:print 0 *default-log-port* "Kill of process " pid " on host " hostname " failed.")
- (debug:print 0 *default-log-port* " message: " ((condition-property-accessor 'exn 'message) exn))
- #t)
- (process-signal pid signal/int)
- (thread-sleep! 5)
- (if (process:alive? pid)
- (process-signal pid signal/kill)))))
- ;; (call-with-environment-variables
- (let ((old-targethost (getenv "TARGETHOST")))
- (setenv "TARGETHOST" hostname)
- (setenv "TARGETHOST_LOGF" "server-kills.log")
- (system (conc "nbfake kill " pid))
- (if old-targethost (setenv "TARGETHOST" old-targethost))
- (unsetenv "TARGETHOST")
- (unsetenv "TARGETHOST_LOGF"))))
- (debug:print-error 0 *default-log-port* "no record or improper record for " target "/" run-name " in tasks_queue in main.db"))))
- records)))
-
;; (define (tasks:start-run dbstruct mdb task)
;; (let ((flags (make-hash-table)))
;; (hash-table-set! flags "-rerun" "NOT_STARTED")
;; (if (not (string=? (tasks:task-get-params task) ""))
;; (hash-table-set! flags "-setvars" (tasks:task-get-params task)))
@@ -610,30 +568,10 @@
(set! str (conc str ",")))
(if (null? rema)
(print "[" str "{target:" target ",run-name:" run-name ", run-time:" run-time "}]")
(loop (car rema) (cdr rema) (conc str "{target:" target ", run-name:" run-name ", run-time:" run-time "}"))))))
-(define (task:get-run-times)
- (let* (
- (run-patt (if (args:get-arg "-run-patt")
- (args:get-arg "-run-patt")
- "%"))
- (target-patt (if (args:get-arg "-target-patt")
- (args:get-arg "-target-patt")
- "%"))
-
- (run-times (rmt:get-run-times run-patt target-patt )))
- (if (eq? (length run-times) 0)
- (begin
- (print "Data not found!!")
- (exit)))
- (if (equal? (args:get-arg "-dumpmode") "json")
- (task:print-runtime-as-json run-times)
- (if (equal? (args:get-arg "-dumpmode") "csv")
- (task:print-runtime run-times ",")
- (task:print-runtime run-times " ")))))
-
(define (task:print-testtime test-times saperator)
(for-each
(lambda (test-time-info)
(let* ((test-name (vector-ref test-time-info 0))
@@ -657,123 +595,11 @@
(if (null? rema)
(print "[" str "{test-name:" test-name ", item-path:" item ", test-time:" test-time "}]")
(loop (car rema) (cdr rema) (conc str "{test-name:" test-name ", item-path:" item ", test-time:" test-time "}"))))))
- (define (task:get-test-times)
- (let* ((runname (if (args:get-arg "-runname")
- (args:get-arg "-runname")
- #f))
- (target (if (args:get-arg "-target")
- (args:get-arg "-target")
- #f))
-
- (test-times (rmt:get-test-times runname target )))
- (if (not runname)
- (begin
- (print "Error: Missing argument -runname")
- (exit)))
- (if (string-contains runname "%")
- (begin
- (print "Error: Invalid runname, '%' not allowed (" runname ") ")
- (exit)))
- (if (not target)
- (begin
- (print "Error: Missing argument -target")
- (exit)))
- (if (string-contains target "%")
- (begin
- (print "Error: Invalid target, '%' not allowed (" target ") ")
- (exit)))
-
- (if (eq? (length test-times) 0)
- (begin
- (print "Data not found!!")
- (exit)))
- (if (equal? (args:get-arg "-dumpmode") "json")
- (task:print-testtime-as-json test-times)
- (if (equal? (args:get-arg "-dumpmode") "csv")
- (task:print-testtime test-times ",")
- (task:print-testtime test-times " ")))))
-
-
-
-;; gets mtpg-run-id and syncs the record if different
-;;
-(define (tasks:run-id->mtpg-run-id dbh cached-info run-id area-info smallest-last-update-time)
- (let* ((runs-ht (hash-table-ref cached-info 'runs))
- (runinf (hash-table-ref/default runs-ht run-id #f))
- (area-id (vector-ref area-info 0)))
- (if runinf
- runinf ;; already cached
- (let* ((run-dat (rmt:get-run-info run-id)) ;; NOTE: get-run-info returns a vector < row header >
- (run-name (rmt:get-run-name-from-id run-id))
- (row (db:get-rows run-dat)) ;; yes, this returns a single row
- (header (db:get-header run-dat))
- (state (db:get-value-by-header row header "state"))
- (status (db:get-value-by-header row header "status"))
- (owner (db:get-value-by-header row header "owner"))
- (event-time (db:get-value-by-header row header "event_time"))
- (comment (db:get-value-by-header row header "comment"))
- (fail-count (db:get-value-by-header row header "fail_count"))
- (pass-count (db:get-value-by-header row header "pass_count"))
- (db-contour (db:get-value-by-header row header "contour"))
- (contour (if (args:get-arg "-prepend-contour")
- (if (and db-contour (not (equal? db-contour "")) (string? db-contour ))
- (begin
- (debug:print-info 10 *default-log-port* "db-contour" db-contour)
- db-contour)
- (args:get-arg "-contour"))))
- (run-tag (if (args:get-arg "-run-tag")
- (args:get-arg "-run-tag")
- ""))
- (last-update (db:get-value-by-header row header "last_update"))
- (keytarg (if (or (args:get-arg "-prepend-contour") (args:get-arg "-prefix-target"))
- (conc "MT_CONTOUR/MT_AREA/" (string-intersperse (rmt:get-keys) "/")) (string-intersperse (rmt:get-keys) "/"))) ;; e.g. version/iteration/platform
- (base-target (rmt:get-target run-id))
- (target (if (or (args:get-arg "-prepend-contour") (args:get-arg "-prefix-target"))
- (conc (or (args:get-arg "-prefix-target") (conc contour "/" (common:get-area-name) "/")) base-target) base-target)) ;; e.g. v1.63/a3e1/ubuntu
- (spec-id (pgdb:get-ttype dbh keytarg))
- (publish-time (if (args:get-arg "-cp-eventtime-to-publishtime")
- event-time
- (current-seconds)))
- (new-run-id (if (and run-name base-target) (pgdb:get-run-id dbh spec-id target run-name area-id) #f)))
- (if new-run-id
- (begin ;; let ((run-record (pgdb:get-run-info dbh new-run-id))
- (hash-table-set! runs-ht run-id new-run-id)
- ;; ensure key fields are up to date
- ;; if last_update == pgdb_last_update do not update smallest-last-update-time
- (let* ((pgdb-last-update (pgdb:get-run-last-update dbh new-run-id))
- (smallest-time (hash-table-ref/default smallest-last-update-time "smallest-time" #f)))
- (if (and (> last-update pgdb-last-update) (or (not smallest-time) (< last-update smallest-time)))
- (hash-table-set! smallest-last-update-time "smallest-time" last-update)))
- (pgdb:refresh-run-info
- dbh
- new-run-id
- state status owner event-time comment fail-count pass-count area-id last-update publish-time)
- (debug:print-info 4 *default-log-port* "Working on run-id " run-id " pgdb-id " new-run-id )
- (if (not (equal? run-tag ""))
- (task:add-run-tag dbh new-run-id run-tag))
- new-run-id)
-
- (if (or (not state) (equal? state "deleted"))
- (begin
- (debug:print-info 1 *default-log-port* "Warning: Run with id " run-id " was created after previous sync and deleted before the sync") #f)
- (if (handle-exceptions
- exn
- (begin (print-call-chain)
- (print ((condition-property-accessor 'exn 'message) exn))
- #f)
-
- (pgdb:insert-run
- dbh
- spec-id target run-name state status owner event-time comment fail-count pass-count area-id last-update publish-time))
- (let* ((smallest-time (hash-table-ref/default smallest-last-update-time "smallest-time" #f)))
- (if (or (not smallest-time) (< last-update smallest-time))
- (hash-table-set! smallest-last-update-time "smallest-time" last-update))
- (tasks:run-id->mtpg-run-id dbh cached-info run-id area-info smallest-last-update-time))
- #f)))))))
+
(define (task:add-run-tag dbh run-id tag)
(let* ((tag-info (pgdb:get-tag-info-by-name dbh tag)))
(if (not tag-info)
(begin
@@ -793,168 +619,10 @@
#f)
(if (not (pgdb:is-run-taged-with-a-tag dbh (vector-ref tag-info 0) run-id))
(pgdb:insert-run-tag dbh (vector-ref tag-info 0) run-id)))))
-(define (tasks:sync-test-steps dbh cached-info test-step-ids smallest-last-update-time)
- ; (print "Sync Steps " test-step-ids )
- (let ((test-ht (hash-table-ref cached-info 'tests))
- (step-ht (hash-table-ref cached-info 'steps)))
- (for-each
- (lambda (test-step-id)
- (let* ((test-step-info (rmt:get-steps-info-by-id test-step-id))
- (step-id (tdb:step-get-id test-step-info))
- (test-id (tdb:step-get-test_id test-step-info))
- (stepname (tdb:step-get-stepname test-step-info))
- (state (tdb:step-get-state test-step-info))
- (status (tdb:step-get-status test-step-info))
- (event_time (tdb:step-get-event_time test-step-info))
- (comment (tdb:step-get-comment test-step-info))
- (logfile (tdb:step-get-logfile test-step-info))
- (last-update (tdb:step-get-last_update test-step-info))
- (pgdb-test-id (hash-table-ref/default test-ht test-id #f))
- (smallest-time (hash-table-ref/default smallest-last-update-time "smallest-time" #f))
- (pgdb-step-id (if pgdb-test-id
- (pgdb:get-test-step-id dbh pgdb-test-id stepname state)
- #f)))
- (if step-id
- (begin
- (if pgdb-test-id
- (begin
- (if pgdb-step-id
- (begin
- (debug:print-info 4 *default-log-port* "Updating existing test-step with test-id: " test-id " and step-id " step-id " pgdb test id: " pgdb-test-id " pgdb step id " pgdb-step-id )
- (let* ((pgdb-last-update (pgdb:get-test-step-last-update dbh pgdb-step-id)))
- (if (and (> last-update pgdb-last-update) (or (not smallest-time) (< last-update smallest-time)))
- (hash-table-set! smallest-last-update-time "smallest-time" last-update)))
- (pgdb:update-test-step dbh pgdb-step-id pgdb-test-id stepname state status event_time comment logfile last-update))
- (begin
- (debug:print-info 4 *default-log-port* "Inserting test-step with test-id: " test-id " and step-id " step-id " pgdb test id: " pgdb-test-id)
- (if (or (not smallest-time) (< last-update smallest-time))
- (hash-table-set! smallest-last-update-time "smallest-time" last-update))
- (pgdb:insert-test-step dbh pgdb-test-id stepname state status event_time comment logfile last-update )
- (set! pgdb-step-id (pgdb:get-test-step-id dbh pgdb-test-id stepname state))))
- (hash-table-set! step-ht step-id pgdb-step-id ))
- (debug:print-info 1 *default-log-port* "Error: Test not cashed")))
- (debug:print-info 1 *default-log-port* "Error: Could not get test step info for step id " test-step-id )))) ;; this is a wierd senario need to debug
- test-step-ids)))
-
-(define (tasks:sync-test-gen-data dbh cached-info test-data-ids smallest-last-update-time)
- (let ((test-ht (hash-table-ref cached-info 'tests))
- (data-ht (hash-table-ref cached-info 'data)))
- (for-each
- (lambda (test-data-id)
- (let* ((test-data-info (rmt:get-data-info-by-id test-data-id))
- (data-id (db:test-data-get-id test-data-info))
- (test-id (db:test-data-get-test_id test-data-info))
- (category (db:test-data-get-category test-data-info))
- (variable (db:test-data-get-variable test-data-info))
- (value (db:test-data-get-value test-data-info))
- (expected (db:test-data-get-expected test-data-info))
- (tol (db:test-data-get-tol test-data-info))
- (units (db:test-data-get-units test-data-info))
- (comment (db:test-data-get-comment test-data-info))
- (status (db:test-data-get-status test-data-info))
- (type (db:test-data-get-type test-data-info))
- (last-update (db:test-data-get-last_update test-data-info))
- (smallest-time (hash-table-ref/default smallest-last-update-time "smallest-time" #f))
-
- (pgdb-test-id (hash-table-ref/default test-ht test-id #f))
- (pgdb-data-id (if pgdb-test-id
- (pgdb:get-test-data-id dbh pgdb-test-id category variable)
- #f)))
- (if data-id
- (begin
- (if pgdb-test-id
- (begin
- (if pgdb-data-id
- (begin
- (debug:print-info 4 *default-log-port* "Updating existing test-data with test-id: " test-id " and data-id " data-id " pgdb test id: " pgdb-test-id " pgdb data id " pgdb-data-id)
- (let* ((pgdb-last-update (pgdb:get-test-data-last-update dbh pgdb-data-id)))
- (if (and (> last-update pgdb-last-update) (or (not smallest-time) (< last-update smallest-time)))
- (hash-table-set! smallest-last-update-time "smallest-time" last-update)))
- (pgdb:update-test-data dbh pgdb-data-id pgdb-test-id category variable value expected tol units comment status type last-update))
- (begin
- (debug:print-info 4 *default-log-port* "Inserting test-data with test-id: " test-id " and data-id " data-id " pgdb test id: " pgdb-test-id)
- (if (handle-exceptions
- exn
- (begin (print-call-chain)
- (print ((condition-property-accessor 'exn 'message) exn))
- #f)
-
- (pgdb:insert-test-data dbh pgdb-test-id category variable value expected tol units comment status type last-update))
- ;(tasks:run-id->mtpg-run-id dbh cached-info run-id area-info)
- (begin
- ;(pgdb:insert-test-data dbh pgdb-test-id category variable value expected tol units comment status type )
- (if (or (not smallest-time) (< last-update smallest-time))
- (hash-table-set! smallest-last-update-time "smallest-time" last-update))
- (set! pgdb-data-id (pgdb:get-test-data-id dbh pgdb-test-id category variable)))
- #f)))
- (hash-table-set! data-ht data-id pgdb-data-id ))
- (begin
- (debug:print-info 1 *default-log-port* "Error: Test not in pgdb"))))
-
- (debug:print-info 1 *default-log-port* "Error: Could not get test data info for data id " test-data-id )))) ;; this is a wierd senario need to debug
- test-data-ids)))
-
-
-
-(define (tasks:sync-tests-data dbh cached-info test-ids area-info smallest-last-update-time)
- (let ((test-ht (hash-table-ref cached-info 'tests)))
- (for-each
- (lambda (test-id)
- ; (print test-id)
- (let* ((test-info (rmt:get-test-info-by-id #f test-id))
- (run-id (db:test-get-run_id test-info)) ;; look these up in db_records.scm
- (test-id (db:test-get-id test-info))
- (test-name (db:test-get-testname test-info))
- (item-path (db:test-get-item-path test-info))
- (state (db:test-get-state test-info))
- (status (db:test-get-status test-info))
- (host (db:test-get-host test-info))
- (pid (db:test-get-process_id test-info))
- (cpuload (db:test-get-cpuload test-info))
- (diskfree (db:test-get-diskfree test-info))
- (uname (db:test-get-uname test-info))
- (run-dir (db:test-get-rundir test-info))
- (log-file (db:test-get-final_logf test-info))
- (run-duration (db:test-get-run_duration test-info))
- (comment (db:test-get-comment test-info))
- (event-time (db:test-get-event_time test-info))
- (archived (db:test-get-archived test-info))
- (last-update (db:test-get-last_update test-info))
- (pgdb-run-id (tasks:run-id->mtpg-run-id dbh cached-info run-id area-info smallest-last-update-time))
- (smallest-time (hash-table-ref/default smallest-last-update-time "smallest-time" #f))
- (pgdb-test-id (if pgdb-run-id
- (begin
- ;(print pgdb-run-id)
- (pgdb:get-test-id dbh pgdb-run-id test-name item-path))
- #f)))
- ;; "id" "run_id" "testname" "state" "status" "event_time"
- ;; "host" "cpuload" "diskfree" "uname" "rundir" "item_path"
- ;; "run_duration" "final_logf" "comment" "shortdir" "attemptnum" "archived"
- (if (or (not item-path) (string-null? item-path))
- (debug:print-info 0 *default-log-port* "Working on Run id : " run-id "and test name : " test-name))
- (if pgdb-run-id
- (begin
- (if pgdb-test-id ;; have a record
- (begin ;; let ((key-name (conc run-id "/" test-name "/" item-path)))
- (debug:print-info 4 *default-log-port* "Updating existing test with run-id: " run-id " and test-id: " test-id " pgdb run id: " pgdb-run-id " pgdb-test-id " pgdb-test-id)
- (let* ((pgdb-last-update (pgdb:get-test-last-update dbh pgdb-test-id)))
- (if (and (> last-update pgdb-last-update) (or (not smallest-time) (< last-update smallest-time))) ;;if last-update is same as pgdb-last-update then it is safe to assume the records are identical and we can use a larger last update time.
- (hash-table-set! smallest-last-update-time "smallest-time" last-update)))
- (pgdb:update-test dbh pgdb-test-id pgdb-run-id test-name item-path state status host cpuload diskfree uname run-dir log-file run-duration comment event-time archived last-update pid))
- (begin
- (debug:print-info 4 *default-log-port* "Inserting test with run-id: " run-id " and test-id: " test-id " pgdb run id: " pgdb-run-id)
- (pgdb:insert-test dbh pgdb-run-id test-name item-path state status host cpuload diskfree uname run-dir log-file run-duration comment event-time archived last-update pid)
- (if (or (not smallest-time) (< last-update smallest-time))
- (hash-table-set! smallest-last-update-time "smallest-time" last-update))
- (set! pgdb-test-id (pgdb:get-test-id dbh pgdb-run-id test-name item-path))))
- (hash-table-set! test-ht test-id pgdb-test-id))
- (debug:print-info 1 *default-log-port* "WARNING: Skipping run with run-id:" run-id ". This run was created after privious sync and removed before this sync."))))
- test-ids)))
-
(define (task:add-area-tag dbh area-info tag)
(let* ((tag-info (pgdb:get-tag-info-by-name dbh tag)))
(if (not tag-info)
(begin
(if (handle-exceptions
@@ -980,80 +648,6 @@
(debug:print-info 4 *default-log-port* "Check if run with " run-id " needs to be synced" )
(tasks:run-id->mtpg-run-id dbh cached-info run-id area-info smallest-last-update-time))
run-ids))
-;; get runs changed since last sync
-;; (define (tasks:sync-test-data dbh cached-info area-info)
-;; (let* ((
-
-(define (tasks:sync-to-postgres configdat dest)
- (print "In sync")
- (let* ((dbh (pgdb:open configdat dbname: dest))
- (area-info (pgdb:get-area-by-path dbh *toppath*))
- (cached-info (make-hash-table))
- (start (current-seconds))
- (test-patt (if (args:get-arg "-testpatt")
- (args:get-arg "-testpatt")
- "%"))
- (target (if (args:get-arg "-target")
- (args:get-arg "-target")
- #f))
- (run-name (if (args:get-arg "-runname")
- (args:get-arg "-runname")
- #f)))
- (if (and target (not run-name))
- (begin
- (print "Error: Provide runname")
- (exit 1)))
- (if (and (not target) run-name)
- (begin
- (print "Error: Provide target")
- (exit 1)))
- ;(print "123")
- ;(exit 1)
- (for-each (lambda (dtype)
- (hash-table-set! cached-info dtype (make-hash-table)))
- '(runs targets tests steps data))
- (hash-table-set! cached-info 'start start) ;; when done we'll set sync times to this
- (if area-info
- (let* ((last-sync-time (vector-ref area-info 3))
- (smallest-last-update-time (make-hash-table))
- (changed (if (and target run-name)
- (rmt:get-run-record-ids target run-name (rmt:get-keys) test-patt)
- (rmt:get-changed-record-ids last-sync-time)))
- (run-ids (alist-ref 'runs changed))
- (test-ids (alist-ref 'tests changed))
- (test-step-ids (alist-ref 'test_steps changed))
- (test-data-ids (alist-ref 'test_data changed))
- (run-stat-ids (alist-ref 'run_stats changed))
- (area-tag (if (args:get-arg "-area-tag")
- (args:get-arg "-area-tag")
- (if (args:get-arg "-area")
- (args:get-arg "-area")
- ""))))
- (if (and (equal? area-tag "") (not (pgdb:is-area-taged dbh (vector-ref area-info 0))))
- (set! area-tag *default-area-tag*))
- (if (not (equal? area-tag ""))
- (task:add-area-tag dbh area-info area-tag))
- (if (or (not (null? test-ids)) (not (null? run-ids)))
- (begin
- (debug:print-info 0 *default-log-port* "syncing runs")
- (tasks:sync-run-data dbh cached-info run-ids area-info smallest-last-update-time)
- (debug:print-info 0 *default-log-port* "syncing tests")
- (tasks:sync-tests-data dbh cached-info test-ids area-info smallest-last-update-time)
- (debug:print-info 0 *default-log-port* "syncing test steps")
- (tasks:sync-test-steps dbh cached-info test-step-ids smallest-last-update-time)
- (debug:print-info 0 *default-log-port* "syncing test data")
- (tasks:sync-test-gen-data dbh cached-info test-data-ids smallest-last-update-time)
- (print "----------done---------------")))
- (let* ((smallest-time (hash-table-ref/default smallest-last-update-time "smallest-time" (current-seconds))))
- (debug:print-info 0 "smallest-time :" smallest-time " last-sync-time " last-sync-time)
- (if (not (and target run-name))
- (if (or (and smallest-time (> smallest-time last-sync-time)) (and smallest-time (eq? last-sync-time 0)))
- (pgdb:write-sync-time dbh area-info smallest-time))))) ;;this needs to be changed
- (if (tasks:set-area dbh configdat)
- (tasks:sync-to-postgres configdat dest)
- (begin
- (debug:print 0 *default-log-port* "ERROR: unable to create an area record")
- #f)))))
-
+)
Index: tcmt.scm
==================================================================
--- tcmt.scm
+++ tcmt.scm
@@ -26,13 +26,15 @@
(use srfi-1 posix srfi-69 srfi-18 regex defstruct)
(use trace)
;; (trace-call-sites #t)
-(declare (uses margs))
(declare (uses rmt))
(declare (uses common))
+(declare (uses margsmod))
+(import margsmod)
+
;; (declare (uses megatest-version))
(declare (uses commonmod))
(import commonmod)
Index: tdb.scm
==================================================================
--- tdb.scm
+++ tdb.scm
@@ -30,10 +30,12 @@
(declare (unit tdb))
(declare (uses common))
(declare (uses client))
(declare (uses mt))
(declare (uses db))
+(declare (uses margsmod))
+(import margsmod)
(declare (uses commonmod))
(import commonmod)
(declare (uses dbmod))
Index: tests.scm
==================================================================
--- tests.scm
+++ tests.scm
@@ -28,10 +28,12 @@
(declare (uses tdb))
(declare (uses common))
(declare (uses items))
(declare (uses runconfig))
(declare (uses server))
+(declare (uses margsmod))
+(import margsmod)
(use sqlite3 srfi-1 posix regex regex-case srfi-69 dot-locking tcp directory-utils)
(import (prefix sqlite3 sqlite3:))
(require-library stml)
Index: tree.scm
==================================================================
--- tree.scm
+++ tree.scm
@@ -25,11 +25,11 @@
(use sqlite3 srfi-1 posix regex regex-case srfi-69)
(import (prefix sqlite3 sqlite3:))
(declare (unit tree))
-(declare (uses margs))
+(declare (uses margsmod))
(declare (uses launch))
;; (declare (uses megatest-version))
(declare (uses gutils))
(declare (uses db))
(declare (uses server))
Index: utils/gendeps.scm
==================================================================
--- utils/gendeps.scm
+++ utils/gendeps.scm
@@ -25,11 +25,11 @@
(with-output-to-port p
(lambda ()
(apply print args))))
(define modules-without-mod
- "(ods|transport|portlogger)")
+ "(ods|transport|portlogger|tasks|pgdb)")
(define (mofiles-adjust->dot-o inf)
(regex-case
inf
("^.*mod$" _ (conc "mofiles/"inf".o"))
@@ -82,23 +82,23 @@
(print "Found module "modname)
(hash-table-set! moduledata modname sname))
(importuse (_ importname)
(print "Found import "importname)
(hh-push incldata importname sname))
- (mofiles-adjust->dot-o usingname)))
(else #f))
(loop (read-line)))))))))
files)
(hash-table-for-each
incldata
(lambda (impname snames)
(for-each
(lambda (sname)
(if (hash-table-exists? moduledata impname)
- (make-inc-entry incport incdotport sname impname)
- (print "No module file found for import " impname)
- ))
+ (if (hash-table-exists? incldata sname)
+ (make-inc-entry incport incdotport sname impname)
+ (print "Skipping module "sname", it is not used by any other modules"))
+ (print "No module file found for import " impname)))
snames)))
(portprint dotport "}")
(portprint incdotport "}")
(close-output-port dotport)
(close-output-port incport)