Index: Makefile
==================================================================
--- Makefile
+++ Makefile
@@ -36,31 +36,34 @@
subrun.scm archive.scm env.scm \
diff-report.scm cgisetup/models/pgdb.scm
# module source files
MSRCFILES = dbfile.scm debugprint.scm mtargs.scm commonmod.scm dbmod.scm \
- tcp-transportmod.scm rmtmod.scm portlogger.scm
+ tcp-transportmod.scm rmtmod.scm portlogger.scm apimod.scm \
+ configfmod.scm processmod.scm
transport-mode.scm : transport-mode.scm.template
- @if [[ -e transport-mode.scm ]];then \
- echo "WARNING: transport-mode.scm.template is newer than transport-mode.scm"; else \
- cp transport-mode.scm.template transport-mode.scm; fi
+ cp transport-mode.scm.template transport-mode.scm
dashboard-transport-mode.scm : dashboard-transport-mode.scm.template
- @if [[ -e dashboard-transport-mode.scm ]];then \
- echo "WARNING: dashboard-transport-mode.scm.template is newer than dashboard-transport-mode.scm"; else \
- cp dashboard-transport-mode.scm.template dashboard-transport-mode.scm; fi
+ cp dashboard-transport-mode.scm.template dashboard-transport-mode.scm
-megatest.scm : transport-mode.scm
-dashboard.scm : dashboard-transport-mode.scm
+mtest : transport-mode.scm
+dboard : dashboard-transport-mode.scm
# dbmod.import.o is just a hack here
mofiles/portlogger.o : mofiles/dbmod.o
+process.o : mofiles/processmod.o
+mofiles/configfmod.o : mofiles/processmod.o
+mofiles/processmod.o : mofiles/commonmod.o
mofiles/dbfile.o : \
- mofiles/debugprint.o mofiles/commonmod.o
-
+ mofiles/debugprint.o mofiles/commonmod.o
+mofiles/apimod.o : mofiles/commonmod.o mofiles/tcp-transportmod.o mofiles/configfmod.o
+mofiles/dbmod.o : mofiles/dbfile.o
+mofiles/api.o : mofiles/apimod.o
+mofiles/commonmod.o : mofiles/debugprint.o
configf.o : commonmod.import.o
mofiles/dbfile.o : mofiles/debugprint.o
mofiles/rmtmod.o mofiles/dbmod.o : mofiles/dbfile.o mofiles/commonmod.o mofiles/debugprint.o
db.o : mofiles/dbmod.o mofiles/dbfile.o
mofiles/debugprint.o : mofiles/mtargs.o
@@ -182,10 +185,11 @@
# Special dependencies for the includes
$(MOFILE) $(MOIMPFILES) : megatest-fossil-hash.scm
mofiles/commonmod.o : mofiles/debugprint.o megatest-fossil-hash.scm
common.o : mofiles/commonmod.o
+mofiles/configfmod.o : mofiles/commonmod.o
# mofiles/dbmod.o : mofiles/configfmod.o
# commonmod.o dashboard.o megatest.o tcmt.o apimod.o : megatest-fossil-hash.scm
Index: TODO
==================================================================
--- TODO
+++ TODO
@@ -16,10 +16,51 @@
# along with Megatest. If not, see .
TODO
====
+23WW48
+. Add calls-per-minute to db access stats
+. Find out why start-server calls are taking 250ms and fix
+. Allow two or three servers to run for any given db
+. Update avg call count/sec every 30 sec in no-sync
+. get server uses no-sync process info to decide which server to suggest
+. Use process table to decide who will do sync back
+. Fix metadat being synced over and over
+
+23WW47
+. Finding server
+.. look at .servinfo for likely prime main
+.. ask the .servinfo prime main for real prime main
+.. save prime main (for how long, 10 seconds or 10 minutes?)
+
+. Starting prime main
+.. get servinfo files - START
+.. no files? create my servinfo file, goto START
+.. have files? am I the prime main according to servinfo files?
+.. no, I'm not the prime main, ping prime main
+.. ping is good, prime main exists, register self as server if on same host as prime main DONE
+.. no pirng response, remove the .servinfo file - goto START
+.. if I am prime main according to .servinfo files, register directly in no-sync
+
+. Starting non-main
+.. get servinfo files
+.. no files? launch server for main.db
+.. have files? pick out prime main
+.. register self as server with prime main
+
+23WW46 - v1.80 branch
+. Use file semaphore to kill tests, eliminate db load of the KILLREQ query
+. Merge this change to revolution branch
+23WW45 - the revolution branch
+. Add "fast" db start option (no handshaking over NFS)
+. Add server-ro to server types (just "server" is fine for read/write).
+. [DONE] Create pause-server and resume-server calls
+. Create rsync or cp sync to MTRAH function
+. Change rmt:send-receive to divert calls to read-only server when possible
+. [DONE] Change start server to call main.db server for 1..N.db servers, block until server is read for use.
+
23WW21
. Dashboard needs its own cache db in /tmp
23WW07
. Remove use of *dbstruct-dbs*
Index: api.scm
==================================================================
--- api.scm
+++ api.scm
@@ -18,317 +18,146 @@
;;
;;======================================================================
(declare (unit api))
(declare (uses db))
+(declare (uses apimod))
+
(declare (uses debugprint))
(declare (uses commonmod))
(declare (uses dbmod))
(declare (uses dbfile))
(declare (uses tasks))
(declare (uses tcp-transportmod))
(import commonmod)
+(import apimod)
(import dbmod)
(import dbfile)
(import debugprint)
(import tcp-transportmod)
(use srfi-69
srfi-18
posix
matchable
- s11n)
-
-;; allow these queries through without starting a server
-;;
-(define api:read-only-queries
- '(get-key-val-pairs
- get-var
- get-keys
- get-key-vals
- test-toplevel-num-items
- get-test-info-by-id
- get-test-state-status-by-id
- get-steps-info-by-id
- get-data-info-by-id
- test-get-rundir-from-test-id
- get-count-tests-running-for-testname
- get-count-tests-running
- get-count-tests-running-in-jobgroup
- get-previous-test-run-record
- get-matching-previous-test-run-records
- test-get-logfile-info
- test-get-records-for-index-file
- get-testinfo-state-status
- test-get-top-process-pid
- test-get-paths-matching-keynames-target-new
- get-prereqs-not-met
- get-count-tests-running-for-run-id
- get-run-info
- get-run-status
- get-run-state
- get-run-stats
- get-run-times
- get-target
- get-targets
- ;; register-run
- get-tests-tags
- get-test-times
- get-tests-for-run
- get-tests-for-run-state-status
- get-test-id
- get-tests-for-runs-mindata
- get-tests-for-run-mindata
- get-run-name-from-id
- get-runs
- simple-get-runs
- get-num-runs
- get-runs-cnt-by-patt
- get-all-run-ids
- get-prev-run-ids
- get-run-ids-matching-target
- get-runs-by-patt
- get-steps-data
- get-steps-for-test
- read-test-data
- read-test-data-varpatt
- login
- tasks-get-last
- testmeta-get-record
- have-incompletes?
- get-changed-record-ids
- get-all-runids
- get-changed-record-test-ids
- get-changed-record-run-ids
- get-run-record-ids
- get-not-completed-cnt))
-
-(define api:write-queries
- '(
- get-keys-write ;; dummy "write" query to force server start
-
- ;; SERVERS
- ;; start-server
- ;; kill-server
-
- ;; TESTS
- test-set-state-status-by-id
- delete-test-records
- delete-old-deleted-test-records
- test-set-state-status
- test-set-top-process-pid
- set-state-status-and-roll-up-items
-
- update-pass-fail-counts
- top-test-set-per-pf-counts ;; (db:top-test-set-per-pf-counts (db:get-db *db* 5) 5 "runfirst")
-
- ;; RUNS
- register-run
- set-tests-state-status
- delete-run
- lock/unlock-run
- update-run-event_time
- mark-incomplete
- set-state-status-and-roll-up-run
- ;; STEPS
- teststep-set-status!
- delete-steps-for-test
- ;; TEST DATA
- test-data-rollup
- csv->test-data
-
- ;; MISC
- sync-cachedb->db
- drop-all-triggers
- create-all-triggers
- update-tesdata-on-repilcate-db
-
- ;; TESTMETA
- testmeta-add-record
- testmeta-update-field
-
- ;; TASKS
- tasks-add
- tasks-set-state-given-param-key
- ))
-
-(define *db-write-mutexes* (make-hash-table))
-(define *server-signature* #f)
-;; ;; 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)
-;; (if (> *api-process-request-count* 50)
-;; (begin
-;; (if (common:low-noise-print 30 "too many threads")
-;; (debug:print 0 *default-log-port* "WARNING: "*api-process-request-count*" threads, potential overload, adding 0.5 sec delay."))
-;; ;; (thread-sleep! 0.5) ;; take a nap - no, the napping is moved to the clients via tt:backoff-incr
-;; ))
-;; (cond
-;; ((not (vector? dat)) ;; it is an error to not receive a vector
-;; (vector #f (vector #f "remote must be called with a vector")))
-;; (else
-;; (let* ((cmd-in (vector-ref dat 0))
-;; (cmd (if (symbol? cmd-in)
-;; cmd-in
-;; (string->symbol cmd-in)))
-;; (params (vector-ref dat 1))
-;; (run-id (if (null? params)
-;; 0
-;; (car params)))
-;; (write-mutex (if (hash-table-exists? *db-write-mutexes* run-id)
-;; (hash-table-ref *db-write-mutexes* run-id)
-;; (let* ((newmutex (make-mutex)))
-;; (hash-table-set! *db-write-mutexes* run-id newmutex)
-;; newmutex)))
-;; (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))))
-;; (if (not readonly-command)
-;; (mutex-lock! write-mutex))
-;; (let* ((tmppath (dbr:dbstruct-tmppath dbstruct))
-;; (clean-run-id (cond
-;; ((number? run-id) run-id)
-;; ((equal? run-id #f) "main")
-;; (else "other")))
-;; (crumbfile (dbfile:wait-for-qif tmppath clean-run-id (cons cmd params)))
-;; (res
-;; (if writecmd-in-readonly-mode
-;; (conc "attempt to run write command "cmd" on a read-only database")
-;; (api:dispatch-request dbstruct cmd run-id params))))
-;; (delete-file* crumbfile)
-;; (if (not readonly-command)
-;; (mutex-unlock! write-mutex))
-;;
-;; ;; save all stats
-;; (let ((delta-t (- (current-milliseconds)
-;; start-t))
-;; (modified-cmd (if (eq? cmd 'general-call)
-;; (string->symbol (conc "general-call-" (car params)))
-;; cmd)))
-;; (hash-table-set! *db-api-call-time* modified-cmd
-;; (cons delta-t (hash-table-ref/default *db-api-call-time* modified-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))))))))
-
-(define *api-threads* '())
-(define (api:register-thread th-in)
- (set! *api-threads* (cons (cons th-in (current-seconds)) *api-threads*)))
-
-(define (api:unregister-thread th-in)
- (set! *api-threads* (filter (lambda (thdat)
- (not (eq? th-in (car thdat))))
- *api-threads*)))
-
-(define (api:remove-dead-or-terminated)
- (set! *api-threads* (filter (lambda (thdat)
- (not (member (thread-state (car thdat)) '(terminated dead))))
- *api-threads*)))
-
-(define (api:get-count-threads-alive)
- (length *api-threads*))
-
+ s11n
+ typed-records)
+
+
+;; QUEUE METHOD
+
+(define (api:tcp-dispatch-request-make-handler-new dbstruct) ;; cmd run-id params)
+ (api:tcp-dispatch-request-make-handler-core dbstruct api:dispatch-request))
+
;; indat is (cmd run-id params meta)
;;
;; WARNING: Do not print anything in the lambda of this function as it
;; reads/writes to current in/out port
;;
-(define (api:tcp-dispatch-request-make-handler dbstruct) ;; cmd run-id params)
+(define (api:tcp-dispatch-request-make-handler-old dbstruct) ;; cmd run-id params)
(assert *toppath* "FATAL: api:tcp-dispatch-request-make-handler called but *toppath* not set.")
(if (not *server-signature*)
(set! *server-signature* (tt:mk-signature *toppath*)))
(lambda (indat)
(api:register-thread (current-thread))
- (let* (;; (indat (deserialize))
- (newcount (+ *api-process-request-count* 1))
- (numthreads (api:get-count-threads-alive))
- (delay-wait (if (> newcount 10)
- (- newcount 10)
- 0))
- (normal-proc (lambda (cmd run-id params)
- (case cmd
- ((ping) *server-signature*)
- (else
- (api:dispatch-request dbstruct cmd run-id params))))))
- (set! *api-process-request-count* newcount)
- (set! *db-last-access* (current-seconds))
- (if (not (eq? newcount numthreads))
- (begin
- (api:remove-dead-or-terminated)
- (let ((threads-now (api:get-count-threads-alive)))
- (debug:print 0 *default-log-port* "WARNING: newcount="newcount", numthreads="numthreads", remaining="threads-now)
- (set! newcount threads-now))))
- (match indat
- ((cmd run-id params meta)
- (let* ((db-ok (let* ((dbfname (dbmod:run-id->dbfname run-id))
- (ok (equal? dbfname (dbr:dbstruct-dbfname dbstruct))))
- (case cmd
- ((ping) #t) ;; we are fine
- (else
- (if (not ok)(debug:print 0 *default-log-port* "ERROR: "cmd", run-id "run-id", not correct for dbfname "(dbr:dbstruct-dbfname dbstruct)))
- (assert ok "FATAL: database file and run-id not aligned.")))))
- (ttdat *server-info*)
- (server-state (tt-state ttdat))
- (status (cond
- ((> newcount 3) 'busy)
- ;; ((> newcount 5) 'loaded) ;; this gets transmitted to the client which calls tt:backoff-incr to slow stuff down.
- (else 'ok)))
- (errmsg (case status
- ((busy) (conc "Server overloaded, "newcount" threads in flight"))
- ((loaded) (conc "Server loaded, "newcount" threads in flight"))
- (else #f)))
- (result (case status
- ((busy)
- (if (eq? cmd 'ping)
- (normal-proc cmd run-id params)
- ;; newcount must be greater than 5 for busy
- (* 1 (- newcount 3)) ;; was 15
- )) ;; (- newcount 29)) ;; call back in as many seconds
- ((loaded)
-;; (if (eq? (rmt:transport-mode) 'tcp)
-;; (thread-sleep! 0.5))
- (normal-proc cmd run-id params))
- (else
- (normal-proc cmd run-id params))))
- (meta (case cmd
- ((ping) `((sstate . ,server-state)))
- (else `((wait . ,delay-wait)))))
- (payload (list status errmsg result meta)))
- (set! *api-process-request-count* (- *api-process-request-count* 1))
- ;; (serialize payload)
- (api:unregister-thread (current-thread))
- payload))
- (else
- (assert #f "FATAL: failed to deserialize indat "indat))))))
-
+ (let* ((result
+ (let* ((numthreads (api:get-count-threads-alive))
+ (delay-wait (if (> numthreads 10)
+ (- numthreads 10)
+ 0))
+ (normal-proc (lambda (cmd run-id params)
+ (case cmd
+ ((ping) *server-signature*)
+ (else
+ (api:dispatch-request dbstruct cmd run-id params))))))
+ (set! *api-process-request-count* numthreads)
+ (set! *db-last-access* (current-seconds))
+;; (if (not (eq? numthreads numthreads))
+;; (begin
+;; (api:remove-dead-or-terminated)
+;; (let ((threads-now (api:get-count-threads-alive)))
+;; (debug:print 0 *default-log-port* "WARNING: numthreads="numthreads", numthreads="numthreads", remaining="threads-now)
+;; (set! numthreads threads-now))))
+ (match indat
+ ((cmd run-id params meta)
+ (let* ((start-t (current-milliseconds))
+ (db-ok (let* ((dbfname (dbmod:run-id->dbfname run-id))
+ (ok (equal? dbfname (dbr:dbstruct-dbfname dbstruct))))
+ (case cmd
+ ((ping) #t) ;; we are fine
+ (else
+ (assert ok "FATAL: database file and run-id not aligned.")))))
+ (ttdat *server-info*)
+ (server-state (tt-state ttdat))
+ (maxthreads 20) ;; make this a parameter?
+ (status (cond
+ ((and (> numthreads maxthreads)
+ (> (random 100) 70)) ;; allow a 30% probability to go through so we can figure out what is going wrong in main.db server.
+ 'busy)
+ ;; ((> numthreads 5) 'loaded) ;; this gets transmitted to the client which calls tt:backoff-incr to slow stuff down.
+ (else 'ok)))
+ (errmsg (case status
+ ((busy) (conc "Server overloaded, "numthreads" threads in flight"))
+ ((loaded) (conc "Server loaded, "numthreads" threads in flight"))
+ (else #f)))
+ (result (case status
+ ((busy)
+ (if (eq? cmd 'ping)
+ (normal-proc cmd run-id params)
+ ;; numthreads must be greater than 5 for busy
+ (* 0.1 (- numthreads maxthreads)) ;; was 15 - return a number for the remote to delay
+ )) ;; (- numthreads 29)) ;; call back in as many seconds
+ ((loaded)
+ ;; (if (eq? (rmt:transport-mode) 'tcp)
+ ;; (thread-sleep! 0.5))
+ (normal-proc cmd run-id params))
+ (else
+ (normal-proc cmd run-id params))))
+ (meta (case cmd
+ ((ping) `((sstate . ,server-state)))
+ (else `((wait . ,delay-wait)))))
+ (payload (list status errmsg result meta)))
+ ;; (cmd run-id params meta)
+ (db:add-stats cmd run-id params (- (current-milliseconds) start-t))
+ payload))
+ (else
+ (assert #f "FATAL: failed to deserialize indat "indat))))))
+ ;; (set! *api-process-request-count* (- *api-process-request-count* 1))
+ ;; (serialize payload)
+
+ (api:unregister-thread (current-thread))
+ result)))
+
+(define api:tcp-dispatch-request-make-handler api:tcp-dispatch-request-make-handler-old) ;; choose -old or -new
+
+(define *api-halt-writes* #f)
(define (api:dispatch-request dbstruct cmd run-id params)
(if (not *no-sync-db*)
(db:open-no-sync-db))
+ (let* ((start-time (current-milliseconds)))
+ (if (member cmd api:write-queries)
+ (let loop ()
+ (if *api-halt-writes*
+ (begin
+ (thread-sleep! 0.2)
+ (if (< (- (current-milliseconds) start-time)
+ 5000) ;; hope it don't take more than five seconds to sync
+ (loop-time)
+ #;(debug:print 0 *default-log-port* "ERROR: writes halted for more than 5 seconds, sync might be taking too long"))))))
+ (db:add-stats 'api-write-blocking-for-sync run-id params (- (current-milliseconds) start-time)))
(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))
+ ((start-server) (apply tt:server-process-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))
@@ -513,43 +342,5 @@
((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))))
-;; 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. Server 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,15 +18,315 @@
;;======================================================================
(declare (unit apimod))
(declare (uses commonmod))
+(declare (uses debugprint))
+(declare (uses dbmod))
+(declare (uses dbfile))
+(declare (uses tcp-transportmod))
(module apimod
*
(import scheme chicken data-structures extras)
-(import (prefix sqlite3 sqlite3:) posix typed-records srfi-18)
+(import (prefix sqlite3 sqlite3:) posix matchable typed-records srfi-1 srfi-18 srfi-69 )
(import commonmod)
+(import debugprint)
+(import dbmod)
+(import dbfile)
+(import tcp-transportmod)
+
+;; allow these queries through without starting a server
+;;
+(define api:read-only-queries
+ '(get-key-val-pairs
+ get-var
+ get-keys
+ get-key-vals
+ test-toplevel-num-items
+ get-test-info-by-id
+ get-test-state-status-by-id
+ get-steps-info-by-id
+ get-data-info-by-id
+ test-get-rundir-from-test-id
+ get-count-tests-running-for-testname
+ get-count-tests-running
+ get-count-tests-running-in-jobgroup
+ get-previous-test-run-record
+ get-matching-previous-test-run-records
+ test-get-logfile-info
+ test-get-records-for-index-file
+ get-testinfo-state-status
+ test-get-top-process-pid
+ test-get-paths-matching-keynames-target-new
+ get-prereqs-not-met
+ get-count-tests-running-for-run-id
+ get-run-info
+ get-run-status
+ get-run-state
+ get-run-stats
+ get-run-times
+ get-target
+ get-targets
+ ;; register-run
+ get-tests-tags
+ get-test-times
+ get-tests-for-run
+ get-tests-for-run-state-status
+ get-test-id
+ get-tests-for-runs-mindata
+ get-tests-for-run-mindata
+ get-run-name-from-id
+ get-runs
+ simple-get-runs
+ get-num-runs
+ get-runs-cnt-by-patt
+ get-all-run-ids
+ get-prev-run-ids
+ get-run-ids-matching-target
+ get-runs-by-patt
+ get-steps-data
+ get-steps-for-test
+ read-test-data
+ read-test-data-varpatt
+ login
+ tasks-get-last
+ testmeta-get-record
+ have-incompletes?
+ get-changed-record-ids
+ get-all-runids
+ get-changed-record-test-ids
+ get-changed-record-run-ids
+ get-run-record-ids
+ get-not-completed-cnt))
+
+(define api:write-queries
+ '(
+ get-keys-write ;; dummy "write" query to force server start
+
+ ;; SERVERS
+ ;; start-server
+ ;; kill-server
+
+ ;; TESTS
+ test-set-state-status-by-id
+ delete-test-records
+ delete-old-deleted-test-records
+ test-set-state-status
+ test-set-top-process-pid
+ set-state-status-and-roll-up-items
+
+ update-pass-fail-counts
+ top-test-set-per-pf-counts ;; (db:top-test-set-per-pf-counts (db:get-db *db* 5) 5 "runfirst")
+
+ ;; RUNS
+ register-run
+ set-tests-state-status
+ delete-run
+ lock/unlock-run
+ update-run-event_time
+ mark-incomplete
+ set-state-status-and-roll-up-run
+ ;; STEPS
+ teststep-set-status!
+ delete-steps-for-test
+ ;; TEST DATA
+ test-data-rollup
+ csv->test-data
+
+ ;; MISC
+ sync-cachedb->db
+ drop-all-triggers
+ create-all-triggers
+ update-tesdata-on-repilcate-db
+
+ ;; TESTMETA
+ testmeta-add-record
+ testmeta-update-field
+
+ ;; TASKS
+ tasks-add
+ tasks-set-state-given-param-key
+ ))
+
+(define *db-write-mutexes* (make-hash-table))
+(define *server-signature* #f)
+
+(define *api-threads* '())
+(define (api:register-thread th-in)
+ (set! *api-threads* (cons (cons th-in (current-seconds)) *api-threads*)))
+
+(define (api:unregister-thread th-in)
+ (set! *api-threads* (filter (lambda (thdat)
+ (not (eq? th-in (car thdat))))
+ *api-threads*)))
+
+(define (api:remove-dead-or-terminated)
+ (set! *api-threads* (filter (lambda (thdat)
+ (not (member (thread-state (car thdat)) '(terminated dead))))
+ *api-threads*)))
+
+(define (api:get-count-threads-alive)
+ (length *api-threads*))
+
+(define *api:last-stats-print* 0)
+(define *api-print-db-stats-mutex* (make-mutex))
+(define (api:print-db-stats)
+ (debug:print-info 0 *default-log-port* "Started periodic db stats printer")
+ (let loop ()
+ (mutex-lock! *api-print-db-stats-mutex*)
+ (if (> (- (current-seconds) *api:last-stats-print*) 15)
+ (begin
+ (dbmod:print-db-stats)
+ (set! *api:last-stats-print* (current-seconds))))
+ (mutex-unlock! *api-print-db-stats-mutex*)
+ (thread-sleep! 5)
+ (loop)))
+
+;; QUEUE METHOD
+
+(define *api:queue-mutex* (make-mutex))
+(define *api:queue-id* 0)
+
+(define *api:in-queue* '())
+(define *api:results* (make-hash-table)) ;; id->queue-item
+
+(defstruct api:queue-item
+ (proc #f)
+ (cmd #f)
+ (run-id #f)
+ (params #f)
+ (start-time (current-seconds))
+ (end-time #f)
+ (id #f)
+ (results #f))
+
+;; Add an item to the incoming queue.
+;;
+(define (api:add-queue-item proc cmd run-id params)
+ (mutex-lock! *api:queue-mutex*)
+ (set! *api:queue-id* (+ *api:queue-id* 1))
+ (set! *api:in-queue*
+ (cons (make-api:queue-item
+ proc: proc
+ cmd: cmd
+ run-id: run-id
+ params: params
+ id: *api:queue-id*
+ )
+ *api:in-queue*))
+ (let ((id *api:queue-id*))
+ (mutex-unlock! *api:queue-mutex*)
+ id)) ;; return id so calling proc can find the result in *api:results*
+
+;; get a queue item from the end of the queue.
+;; return #f if there are no items to be processed.
+;;
+(define (api:get-queue-item)
+ (mutex-lock! *api:queue-mutex*)
+ (let* ((res (if (null? *api:in-queue*)
+ #f
+ (let* ((revlist (reverse *api:in-queue*)))
+ (set! *api:in-queue* (reverse (cdr revlist)))
+ (car revlist)))))
+ (mutex-unlock! *api:queue-mutex*)
+ res))
+
+(define (api:put-item-in-results id item)
+ (hash-table-set! *api:results* id item))
+
+(define (api:retrieve-result-item id)
+ (let ((res (hash-table-ref/default *api:results* id #f)))
+ (if res
+ (begin
+ (hash-table-delete! *api:results* id)
+ res)
+ #f)))
+
+;; timeout is in ms, poll less frequently over time
+;;
+;; Yes, it would be better to do this with mailboxes. My last attempt to use
+;; mailboxes resulted in erratic behavior but that was likely due to something
+;; unrelated. Just to eliminate uncertainty we'll start with polling and switch
+;; to mailboxes laters.
+;;
+(define (api:wait-for-result id #!key (timeout 30000))
+ (let loop ((start (current-milliseconds)))
+ (thread-sleep! (let ((delta (- (current-milliseconds) start)))
+ (cond
+ ((< delta 500) 0.01)
+ ((< delta 5000) 0.1)
+ ((< delta 10000) 0.25)
+ (else 1.25))))
+ (let ((res (api:retrieve-result-item id)))
+ (if res
+ (api:queue-item-results res)
+ (loop start)))))
+
+(define (api:queue-run-one)
+ (let* ((item (api:get-queue-item))) ;; this removes it from the in-queue
+ (if item
+ (let* ((id (api:queue-item-id item))
+ (proc (api:queue-item-proc item))
+ (result (proc)))
+ (api:queue-item-end-time-set! item (current-seconds))
+ (api:queue-item-results-set! item result)
+ (api:put-item-in-results id item)))))
+(define (api:queue-processor)
+ (let* ((thproc (lambda ()
+ (let loop ()
+ (api:queue-run-one)
+ (thread-sleep! 0.1)
+ (loop)))))
+ (let loop ((thnum 0))
+ (thread-start! (make-thread thproc (conc "queue-thread-" thnum)))
+ (thread-sleep! 0.05)
+ (if (< thnum 20)
+ (loop (+ thnum 1))))))
+(define (api:tcp-dispatch-request-make-handler-core dbstruct api:dispatch-request)
+ (assert *toppath* "FATAL: api:tcp-dispatch-request-make-handler called but *toppath* not set.")
+ (if (not *server-signature*)
+ (set! *server-signature* (tt:mk-signature *toppath*)))
+ (lambda (indat)
+ (let* ((outer-proc (lambda (cmd run-id params)
+ (case cmd
+ ((ping) *server-signature*) ;; but ping in api:dispatch-request is (current-process-id)?
+ (else
+ (let* ((id (api:add-queue-item
+ (lambda ()
+ (api:dispatch-request dbstruct cmd run-id params))
+ cmd run-id params)))
+ (api:wait-for-result id)))))))
+ ;; (set! *api-process-request-count* numthreads)
+ (set! *db-last-access* (current-seconds))
+ (match indat
+ ((cmd run-id params meta)
+ (let* ((start-t (current-milliseconds))
+ ;; factor this out and move before this let, it is just
+ ;; an assert if not ping and dbfname is not correct
+ (db-ok (let* ((dbfname (dbmod:run-id->dbfname run-id))
+ (ok (equal? dbfname (dbr:dbstruct-dbfname dbstruct))))
+ (case cmd
+ ((ping) #t) ;; we are fine
+ (else
+ (assert ok "FATAL: database file and run-id not aligned.")))))
+ (ttdat *server-info*)
+ (server-state (tt-state ttdat))
+ (status 'ok) ;; anything legit we can do with status?
+ (delay-wait 0)
+ (result (if (eq? cmd 'ping)
+ *server-signature* ;; (current-process-id) ;; process id or server-signature?
+ (outer-proc cmd run-id params)))
+ (meta (case cmd
+ ((ping) `((sstate . ,server-state)))
+ (else `((wait . ,delay-wait)))))
+ (errmsg "")
+ (payload (list status errmsg result meta)))
+ ;; (cmd run-id params meta)
+ (db:add-stats cmd run-id params (- (current-milliseconds) start-t))
+ payload))
+ (else
+ (assert #f "FATAL: failed to deserialize indat "indat))))))
)
Index: archive.scm
==================================================================
--- archive.scm
+++ archive.scm
@@ -22,16 +22,18 @@
(declare (uses db))
(declare (uses debugprint))
(declare (uses mtargs))
(declare (uses common))
(declare (uses commonmod))
+(declare (uses configfmod))
(declare (uses rmtmod))
(use (prefix sqlite3 sqlite3:) srfi-1 posix regex regex-case srfi-69
format md5 message-digest srfi-18)
(import commonmod
+ configfmod
debugprint
rmtmod
(prefix mtargs args:))
(include "common_records.scm")
@@ -359,11 +361,11 @@
(archive-dir (if archive-info (cdr archive-info) #f))
(archive-id (if archive-info (car archive-info) -1))
(home-host (server:choose-server *toppath* 'homehost))
(archive-time (seconds->std-time-str (current-seconds)))
(archive-staging-db (conc *toppath* "/.db-snapshot/archive_" archive-time))
- (tmp-db-path (conc (common:get-db-tmp-area) "/megatest.db"))
+ (tmp-db-path (conc (dbfile:make-tmpdir-name *toppath* "") "/megatest.db"))
(dbfile (conc archive-staging-db "/megatest.db")))
(create-directory archive-staging-db #t)
(let-values (((pid-val exit-status exit-code) (run-n-wait rsync-exe params: (list "-v" (conc (car home-host) ":"tmp-db-path) archive-staging-db) print-cmd: print-prefix)))
(if (eq? exit-code 0)
(case archiver
@@ -407,11 +409,11 @@
(bup-restore-params (list "-d" archive-path "restore" "-C" *toppath* archive-internal-path)))
(debug:print-info 2 *default-log-port* "Restoring archived data to " *toppath* " from archive in " archive-path " ... " archive-internal-path)
(run-n-wait bup-exe params: bup-restore-params print-cmd: "Running:"))
(sleep 2)
(db:multi-db-sync
- (db:setup #t) ;; (db:setup-db *dbstruct-dbs* *toppath* #f)
+ (db:setup) ;; (db:setup-db *dbstruct-dbs* *toppath* #f)
'killservers
;'dejunk
;'adj-testids
'old2new
)
Index: common.scm
==================================================================
--- common.scm
+++ common.scm
@@ -18,13 +18,16 @@
;;======================================================================
(declare (unit common))
(declare (uses commonmod))
+(declare (uses processmod))
+(declare (uses configfmod))
(declare (uses rmtmod))
(declare (uses debugprint))
(declare (uses mtargs))
+
(use srfi-1 data-structures posix regex-case (prefix base64 base64:)
format dot-locking csv-xml z3 udp ;; sql-de-lite
hostinfo md5 message-digest typed-records directory-utils stack
matchable regex posix (srfi 18) extras ;; tcp
@@ -34,11 +37,13 @@
)
(use posix-extras pathname-expand files)
(import commonmod
+ processmod
debugprint
+ configfmod
rmtmod
(prefix mtargs args:))
(include "common_records.scm")
@@ -76,27 +81,10 @@
(print-error-message exn) ))))
(debug:print-info 0 *default-log-port* " -- continuing after nonfatal condition...")
#f)
(thunk)))
-(define getenv get-environment-variable)
-(define (safe-setenv key val)
- (if (or (substring-index "!" key)
- (substring-index ":" key) ;; variables containing : are for internal use and cannot be environment variables.
- (substring-index "." key)) ;; periods are not allowed in environment variables
- (debug:print-error 4 *default-log-port* "skip setting internal use only variables containing \":\" or starting with \"!\"")
- (if (and (string? val)
- (string? key))
- (handle-exceptions
- exn
- (debug:print-error 0 *default-log-port* "bad value for setenv, key=" key ", value=" val ", exn=" exn)
- (setenv key val))
- (debug:print-error 0 *default-log-port* "bad value for setenv, key=" key ", value=" val))))
-
-(define home (getenv "HOME"))
-(define user (getenv "USER"))
-
;; returns list of fd count, socket count
(define (get-file-descriptor-count #!key (pid (current-process-id )))
(list
(length (glob (conc "/proc/" pid "/fd/*")))
@@ -139,11 +127,11 @@
(define *pkts-info* (make-hash-table)) ;; store stuff like the last parent here
(define *configinfo* #f) ;; raw results from setup, includes toppath and table from megatest.config
(define *runconfigdat* #f) ;; run configs data
(define *configdat* #f) ;; megatest.config data
(define *configstatus* #f) ;; status of data; 'fulldata : all processing done, #f : no data yet, 'partialdata : partial read done
-(define *toppath* #f)
+;; (define *toppath* #f) ;; moved to commonmod
(define *already-seen-runconfig-info* #f)
(define *test-meta-updated* (make-hash-table))
(define *globalexitstatus* 0) ;; attempt to work around possible thread issues
(define *passnum* 0) ;; when running track calls to run-tests or similar
@@ -153,14 +141,10 @@
(define *time-zero* (current-seconds)) ;; for the watchdog
(define *on-exit-procs* '()) ;; add procs to this list to be executed on exit
(define *default-area-tag* "local")
;; DATABASE
-;; (define *dbstruct-dbs* #f) ;; used to cache the dbstruct in db:setup. Goal is to remove this.
-;; db stats
-(define *db-stats* (make-hash-table)) ;; hash of vectors < count duration-total >
-(define *db-stats-mutex* (make-mutex))
;; db access
(define *db-last-access* (current-seconds)) ;; last db access, used in server
;; (define *db-write-access* #t)
;; db sync
;; (define *db-last-sync* 0) ;; last time the sync to megatest.db happened
@@ -179,13 +163,12 @@
(define *transport-type* 'http) ;; override with [server] transport http|rpc|nmsg
(define *runremote* #f) ;; if set up for server communication this will hold
;; (define *max-cache-size* 0)
(define *logged-in-clients* (make-hash-table))
(define *server-id* #f)
-(define *server-info* #f) ;; good candidate for easily convert to non-global
+;; (define *server-info* #f) ;; good candidate for easily convert to non-global
(define *time-to-exit* #f)
-(define *server-run* #t)
(define *run-id* #f)
(define *server-kind-run* (make-hash-table))
(define *home-host* #f)
;; (define *total-non-write-delay* 0)
(define *heartbeat-mutex* (make-mutex))
@@ -247,11 +230,11 @@
(define *common:this-exe-fullpath* (common:get-this-exe-fullpath))
(define *common:this-exe-dir* (pathname-directory *common:this-exe-fullpath*))
(define *common:this-exe-name* (pathname-strip-directory *common:this-exe-fullpath*))
(define (common:get-sync-lock-filepath)
- (let* ((tmp-area (common:get-db-tmp-area))
+ (let* ((tmp-area (common:make-tmpdir-name *toppath* ""))
(lockfile (conc tmp-area "/megatest.db.lock")))
lockfile))
(define *common:logpro-exit-code->status-sym-alist*
'( ( 0 . pass )
@@ -429,12 +412,11 @@
'adj-target
'new2old
'(dejunk)
))
((tcp nfs)
- (debug:print 0 *default-log-port* "WARNING: cleanup-db NOT implemented yet for tcp and nfs.")
- #;(apply db:multi-db-sync
+ (apply db:multi-db-sync
dbstruct
'schema
'killservers
'adj-target
'new2old
@@ -618,11 +600,11 @@
(common:on-homehost?))
(if (common:api-changed?)
(let* ((mtconf (conc (get-environment-variable "MT_RUN_AREA_HOME") "/megatest.config"))
(dbfile (conc (get-environment-variable "MT_RUN_AREA_HOME") ".mtdb/main.db"))
(read-only (not (file-write-access? dbfile)))
- (dbstruct (db:setup #t))) ;; (db:setup-db *dbstruct-dbs* *toppath* #f))) ;; #t)))
+ (dbstruct (db:setup))) ;; (db:setup-db *dbstruct-dbs* *toppath* #f))) ;; #t)))
(debug:print 0 *default-log-port*
"WARNING: Version mismatch!\n"
" expected: " (common:version-signature) "\n"
" got: " (common:get-last-run-version))
(cond
@@ -1190,46 +1172,10 @@
rtestpatt)
(else
(debug:print-info 0 *default-log-port* "using testpatt " args-testpatt " rtestpatt:" rtestpatt)
args-testpatt))))
-(define (common:false-on-exception thunk #!key (message #f))
- (handle-exceptions exn
- (begin
- (if message
- (debug:print-info 0 *default-log-port* message))
- #f) (thunk) ))
-
-(define (common:file-exists? path-string #!key (silent #f))
- ;;;; TODO: catch permission denied exceptions and emit appropriate warnings. Might be able to get rid of with chicken 5?
- (common:false-on-exception (lambda () (file-exists? path-string))
- message: (if (not silent)
- (conc "Unable to access path: " path-string)
- #f)
- ))
-
-(define (common:directory-exists? path-string)
- ;;;; TODO: catch permission denied exceptions and emit appropriate warnings
- (common:false-on-exception (lambda () (directory-exists? path-string))
- message: (conc "Unable to access path: " path-string)
- ))
-
-;;======================================================================
-;; does the directory exist and do we have write access?
-;;
-;; returns the directory or #f
-;;
-(define (common:directory-writable? path-string)
- (handle-exceptions
- exn
- (begin
- (debug:print 0 *default-log-port* "Failed to identify access to " path-string ", exn=" exn)
- #f)
- (if (and (directory-exists? path-string)
- (file-write-access? path-string))
- path-string
- #f)))
(define (common:get-linktree)
(or (getenv "MT_LINKTREE")
(if *configdat*
(configf:lookup *configdat* "setup" "linktree")
@@ -1533,11 +1479,11 @@
;;
(define (common:lazy-modification-time fpath)
(handle-exceptions
exn
(begin
- (debug:print 0 *default-log-port* "Failed to get modifcation time for " fpath ", treating it as zero. exn=" exn)
+ (debug:print 2 *default-log-port* "Failed to get modification time for " fpath ", treating it as zero. exn=" exn)
0)
(if (file-exists? fpath)
(file-modification-time fpath)
0)))
@@ -1556,55 +1502,14 @@
(apply max
(map
common:lazy-modification-time
file-list))))
-;;======================================================================
-;; return a nice clean pathname made absolute
-(define (common:nice-path dir)
- (let ((match (string-match "^(~[^\\/]*)(\\/.*|)$" dir)))
- (if match ;; using ~ for home?
- (common:nice-path (conc (common:read-link-f (cadr match)) "/" (caddr match)))
- (normalize-pathname (if (absolute-pathname? dir)
- dir
- (conc (current-directory) "/" dir))))))
-
;;======================================================================
;; make "nice-path" available in config files and the repl
(define nice-path common:nice-path)
-(define (common:read-link-f path)
- (handle-exceptions
- exn
- (begin
- (debug:print-error 0 *default-log-port* "command \"/bin/readlink -f " path "\" failed. exn=" exn)
- path) ;; just give up
- (with-input-from-pipe
- (conc "/bin/readlink -f " path)
- (lambda ()
- (read-line)))))
-
-;; for reasons I don't understand multiple calls to real-path in parallel threads
-;; must be protected by mutexes
-;;
-(define (common:real-path inpath)
- ;; (process:cmd-run-with-stderr->list "readlink" "-f" inpath)) ;; cmd . params)
- ;; (let-values
- ;; (((inp oup pid) (process "readlink" (list "-f" inpath))))
- ;; (with-input-from-port inp
- ;; (let loop ((inl (read-line))
- ;; (res #f))
- ;; (print "inl=" inl)
- ;; (if (eof-object? inl)
- ;; (begin
- ;; (close-input-port inp)
- ;; (close-output-port oup)
- ;; ;; (process-wait pid)
- ;; res)
- ;; (loop (read-line) inl))))))
- (with-input-from-pipe (conc "readlink -f " inpath) read-line))
-
;;======================================================================
;; returns *effective load* (not normalized)
;;
(define (common:get-intercept onemin fivemin)
(if (< onemin fivemin) ;; load is decreasing, just use the onemin load
@@ -1649,12 +1554,12 @@
;; (let loop ((x 0))
;; (print x "," (common:get-delay x 1))
;; (if (< x 2)
;; (loop (+ x 0.1)))))
-(define (get-cpu-load #!key (remote-host #f))
- (car (common:get-cpu-load remote-host)))
+;; (define (get-cpu-load #!key (remote-host #f))
+;; (car (common:get-cpu-load remote-host)))
;;======================================================================
;; (let* ((load-res (process:cmd-run->list "uptime"))
;; (load-rx (regexp "load average:\\s+(\\d+)"))
;; (cpu-load #f))
@@ -1666,18 +1571,18 @@
;; (set! cpu-load newval))))))
;; (car load-res))
;; cpu-load))
;;======================================================================
-;; get values from cached info from dropping file in logs dir
+;; get values from cached info from dropping file in .sysdata dir
;; e.g. key is host and dtype is normalized-load
;;
(define (common:get-cached-info key dtype #!key (age 10))
(if *toppath*
(let* ((fullpath (conc *toppath* "/.sysdata/" key "-" dtype ".log"))
(delfile (lambda (exn)
- (debug:print-info 1 *default-log-port* " removing bad file " fullpath ", exn=" exn)
+ (debug:print-info 2 *default-log-port* " removing bad file " fullpath ", exn=" exn)
(delete-file* fullpath)
#f)))
(if (and (file-exists? fullpath)
(file-read-access? fullpath))
(handle-exceptions
@@ -2280,11 +2185,11 @@
(define (common:check-db-dir-space)
(let* ((required (string->number
;; default is 1GB (or actually a billion bytes) This is the number of 1 kB blocks.
(or (configf:lookup *configdat* "setup" "dbdir-space-required")
"1000000")))
- (dbdir (common:get-db-tmp-area)) ;; (db:get-dbdir))
+ (dbdir (common:make-tmpdir-name *toppath* "")) ;; (db:get-dbdir))
(tdbspace (common:check-space-in-dir dbdir required))
(mdbspace (common:check-space-in-dir *toppath* required)))
(sort (list tdbspace mdbspace) (lambda (a b)
(< (cadr a)(cadr b))))))
@@ -3035,50 +2940,10 @@
`(,(alist-ref 't x) . ,(string->number (alist-ref 'D x))))
pkts)
(lambda (a b)(> (cdr a)(cdr b)))) ;; sort descending
(lambda (a b)(equal? (car a)(car b))))) ;; remove duplicates by target
-;;======================================================================
-;; accept an alist or hash table containing envvar/env value pairs (value of #f causes unset)
-;; execute thunk in context of environment modified as per this list
-;; restore env to prior state then return value of eval'd thunk.
-;; ** this is not thread safe **
-(define (common:with-env-vars delta-env-alist-or-hash-table thunk)
- (let* ((delta-env-alist (if (hash-table? delta-env-alist-or-hash-table)
- (hash-table->alist delta-env-alist-or-hash-table)
- delta-env-alist-or-hash-table))
- (restore-thunks
- (filter
- identity
- (map (lambda (env-pair)
- (let* ((env-var (car env-pair))
- (new-val (let ((tmp (cdr env-pair)))
- (if (list? tmp) (car tmp) tmp)))
- (current-val (get-environment-variable env-var))
- (restore-thunk
- (cond
- ((not current-val) (lambda () (unsetenv env-var)))
- ((not (string? new-val)) #f)
- ((eq? current-val new-val) #f)
- (else
- (lambda () (setenv env-var current-val))))))
- ;;(when (not (string? new-val))
- ;; (debug:print 0 *default-log-port* " PROBLEM: not a string: "new-val"\n from env-alist:\n"delta-env-alist)
- ;; (pp delta-env-alist)
- ;; (exit 1))
-
-
- (cond
- ((not new-val) ;; modify env here
- (unsetenv env-var))
- ((string? new-val)
- (setenv env-var new-val)))
- restore-thunk))
- delta-env-alist))))
- (let ((rv (thunk)))
- (for-each (lambda (x) (x)) restore-thunks) ;; restore env to original state
- rv)))
(define *common:thread-punchlist* (make-hash-table))
(define (common:send-thunk-to-background-thread thunk #!key (name #f))
;;(BB> "launched thread " name)
;; we need a unique name for the thread.
Index: commonmod.scm
==================================================================
--- commonmod.scm
+++ commonmod.scm
@@ -64,10 +64,11 @@
chicken.condition
chicken.file
chicken.file.posix
chicken.io
chicken.pathname
+ chicken.port
chicken.process
chicken.process-context
chicken.process-context.posix
chicken.sort
chicken.string
@@ -83,10 +84,12 @@
srfi-1
srfi-18
srfi-69
typed-records
system-information
+
+ debugprint
)))
;;======================================================================
;; CONTENTS
;;
@@ -121,10 +124,111 @@
(begin
(hash-table-set! *common:denoise* key currtime)
#t)
#f)))
+;; environment vars handy stuff from common.scm
+;;
+(define getenv get-environment-variable)
+(define (safe-setenv key val)
+ (if (or (substring-index "!" key)
+ (substring-index ":" key) ;; variables containing : are for internal use and cannot be environment variables.
+ (substring-index "." key)) ;; periods are not allowed in environment variables
+ (debug:print-error 4 *default-log-port* "skip setting internal use only variables containing \":\" or starting with \"!\"")
+ (if (and (string? val)
+ (string? key))
+ (handle-exceptions
+ exn
+ (debug:print-error 0 *default-log-port* "bad value for setenv, key=" key ", value=" val ", exn=" exn)
+ (setenv key val))
+ (debug:print-error 0 *default-log-port* "bad value for setenv, key=" key ", value=" val))))
+
+;;======================================================================
+;; accept an alist or hash table containing envvar/env value pairs (value of #f causes unset)
+;; execute thunk in context of environment modified as per this list
+;; restore env to prior state then return value of eval'd thunk.
+;; ** this is not thread safe **
+(define (common:with-env-vars delta-env-alist-or-hash-table thunk)
+ (let* ((delta-env-alist (if (hash-table? delta-env-alist-or-hash-table)
+ (hash-table->alist delta-env-alist-or-hash-table)
+ delta-env-alist-or-hash-table))
+ (restore-thunks
+ (filter
+ identity
+ (map (lambda (env-pair)
+ (let* ((env-var (car env-pair))
+ (new-val (let ((tmp (cdr env-pair)))
+ (if (list? tmp) (car tmp) tmp)))
+ (current-val (get-environment-variable env-var))
+ (restore-thunk
+ (cond
+ ((not current-val) (lambda () (unsetenv env-var)))
+ ((not (string? new-val)) #f)
+ ((eq? current-val new-val) #f)
+ (else
+ (lambda () (setenv env-var current-val))))))
+ ;;(when (not (string? new-val))
+ ;; (debug:print 0 *default-log-port* " PROBLEM: not a string: "new-val"\n from env-alist:\n"delta-env-alist)
+ ;; (pp delta-env-alist)
+ ;; (exit 1))
+
+
+ (cond
+ ((not new-val) ;; modify env here
+ (unsetenv env-var))
+ ((string? new-val)
+ (setenv env-var new-val)))
+ restore-thunk))
+ delta-env-alist))))
+ (let ((rv (thunk)))
+ (for-each (lambda (x) (x)) restore-thunks) ;; restore env to original state
+ rv)))
+
+(define home (getenv "HOME"))
+(define user (getenv "USER"))
+
+;;======================================================================
+;; return a nice clean pathname made absolute
+(define (common:nice-path dir)
+ (let ((match (string-match "^(~[^\\/]*)(\\/.*|)$" dir)))
+ (if match ;; using ~ for home?
+ (common:nice-path (conc (common:read-link-f (cadr match)) "/" (caddr match)))
+ (normalize-pathname (if (absolute-pathname? dir)
+ dir
+ (conc (current-directory) "/" dir))))))
+
+(define (common:read-link-f path)
+ (handle-exceptions
+ exn
+ (begin
+ (debug:print-error 0 *default-log-port* "command \"/bin/readlink -f " path "\" failed. exn=" exn)
+ path) ;; just give up
+ (with-input-from-pipe
+ (conc "/bin/readlink -f " path)
+ (lambda ()
+ (read-line)))))
+
+;; for reasons I don't understand multiple calls to real-path in parallel threads
+;; must be protected by mutexes
+;;
+(define (common:real-path inpath)
+ ;; (process :cmd-run-with-stderr->list "readlink" "-f" inpath)) ;; cmd . params)
+ ;; (let-values
+ ;; (((inp oup pid) (process "readlink" (list "-f" inpath))))
+ ;; (with-input-from-port inp
+ ;; (let loop ((inl (read-line))
+ ;; (res #f))
+ ;; (print "inl=" inl)
+ ;; (if (eof-object? inl)
+ ;; (begin
+ ;; (close-input-port inp)
+ ;; (close-output-port oup)
+ ;; ;; (process-wait pid)
+ ;; res)
+ ;; (loop (read-line) inl))))))
+ (with-input-from-pipe (conc "readlink -f " inpath) read-line))
+
;; KEEP THIS ONE
;;
;; client:get-signature
(define *my-client-signature* #f)
@@ -132,10 +236,50 @@
(define (client:get-signature)
(if *my-client-signature* *my-client-signature*
(let ((sig (conc (get-host-name) " " (current-process-id))))
(set! *my-client-signature* sig)
*my-client-signature*)))
+
+(define *server-info* #f)
+(define *toppath* #f)
+
+(define (common:false-on-exception thunk #!key (message #f))
+ (handle-exceptions exn
+ (begin
+ (if message
+ (debug:print-info 0 *default-log-port* message))
+ #f) (thunk) ))
+
+(define (common:file-exists? path-string #!key (silent #f))
+ ;;;; TODO: catch permission denied exceptions and emit appropriate warnings. Might be able to get rid of with chicken 5?
+ (common:false-on-exception (lambda () (file-exists? path-string))
+ message: (if (not silent)
+ (conc "Unable to access path: " path-string)
+ #f)
+ ))
+
+(define (common:directory-exists? path-string)
+ ;;;; TODO: catch permission denied exceptions and emit appropriate warnings
+ (common:false-on-exception (lambda () (directory-exists? path-string))
+ message: (conc "Unable to access path: " path-string)
+ ))
+
+;;======================================================================
+;; does the directory exist and do we have write access?
+;;
+;; returns the directory or #f
+;;
+(define (common:directory-writable? path-string)
+ (handle-exceptions
+ exn
+ (begin
+ (debug:print 0 *default-log-port* "Failed to identify access to " path-string ", exn=" exn)
+ #f)
+ (if (and (directory-exists? path-string)
+ (file-write-access? path-string))
+ path-string
+ #f)))
;;======================================================================
;; config file utils
;;======================================================================
@@ -160,10 +304,17 @@
'()))) ;; should it return empty list or #f to indicate not set?
(define (get-section cfgdat section)
(hash-table-ref/default cfgdat section '()))
+
+(define (common:make-tmpdir-name areapath tmpadj)
+ (let* ((area (pathname-file areapath))
+ (dname (conc "/tmp/"(current-user-name)"/megatest_localdb/" area "/" (string-translate areapath "/" ".") tmpadj "/.mtdb")))
+ (unless (directory-exists? dname)
+ (create-directory dname #t))
+ dname))
;; dot-locking egg seems not to work, using this for now
;; if lock is older than expire-time then remove it and try again
;; to get the lock
;;
@@ -287,13 +438,16 @@
(filter (lambda (x)
(not (string-match "^\\s*" x)))
val-list))
'())))
-(define (get-cpu-load)
- (let* ((load-info (with-input-from-file "/proc/loadavg" read-lines)))
- (map string->number (string-split load-info))))
+(define (commonmod:get-cpu-load)
+ (let* ((load-info (with-input-from-file "/proc/loadavg" read-lines))
+ (res (map string->number (string-split (car load-info)))))
+ (if (null? res)
+ #f ;; something is wrong
+ (car res))))
(define *current-host-cores* #f)
(define (get-current-host-cores)
(or *current-host-cores*
@@ -315,11 +469,11 @@
(string->number (read-line)))))
;; get the normalized (i.e. load / numcpus) for *this* host
;;
(define (get-normalized-cpu-load)
- (/ (get-cpu-load)(get-current-host-cores)))
+ (/ (commonmod:get-cpu-load)(get-current-host-cores)))
;;======================================================================
;; testsuite and area utilites
;;======================================================================
@@ -399,14 +553,13 @@
((d) 86400)
((w) 604800)
((M) 2628000) ;; aproximately one month
((y) 31536000)
(else
- 0)))))))
- ;; (print "ERROR: can't parse timestring "tstr", component "part)
- ;; can't (yet) use debugprint. rely on -show-config for user to find errors
- )))
+ 0)))))
+ (debug:print 0 *default-log-port* "ERROR: can't parse timestring "tstr", component "part", string: "(cadr match))))
+ (debug:print 0 *default-log-port* "ERROR: can't parse timestring "tstr", component "part))))
parts)
time-secs))
(define (seconds->hr-min-sec secs)
(let* ((hrs (quotient secs 3600))
Index: configf.scm
==================================================================
--- configf.scm
+++ configf.scm
@@ -31,87 +31,72 @@
(declare (uses mtargs))
(declare (uses mtargs.import))
(declare (uses common))
(declare (uses commonmod))
(declare (uses commonmod.import))
+(declare (uses processmod))
+(declare (uses processmod.import))
+(declare (uses configfmod))
+(declare (uses configfmod.import))
+(declare (uses dbfile))
+(declare (uses dbfile.import))
+(declare (uses dbmod))
+(declare (uses dbmod.import))
+
(import commonmod
+ configfmod
+ processmod
(prefix mtargs args:)
debugprint)
(include "common_records.scm")
-;; return list (path fullpath configname)
-(define (find-config configname #!key (toppath #f))
- (if toppath
- (let ((cfname (conc toppath "/" configname)))
- (if (common:file-exists? cfname)
- (list toppath cfname configname)
- (list #f #f #f)))
- (let* ((cwd (string-split (current-directory) "/")))
- (let loop ((dir cwd))
- (let* ((path (conc "/" (string-intersperse dir "/")))
- (fullpath (conc path "/" configname)))
- (if (common:file-exists? fullpath)
- (list path fullpath configname)
- (let ((remcwd (take dir (- (length dir) 1))))
- (if (null? remcwd)
- (list #f #f #f) ;; #f #f)
- (loop remcwd)))))))))
-
-(define (configf:assoc-safe-add alist key val #!key (metadata #f))
- (let ((newalist (filter (lambda (x)(not (equal? key (car x)))) alist)))
- (append newalist (list (if metadata
- (list key val metadata)
- (list key val))))))
-
-;; this is used in megatestqa/ext.scm.
-;; remove it from here and there by 12/31/21
-;; (define config:assoc-safe-add configf:assoc-safe-add)
-
-(define (configf:section-var-set! cfgdat section-name var value #!key (metadata #f))
- (hash-table-set! cfgdat section-name
- (configf:assoc-safe-add
- (hash-table-ref/default cfgdat section-name '())
- var value metadata: metadata)))
-
-(define (configf:eval-string-in-environment str)
- ;; (if (or (string-null? str)
- ;; (equal? "!" (substring str 0 1))) ;; null string or starts with ! are preserved but NOT set in the environment
- str
- (handle-exceptions
- exn
- (begin
- (debug:print-error 0 *default-log-port* "problem evaluating \"" str "\" in the shell environment, exn=" exn)
- #f)
- (let ((cmdres (process:cmd-run->list (conc "echo " str))))
- (if (null? cmdres) ""
- (caar cmdres))))) ;; )
-
-;;======================================================================
-;; Make the regexp's needed globally available
-;;======================================================================
-
-(define configf:include-rx (regexp "^\\[include\\s+(.*)\\]\\s*$"))
-(define configf:script-rx (regexp "^\\[scriptinc\\s+(\\S+)([^\\]]*)\\]\\s*$")) ;; include output from a script
-(define configf:section-rx (regexp "^\\[(.*)\\]\\s*$"))
-(define configf:blank-l-rx (regexp "^\\s*$"))
-(define configf:key-sys-pr (regexp "^(\\S+)\\s+\\[system\\s+(\\S+.*)\\]\\s*$"))
-(define configf:key-val-pr (regexp "^(\\S+)(\\s+(.*)|())$"))
-(define configf:key-no-val (regexp "^(\\S+)(\\s*)$"))
-(define configf:comment-rx (regexp "^\\s*#.*"))
-(define configf:cont-ln-rx (regexp "^(\\s+)(\\S+.*)$"))
-(define configf:settings (regexp "^\\[configf:settings\\s+(\\S+)\\s+(\\S+)]\\s*$"))
-
-;; read a line and process any #{ ... } constructs
-
-(define configf:var-expand-regex (regexp "^(.*)#\\{(scheme|system|shell|getenv|get|runconfigs-get|rget|scm|sh|rp|gv|g|mtrah)\\s+([^\\}\\{]*)\\}(.*)"))
-
-(define (configf:system ht cmd)
- (system cmd)
- )
-
-(define configf:imports "(import commonmod (prefix mtargs args:))")
+(define configf:imports "(import commonmod configfmod processmod (prefix mtargs args:))")
+
+(define (configf:write-alist cdat fname)
+ (if (not (common:faux-lock fname))
+ (debug:print 0 *default-log-port* "INFO: Could not get lock on " fname))
+ (let* ((dat (configf:config->alist cdat))
+ (res
+ (begin
+ (with-output-to-file fname ;; first write out the file
+ (lambda ()
+ (pp dat)))
+
+ (if (common:file-exists? fname) ;; now verify it is readable
+ (if (configf:read-alist fname)
+ #t ;; data is good.
+ (begin
+ (handle-exceptions
+ exn
+ (begin
+ (debug:print 0 *default-log-port* "deleting " fname " failed, exn=" exn)
+ #f)
+ (debug:print 0 *default-log-port* "WARNING: content " dat " for cache " fname " is not readable. Deleting generated file.")
+ (delete-file fname))
+ #f))
+ #f))))
+ (common:faux-unlock fname)
+ res))
+
+;; pathenvvar will set the named var to the path of the config
+(define (find-and-read-config fname #!key (environ-patt #f)(given-toppath #f)(pathenvvar #f))
+ (let* ((curr-dir (current-directory))
+ (configinfo (find-config fname toppath: given-toppath))
+ (toppath (car configinfo))
+ (configfile (cadr configinfo))
+ (set-fields (lambda (curr-section next-section ht path)
+ (let ((field-names (if ht (common:get-fields ht) '()))
+ (target (or (getenv "MT_TARGET")(args:get-arg "-reqtarg")(args:get-arg "-target"))))
+ (debug:print-info 9 *default-log-port* "set-fields with field-names=" field-names " target=" target " curr-section=" curr-section " next-section=" next-section " path=" path " ht=" ht)
+ (if (not (null? field-names))(keys:target-set-args field-names target #f))))))
+ (if toppath (change-directory toppath))
+ (if (and toppath pathenvvar)(setenv pathenvvar toppath))
+ (let ((configdat (if configfile
+ (read-config configfile #f #t environ-patt: environ-patt post-section-procs: (list (cons "^fields$" set-fields)) #f))))
+ (if toppath (change-directory curr-dir))
+ (list configdat toppath configfile fname))))
(define (configf:process-line l ht allow-system #!key (linenum #f))
(let loop ((res l))
(if (string? res)
(let ((matchdat (string-search configf:var-expand-regex res)))
@@ -165,27 +150,10 @@
(debug:print-info 9 *default-log-port* "for line \"" l "\"\n command: " cmd " took " delta " seconds to run with output:\n " result)))))
(loop (conc prestr result poststr)))
res))
res)))
-;; Run a shell command and return the output as a string
-(define (shell cmd)
- (let* ((output (process:cmd-run->list cmd))
- (res (car output))
- (status (cadr output)))
- (if (equal? status 0)
- (let ((outres (string-intersperse
- res
- "\n")))
- (debug:print-info 4 *default-log-port* "shell result:\n" outres)
- outres)
- (begin ;; why is this printing to error-port and not using debug:print? -mrw-
- (with-output-to-port (current-error-port)
- (lambda ()
- (print "ERROR: " cmd " returned bad exit code " status)))
- ""))))
-
;; this was inline but I'm pretty sure that is a hold over from when it was *very* simple ...
;;
(define (configf:read-line p ht allow-processing settings)
(let loop ((inl (read-line p)))
(let ((cont-line (and (string? inl)
@@ -209,62 +177,10 @@
(if (and (string? res) ;; must set to "no" to force NOT trimming trailing spaces
(not (equal? (hash-table-ref/default settings "trim-trailing-spaces" "yes") "no")))
(string-substitute "\\s+$" "" res)
res))))))
-(define (configf:cfgdat->env-alist section cfgdat-ht allow-system)
- (filter
- (lambda (pair)
- (let* ((var (car pair))
- (val (cdr pair)))
- (cons var
- (cond
- ((and allow-system (procedure? val)) ;; if we decided to use something other than #t or #f for allow-system ('return-procs or 'return-string) , this may become problematic
- (val))
- ((procedure? val) #f)
- ((string? val) val)
- (else "#f")))))
- (append
- (hash-table-ref/default cfgdat-ht "default" '())
- (if (equal? section "default") '() (hash-table-ref/default cfgdat-ht section '())))))
-
-(define (calc-allow-system allow-system section sections)
- (if sections
- (and (or (equal? "default" section)
- (member section sections))
- allow-system) ;; account for sections and return allow-system as it might be a symbol such as return-strings
- allow-system))
-
-;; given a config hash and a section name, apply that section to all matching sections (using wildcard % or regex if /..../)
-;; remove the section when done so that there is no downstream clobbering
-;;
-(define (configf:apply-wildcards ht section-name)
- (if (hash-table-exists? ht section-name)
- (let* ((vars (hash-table-ref ht section-name))
- (rxstr (if (string-contains section-name "%")
- (string-substitute (regexp "%") ".*" section-name)
- (string-substitute (regexp "^/(.*)/$") "\\1" section-name)))
- (rx (regexp rxstr)))
- ;; (print "\nsection-name: " section-name " rxstr: " rxstr)
- (for-each
- (lambda (section)
- (if section
- (let ((same-section (string=? section-name section))
- (rx-match (string-match rx section)))
- ;; (print "section: " section " vars: " vars " same-section: " same-section " rx-match: " rx-match)
- (if (and (not same-section) rx-match)
- (for-each
- (lambda (bundle)
- ;; (print "bundle: " bundle)
- (let ((key (car bundle))
- (val (cadr bundle))
- (meta (if (> (length bundle) 2)(caddr bundle) #f)))
- (hash-table-set! ht section (configf:assoc-safe-add (hash-table-ref ht section) key val metadata: meta))))
- vars)))))
- (hash-table-keys ht))))
- ht)
-
;; read a config file, returns hash table of alists
;; read a config file, returns hash table of alists
;; adds to ht if given (must be #f otherwise)
;; allow-system:
@@ -500,232 +416,17 @@
(set! var-flag #f)
(loop (configf:read-line inp res (calc-allow-system allow-system curr-section-name sections) settings) curr-section-name #f #f))))
) ;; end loop
)))
-;; pathenvvar will set the named var to the path of the config
-(define (find-and-read-config fname #!key (environ-patt #f)(given-toppath #f)(pathenvvar #f))
- (let* ((curr-dir (current-directory))
- (configinfo (find-config fname toppath: given-toppath))
- (toppath (car configinfo))
- (configfile (cadr configinfo))
- (set-fields (lambda (curr-section next-section ht path)
- (let ((field-names (if ht (common:get-fields ht) '()))
- (target (or (getenv "MT_TARGET")(args:get-arg "-reqtarg")(args:get-arg "-target"))))
- (debug:print-info 9 *default-log-port* "set-fields with field-names=" field-names " target=" target " curr-section=" curr-section " next-section=" next-section " path=" path " ht=" ht)
- (if (not (null? field-names))(keys:target-set-args field-names target #f))))))
- (if toppath (change-directory toppath))
- (if (and toppath pathenvvar)(setenv pathenvvar toppath))
- (let ((configdat (if configfile
- (read-config configfile #f #t environ-patt: environ-patt post-section-procs: (list (cons "^fields$" set-fields)) #f))))
- (if toppath (change-directory curr-dir))
- (list configdat toppath configfile fname))))
-
-(define (configf:lookup cfgdat section var)
- (if (hash-table? cfgdat)
- (let ((sectdat (hash-table-ref/default cfgdat section '())))
- (if (null? sectdat)
- #f
- (let ((match (assoc var sectdat)))
- (if match ;; (and match (list? match)(> (length match) 1))
- (cadr match)
- #f))
- ))
- #f))
-
-;; use to have definitive setting:
-;; [foo]
-;; var yes
-;;
-;; (configf:var-is? cfgdat "foo" "var" "yes") => #t
-;;
-(define (configf:var-is? cfgdat section var expected-val)
- (equal? (configf:lookup cfgdat section var) expected-val))
-
-;; redefines
-(define config-lookup configf:lookup)
-(define configf:read-file read-config)
-
-;; safely look up a value that is expected to be a number, return
-;; a default (#f unless provided)
-;;
-(define (configf:lookup-number cfgdat section varname #!key (default #f))
- (let* ((val (configf:lookup cfgdat section varname))
- (res (if val
- (string->number (string-substitute "\\s+" "" val #t))
- #f)))
- (cond
- (res res)
- (val (debug:print 0 *default-log-port* "ERROR: no number found for [" section "], " varname ", got: " val))
- (else default))))
-
-(define (configf:section-vars cfgdat section)
- (let ((sectdat (hash-table-ref/default cfgdat section '())))
- (if (null? sectdat)
- '()
- (map car sectdat))))
-
-(define (configf:get-section cfgdat section)
- (hash-table-ref/default cfgdat section '()))
-
-(define (configf:set-section-var cfgdat section var val)
- (let ((sectdat (configf:get-section cfgdat section)))
- (hash-table-set! cfgdat section
- (configf:assoc-safe-add sectdat var val))))
-
-;;======================================================================
-;;(append (filter (lambda (x)(not (assoc var sectdat))) sectdat)
-;; (list var val))))
-
(define (setup)
(let* ((configf (find-config "megatest.config"))
(config (if configf (read-config configf #f #t) #f)))
(if config
(setenv "RUN_AREA_HOME" (pathname-directory configf)))
config))
-;;======================================================================
-;; Non destructive writing of config file
-;;======================================================================
-
-(define (configf:compress-multi-lines fdat)
- ;; step 1.5 - compress any continued lines
- (if (null? fdat) fdat
- (let loop ((hed (car fdat))
- (tal (cdr fdat))
- (cur "")
- (led #f)
- (res '()))
- ;; ALL WHITESPACE LEADING LINES ARE TACKED ON!!
- ;; 1. remove led whitespace
- ;; 2. tack on to hed with "\n"
- (let ((match (string-match configf:cont-ln-rx hed)))
- (if match ;; blast! have to deal with a multiline
- (let* ((lead (cadr match))
- (lval (caddr match))
- (newl (conc cur "\n" lval)))
- (if (not led)(set! led lead))
- (if (null? tal)
- (set! fdat (append fdat (list newl)))
- (loop (car tal)(cdr tal) newl led res))) ;; NB// not tacking newl onto res
- (let ((newres (if led
- (append res (list cur hed))
- (append res (list hed)))))
- ;; prev was a multiline
- (if (null? tal)
- newres
- (loop (car tal)(cdr tal) "" #f newres))))))))
-
-;; note: I'm cheating a little here. I merely replace "\n" with "\n "
-(define (configf:expand-multi-lines fdat)
- ;; step 1.5 - compress any continued lines
- (if (null? fdat) fdat
- (let loop ((hed (car fdat))
- (tal (cdr fdat))
- (res '()))
- (let ((newres (append res (list (string-substitute (regexp "\n") "\n " hed #t)))))
- (if (null? tal)
- newres
- (loop (car tal)(cdr tal) newres))))))
-
-(define (configf:file->list fname)
- (if (common:file-exists? fname)
- (let ((inp (open-input-file fname)))
- (let loop ((inl (read-line inp))
- (res '()))
- (if (eof-object? inl)
- (begin
- (close-input-port inp)
- (reverse res))
- (loop (read-line inp)(cons inl res)))))
- '()))
-
-;;======================================================================
-;; Write a config
-;; 0. Given a refererence data structure "indat"
-;; 1. Open the output file and read it into a list
-;; 2. Flatten any multiline entries
-;; 3. Modify values per contents of "indat" and remove absent values
-;; 4. Append new values to the section (immediately after last legit entry)
-;; 5. Write out the new list
-;;======================================================================
-
-(define (configf:write-config indat fname #!key (required-sections '()))
- (let* (;; step 1: Open the output file and read it into a list
- (fdat (configf:file->list fname))
- (refdat (make-hash-table))
- (sechash (make-hash-table)) ;; current section hash, init with hash for "default" section
- (new #f) ;; put the line to be used in new, if it is to be deleted the set new to #f
- (secname #f))
-
- ;; step 2: Flatten multiline entries
- (if (not (null? fdat))(set! fdat (configf:compress-multi-lines fdat)))
-
- ;; step 3: Modify values per contents of "indat" and remove absent values
- (if (not (null? fdat))
- (let loop ((hed (car fdat))
- (tal (cadr fdat))
- (res '())
- (lnum 0))
- (regex-case
- hed
- (configf:comment-rx _ (set! res (append res (list hed)))) ;; (loop (read-line inp) curr-section-name #f #f))
- (configf:blank-l-rx _ (set! res (append res (list hed)))) ;; (loop (read-line inp) curr-section-name #f #f))
- (configf:section-rx ( x section-name ) (let ((section-hash (hash-table-ref/default refdat section-name #f)))
- (if (not section-hash)
- (let ((newhash (make-hash-table)))
- (hash-table-set! refdat section-name newhash) ;; was refhash - not sure that refdat is correct here
- (set! sechash newhash))
- (set! sechash section-hash))
- (set! new hed) ;; will append this at the bottom of the loop
- (set! secname section-name)
- ))
- ;; No need to process key cmd, let it fall though to key val
- (configf:key-val-pr ( x key val )
- (let ((newval (configf:lookup indat secname key))) ;; was sec, bug or correct?
- ;; can handle newval == #f here => that means key is removed
- (cond
- ((equal? newval val)
- (set! res (append res (list hed))))
- ((not newval) ;; key has been removed
- (set! new #f))
- ((not (equal? newval val))
- (hash-table-set! sechash key newval)
- (set! new (conc key " " newval)))
- (else
- (debug:print-error 0 *default-log-port* "problem parsing line number " lnum "\"" hed "\"")))))
- (else
- (debug:print-error 0 *default-log-port* "Problem parsing line num " lnum " :\n " hed )))
- (if (not (null? tal))
- (loop (car tal)(cdr tal)(if new (append res (list new)) res)(+ lnum 1)))
- ;; drop to here when done processing, res contains modified list of lines
- (set! fdat res)))
-
- ;; step 4: Append new values to the section
- (for-each
- (lambda (section)
- (let ((sdat '()) ;; append needed bits here
- (svars (configf:section-vars indat section)))
- (for-each
- (lambda (var)
- (let ((val (configf:lookup refdat section var)))
- (if (not val) ;; this one is new
- (begin
- (if (null? sdat)(set! sdat (list (conc "[" section "]"))))
- (set! sdat (append sdat (list (conc var " " val))))))))
- svars)
- (set! fdat (append fdat sdat))))
- (delete-duplicates (append required-sections (hash-table-keys indat))))
-
- ;; step 5: Write out new file
- (with-output-to-file fname
- (lambda ()
- (for-each
- (lambda (line)
- (print line))
- (configf:expand-multi-lines fdat))))))
-
;;======================================================================
;; refdb
;;======================================================================
;; reads a refdb into an assoc array of assoc arrays
@@ -755,95 +456,10 @@
;; (set! data (append data (list (list sheet-name ref-assoc))))))
(set! data (cons (list sheet-name ref-assoc) data))))
sheets)
(list data "NO ERRORS"))))))
-;; map over all pairs in a three level hierarchial alist and apply a function to the keys/val
-;;
-(define (configf:map-all-hier-alist data proc #!key (initproc1 #f)(initproc2 #f)(initproc3 #f))
- (for-each
- (lambda (sheetname)
- (let* ((sheettmp (assoc sheetname data))
- (sheetdat (if sheettmp (cadr sheettmp) '())))
- (if initproc1 (initproc1 sheetname))
- (for-each
- (lambda (sectionname)
- (let* ((sectiontmp (assoc sectionname sheetdat))
- (sectiondat (if sectiontmp (cadr sectiontmp) '())))
- (if initproc2 (initproc2 sheetname sectionname))
- (for-each
- (lambda (varname)
- (let* ((valtmp (assoc varname sectiondat))
- (val (if valtmp (cadr valtmp) "")))
- (proc sheetname sectionname varname val)))
- (map car sectiondat))))
- (map car sheetdat))))
- (map car data))
- data)
-
-;;======================================================================
-;; C O N F I G T O / F R O M A L I S T
-;;======================================================================
-
-(define (configf:config->alist cfgdat)
- (hash-table->alist cfgdat))
-
-(define (configf:alist->config adat)
- (let ((ht (make-hash-table)))
- (for-each
- (lambda (section)
- (hash-table-set! ht (car section)(cdr section)))
- adat)
- ht))
-
-;; if
-(define (configf:read-alist fname)
- (handle-exceptions
- exn
- (begin
- (debug:print 0 *default-log-port* "read of alist " fname " failed. exn=" exn)
- #f)
- (configf:alist->config
- (with-input-from-file fname read))))
-
-(define (configf:write-alist cdat fname)
- (if (not (common:faux-lock fname))
- (debug:print 0 *default-log-port* "INFO: Could not get lock on " fname))
- (let* ((dat (configf:config->alist cdat))
- (res
- (begin
- (with-output-to-file fname ;; first write out the file
- (lambda ()
- (pp dat)))
-
- (if (common:file-exists? fname) ;; now verify it is readable
- (if (configf:read-alist fname)
- #t ;; data is good.
- (begin
- (handle-exceptions
- exn
- (begin
- (debug:print 0 *default-log-port* "deleting " fname " failed, exn=" exn)
- #f)
- (debug:print 0 *default-log-port* "WARNING: content " dat " for cache " fname " is not readable. Deleting generated file.")
- (delete-file fname))
- #f))
- #f))))
- (common:faux-unlock fname)
- res))
-
-;; convert hierarchial list to ini format
-;;
-(define (configf:config->ini data)
- (map
- (lambda (section)
- (let ((section-name (car section))
- (section-dat (cdr section)))
- (print "\n[" section-name "]")
- (map (lambda (dat-pair)
- (let* ((var (car dat-pair))
- (val (cadr dat-pair))
- (fname (if (> (length dat-pair) 2)(caddr dat-pair) #f)))
- (if fname (print "# " var "=>" fname))
- (print var " " val)))
- section-dat))) ;; (print "section-dat: " section-dat))
- (hash-table->alist data)))
+;; redefines
+(define config-lookup configf:lookup)
+(define configf:read-file read-config)
+(define shell configfmod#shell)
+
Index: configfmod.scm
==================================================================
--- configfmod.scm
+++ configfmod.scm
@@ -17,59 +17,439 @@
;; along with Megatest. If not, see .
;;======================================================================
(declare (unit configfmod))
-;; (declare (uses mtargs))
-;; (declare (uses debugprint))
-;; (declare (uses keysmod))
+(declare (uses debugprint))
+(declare (uses commonmod))
+(declare (uses processmod))
+
+(use regex regex-case)
(module configfmod
*
-(import srfi-1
-
-;; scheme
-;;
-;; big-chicken ;; more of a reminder than anything ...
-;; chicken.base
-;; chicken.condition
-;; chicken.file
-;; chicken.io
-;; chicken.pathname
-;; chicken.port
-;; chicken.pretty-print
-;; chicken.process
-;; chicken.process-context
-;; chicken.process-context.posix
-;; chicken.sort
-;; chicken.string
-;; chicken.time
-;; chicken.eval
-;;
-;; debugprint
-;; (prefix mtargs args:)
-;; pkts
-;; keysmod
-;;
-;; (prefix base64 base64:)
-;; (prefix dbi dbi:)
-;; (prefix sqlite3 sqlite3:)
-;; (srfi 18)
-;; directory-utils
-;; format
-;; matchable
-;; md5
-;; message-digest
-;; regex
-;; regex-case
-;; sparse-vectors
-;; srfi-1
-;; srfi-13
-;; srfi-69
-;; stack
-;; typed-records
-;; z3
-
- )
+(import scheme
+ chicken
+ extras
+ files
+ matchable
+ ports
+ srfi-1
+ srfi-13
+ srfi-69
+
+ posix
+ data-structures
+
+ regex
+ regex-case
+
+ )
+
+(import debugprint
+ commonmod
+ processmod)
+
+;; Run a shell command and return the output as a string
+(define (shell cmd)
+ (let* ((output (process:cmd-run->list cmd))
+ (res (car output))
+ (status (cadr output)))
+ (if (equal? status 0)
+ (let ((outres (string-intersperse
+ res
+ "\n")))
+ (debug:print-info 4 *default-log-port* "shell result:\n" outres)
+ outres)
+ (begin ;; why is this printing to error-port and not using debug:print? -mrw-
+ (with-output-to-port (current-error-port)
+ (lambda ()
+ (print "ERROR: " cmd " returned bad exit code " status)))
+ ""))))
+
+;; return list (path fullpath configname)
+(define (find-config configname #!key (toppath #f))
+ (if toppath
+ (let ((cfname (conc toppath "/" configname)))
+ (if (common:file-exists? cfname)
+ (list toppath cfname configname)
+ (list #f #f #f)))
+ (let* ((cwd (string-split (current-directory) "/")))
+ (let loop ((dir cwd))
+ (let* ((path (conc "/" (string-intersperse dir "/")))
+ (fullpath (conc path "/" configname)))
+ (if (common:file-exists? fullpath)
+ (list path fullpath configname)
+ (let ((remcwd (take dir (- (length dir) 1))))
+ (if (null? remcwd)
+ (list #f #f #f) ;; #f #f)
+ (loop remcwd)))))))))
+
+(define (configf:assoc-safe-add alist key val #!key (metadata #f))
+ (let ((newalist (filter (lambda (x)(not (equal? key (car x)))) alist)))
+ (append newalist (list (if metadata
+ (list key val metadata)
+ (list key val))))))
+
+;; this is used in megatestqa/ext.scm.
+;; remove it from here and there by 12/31/21
+;; (define config:assoc-safe-add configf:assoc-safe-add)
+
+(define (configf:section-var-set! cfgdat section-name var value #!key (metadata #f))
+ (hash-table-set! cfgdat section-name
+ (configf:assoc-safe-add
+ (hash-table-ref/default cfgdat section-name '())
+ var value metadata: metadata)))
+
+(define (configf:eval-string-in-environment str)
+ ;; (if (or (string-null? str)
+ ;; (equal? "!" (substring str 0 1))) ;; null string or starts with ! are preserved but NOT set in the environment
+ str
+ (handle-exceptions
+ exn
+ (begin
+ (debug:print-error 0 *default-log-port* "problem evaluating \"" str "\" in the shell environment, exn=" exn)
+ #f)
+ (let ((cmdres (process:cmd-run->list (conc "echo " str))))
+ (if (null? cmdres) ""
+ (caar cmdres))))) ;; )
+
+;;======================================================================
+;; Make the regexp's needed globally available
+;;======================================================================
+
+(define configf:include-rx (regexp "^\\[include\\s+(.*)\\]\\s*$"))
+(define configf:script-rx (regexp "^\\[scriptinc\\s+(\\S+)([^\\]]*)\\]\\s*$")) ;; include output from a script
+(define configf:section-rx (regexp "^\\[(.*)\\]\\s*$"))
+(define configf:blank-l-rx (regexp "^\\s*$"))
+(define configf:key-sys-pr (regexp "^(\\S+)\\s+\\[system\\s+(\\S+.*)\\]\\s*$"))
+(define configf:key-val-pr (regexp "^(\\S+)(\\s+(.*)|())$"))
+(define configf:key-no-val (regexp "^(\\S+)(\\s*)$"))
+(define configf:comment-rx (regexp "^\\s*#.*"))
+(define configf:cont-ln-rx (regexp "^(\\s+)(\\S+.*)$"))
+(define configf:settings (regexp "^\\[configf:settings\\s+(\\S+)\\s+(\\S+)]\\s*$"))
+
+;; read a line and process any #{ ... } constructs
+
+(define configf:var-expand-regex (regexp "^(.*)#\\{(scheme|system|shell|getenv|get|runconfigs-get|rget|scm|sh|rp|gv|g|mtrah)\\s+([^\\}\\{]*)\\}(.*)"))
+
+(define (configf:system ht cmd)
+ (system cmd)
+ )
+
+(define configf:imports "(import commonmod (prefix mtargs args:))")
+
+(define (configf:cfgdat->env-alist section cfgdat-ht allow-system)
+ (filter
+ (lambda (pair)
+ (let* ((var (car pair))
+ (val (cdr pair)))
+ (cons var
+ (cond
+ ((and allow-system (procedure? val)) ;; if we decided to use something other than #t or #f for allow-system ('return-procs or 'return-string) , this may become problematic
+ (val))
+ ((procedure? val) #f)
+ ((string? val) val)
+ (else "#f")))))
+ (append
+ (hash-table-ref/default cfgdat-ht "default" '())
+ (if (equal? section "default") '() (hash-table-ref/default cfgdat-ht section '())))))
+
+(define (calc-allow-system allow-system section sections)
+ (if sections
+ (and (or (equal? "default" section)
+ (member section sections))
+ allow-system) ;; account for sections and return allow-system as it might be a symbol such as return-strings
+ allow-system))
+
+;; given a config hash and a section name, apply that section to all matching sections (using wildcard % or regex if /..../)
+;; remove the section when done so that there is no downstream clobbering
+;;
+(define (configf:apply-wildcards ht section-name)
+ (if (hash-table-exists? ht section-name)
+ (let* ((vars (hash-table-ref ht section-name))
+ (rxstr (if (string-contains section-name "%")
+ (string-substitute (regexp "%") ".*" section-name)
+ (string-substitute (regexp "^/(.*)/$") "\\1" section-name)))
+ (rx (regexp rxstr)))
+ ;; (print "\nsection-name: " section-name " rxstr: " rxstr)
+ (for-each
+ (lambda (section)
+ (if section
+ (let ((same-section (string=? section-name section))
+ (rx-match (string-match rx section)))
+ ;; (print "section: " section " vars: " vars " same-section: " same-section " rx-match: " rx-match)
+ (if (and (not same-section) rx-match)
+ (for-each
+ (lambda (bundle)
+ ;; (print "bundle: " bundle)
+ (let ((key (car bundle))
+ (val (cadr bundle))
+ (meta (if (> (length bundle) 2)(caddr bundle) #f)))
+ (hash-table-set! ht section (configf:assoc-safe-add (hash-table-ref ht section) key val metadata: meta))))
+ vars)))))
+ (hash-table-keys ht))))
+ ht)
+
+(define (configf:lookup cfgdat section var)
+ (if (hash-table? cfgdat)
+ (let ((sectdat (hash-table-ref/default cfgdat section '())))
+ (if (null? sectdat)
+ #f
+ (let ((match (assoc var sectdat)))
+ (if match ;; (and match (list? match)(> (length match) 1))
+ (cadr match)
+ #f))
+ ))
+ #f))
+
+;; use to have definitive setting:
+;; [foo]
+;; var yes
+;;
+;; (configf:var-is? cfgdat "foo" "var" "yes") => #t
+;;
+(define (configf:var-is? cfgdat section var expected-val)
+ (equal? (configf:lookup cfgdat section var) expected-val))
+
+;; safely look up a value that is expected to be a number, return
+;; a default (#f unless provided)
+;;
+(define (configf:lookup-number cfgdat section varname #!key (default #f))
+ (let* ((val (configf:lookup cfgdat section varname))
+ (res (if val
+ (string->number (string-substitute "\\s+" "" val #t))
+ #f)))
+ (cond
+ (res res)
+ (val (debug:print 0 *default-log-port* "ERROR: no number found for [" section "], " varname ", got: " val))
+ (else default))))
+
+(define (configf:section-vars cfgdat section)
+ (let ((sectdat (hash-table-ref/default cfgdat section '())))
+ (if (null? sectdat)
+ '()
+ (map car sectdat))))
+
+(define (configf:get-section cfgdat section)
+ (hash-table-ref/default cfgdat section '()))
+
+(define (configf:set-section-var cfgdat section var val)
+ (let ((sectdat (configf:get-section cfgdat section)))
+ (hash-table-set! cfgdat section
+ (configf:assoc-safe-add sectdat var val))))
+
+;;======================================================================
+;;(append (filter (lambda (x)(not (assoc var sectdat))) sectdat)
+;; (list var val))))
+
+;;======================================================================
+;; Non destructive writing of config file
+;;======================================================================
+
+(define (configf:compress-multi-lines fdat)
+ ;; step 1.5 - compress any continued lines
+ (if (null? fdat) fdat
+ (let loop ((hed (car fdat))
+ (tal (cdr fdat))
+ (cur "")
+ (led #f)
+ (res '()))
+ ;; ALL WHITESPACE LEADING LINES ARE TACKED ON!!
+ ;; 1. remove led whitespace
+ ;; 2. tack on to hed with "\n"
+ (let ((match (string-match configf:cont-ln-rx hed)))
+ (if match ;; blast! have to deal with a multiline
+ (let* ((lead (cadr match))
+ (lval (caddr match))
+ (newl (conc cur "\n" lval)))
+ (if (not led)(set! led lead))
+ (if (null? tal)
+ (set! fdat (append fdat (list newl)))
+ (loop (car tal)(cdr tal) newl led res))) ;; NB// not tacking newl onto res
+ (let ((newres (if led
+ (append res (list cur hed))
+ (append res (list hed)))))
+ ;; prev was a multiline
+ (if (null? tal)
+ newres
+ (loop (car tal)(cdr tal) "" #f newres))))))))
+
+;; note: I'm cheating a little here. I merely replace "\n" with "\n "
+(define (configf:expand-multi-lines fdat)
+ ;; step 1.5 - compress any continued lines
+ (if (null? fdat) fdat
+ (let loop ((hed (car fdat))
+ (tal (cdr fdat))
+ (res '()))
+ (let ((newres (append res (list (string-substitute (regexp "\n") "\n " hed #t)))))
+ (if (null? tal)
+ newres
+ (loop (car tal)(cdr tal) newres))))))
+
+(define (configf:file->list fname)
+ (if (common:file-exists? fname)
+ (let ((inp (open-input-file fname)))
+ (let loop ((inl (read-line inp))
+ (res '()))
+ (if (eof-object? inl)
+ (begin
+ (close-input-port inp)
+ (reverse res))
+ (loop (read-line inp)(cons inl res)))))
+ '()))
+
+;;======================================================================
+;; Write a config
+;; 0. Given a refererence data structure "indat"
+;; 1. Open the output file and read it into a list
+;; 2. Flatten any multiline entries
+;; 3. Modify values per contents of "indat" and remove absent values
+;; 4. Append new values to the section (immediately after last legit entry)
+;; 5. Write out the new list
+;;======================================================================
+
+(define (configf:write-config indat fname #!key (required-sections '()))
+ (let* (;; step 1: Open the output file and read it into a list
+ (fdat (configf:file->list fname))
+ (refdat (make-hash-table))
+ (sechash (make-hash-table)) ;; current section hash, init with hash for "default" section
+ (new #f) ;; put the line to be used in new, if it is to be deleted the set new to #f
+ (secname #f))
+
+ ;; step 2: Flatten multiline entries
+ (if (not (null? fdat))(set! fdat (configf:compress-multi-lines fdat)))
+
+ ;; step 3: Modify values per contents of "indat" and remove absent values
+ (if (not (null? fdat))
+ (let loop ((hed (car fdat))
+ (tal (cadr fdat))
+ (res '())
+ (lnum 0))
+ (regex-case
+ hed
+ (configf:comment-rx _ (set! res (append res (list hed)))) ;; (loop (read-line inp) curr-section-name #f #f))
+ (configf:blank-l-rx _ (set! res (append res (list hed)))) ;; (loop (read-line inp) curr-section-name #f #f))
+ (configf:section-rx ( x section-name ) (let ((section-hash (hash-table-ref/default refdat section-name #f)))
+ (if (not section-hash)
+ (let ((newhash (make-hash-table)))
+ (hash-table-set! refdat section-name newhash) ;; was refhash - not sure that refdat is correct here
+ (set! sechash newhash))
+ (set! sechash section-hash))
+ (set! new hed) ;; will append this at the bottom of the loop
+ (set! secname section-name)
+ ))
+ ;; No need to process key cmd, let it fall though to key val
+ (configf:key-val-pr ( x key val )
+ (let ((newval (configf:lookup indat secname key))) ;; was sec, bug or correct?
+ ;; can handle newval == #f here => that means key is removed
+ (cond
+ ((equal? newval val)
+ (set! res (append res (list hed))))
+ ((not newval) ;; key has been removed
+ (set! new #f))
+ ((not (equal? newval val))
+ (hash-table-set! sechash key newval)
+ (set! new (conc key " " newval)))
+ (else
+ (debug:print-error 0 *default-log-port* "problem parsing line number " lnum "\"" hed "\"")))))
+ (else
+ (debug:print-error 0 *default-log-port* "Problem parsing line num " lnum " :\n " hed )))
+ (if (not (null? tal))
+ (loop (car tal)(cdr tal)(if new (append res (list new)) res)(+ lnum 1)))
+ ;; drop to here when done processing, res contains modified list of lines
+ (set! fdat res)))
+
+ ;; step 4: Append new values to the section
+ (for-each
+ (lambda (section)
+ (let ((sdat '()) ;; append needed bits here
+ (svars (configf:section-vars indat section)))
+ (for-each
+ (lambda (var)
+ (let ((val (configf:lookup refdat section var)))
+ (if (not val) ;; this one is new
+ (begin
+ (if (null? sdat)(set! sdat (list (conc "[" section "]"))))
+ (set! sdat (append sdat (list (conc var " " val))))))))
+ svars)
+ (set! fdat (append fdat sdat))))
+ (delete-duplicates (append required-sections (hash-table-keys indat))))
+
+ ;; step 5: Write out new file
+ (with-output-to-file fname
+ (lambda ()
+ (for-each
+ (lambda (line)
+ (print line))
+ (configf:expand-multi-lines fdat))))))
+
+;; map over all pairs in a three level hierarchial alist and apply a function to the keys/val
+;;
+(define (configf:map-all-hier-alist data proc #!key (initproc1 #f)(initproc2 #f)(initproc3 #f))
+ (for-each
+ (lambda (sheetname)
+ (let* ((sheettmp (assoc sheetname data))
+ (sheetdat (if sheettmp (cadr sheettmp) '())))
+ (if initproc1 (initproc1 sheetname))
+ (for-each
+ (lambda (sectionname)
+ (let* ((sectiontmp (assoc sectionname sheetdat))
+ (sectiondat (if sectiontmp (cadr sectiontmp) '())))
+ (if initproc2 (initproc2 sheetname sectionname))
+ (for-each
+ (lambda (varname)
+ (let* ((valtmp (assoc varname sectiondat))
+ (val (if valtmp (cadr valtmp) "")))
+ (proc sheetname sectionname varname val)))
+ (map car sectiondat))))
+ (map car sheetdat))))
+ (map car data))
+ data)
+
+;;======================================================================
+;; C O N F I G T O / F R O M A L I S T
+;;======================================================================
+
+(define (configf:config->alist cfgdat)
+ (hash-table->alist cfgdat))
+
+(define (configf:alist->config adat)
+ (let ((ht (make-hash-table)))
+ (for-each
+ (lambda (section)
+ (hash-table-set! ht (car section)(cdr section)))
+ adat)
+ ht))
+
+;; if
+(define (configf:read-alist fname)
+ (handle-exceptions
+ exn
+ (begin
+ (debug:print 0 *default-log-port* "read of alist " fname " failed. exn=" exn)
+ #f)
+ (configf:alist->config
+ (with-input-from-file fname read))))
+
+
+;; convert hierarchial list to ini format
+;;
+(define (configf:config->ini data)
+ (map
+ (lambda (section)
+ (let ((section-name (car section))
+ (section-dat (cdr section)))
+ (print "\n[" section-name "]")
+ (map (lambda (dat-pair)
+ (let* ((var (car dat-pair))
+ (val (cadr dat-pair))
+ (fname (if (> (length dat-pair) 2)(caddr dat-pair) #f)))
+ (if fname (print "# " var "=>" fname))
+ (print var " " val)))
+ section-dat))) ;; (print "section-dat: " section-dat))
+ (hash-table->alist data)))
+
+
)
Index: dashboard-context-menu.scm
==================================================================
--- dashboard-context-menu.scm
+++ dashboard-context-menu.scm
@@ -24,10 +24,11 @@
;;======================================================================
(declare (unit dashboard-context-menu))
(declare (uses common))
(declare (uses commonmod))
+(declare (uses configfmod))
(declare (uses db))
(declare (uses gutils))
(declare (uses rmt))
(declare (uses rmtmod))
(declare (uses ezsteps))
@@ -47,10 +48,11 @@
(include "common_records.scm")
(include "db_records.scm")
(include "run_records.scm")
(import commonmod
+ configfmod
rmtmod
debugprint)
(define (dboard:launch-testpanel run-id test-id)
(let* ((dboardexe (common:find-local-megatest "dashboard"))
Index: dashboard-tests.scm
==================================================================
--- dashboard-tests.scm
+++ dashboard-tests.scm
@@ -23,10 +23,12 @@
;;======================================================================
(declare (unit dashboard-tests))
(declare (uses common))
(declare (uses commonmod))
+(declare (uses configfmod))
+(declare (uses dcommon))
(declare (uses db))
(declare (uses gutils))
(declare (uses rmt))
(declare (uses ezsteps))
(declare (uses subrun))
@@ -41,10 +43,11 @@
(use srfi-1 posix regex regex-case srfi-69)
(use (prefix sqlite3 sqlite3:))
(import commonmod
+ configfmod
rmtmod
debugprint)
(include "common_records.scm")
(include "db_records.scm")
@@ -463,11 +466,11 @@
;;======================================================================
;;
;;======================================================================
(define (dashboard-tests:examine-test run-id test-id) ;; run-id run-key origtest)
- (let* ((db-path (db:dbfile-path)) ;; (conc (configf:lookup *configdat* "setup" "linktree") "/db/" run-id ".db"))
+ (let* ((db-path (common:make-tmpdir-name *toppath* "")) ;; (conc (configf:lookup *configdat* "setup" "linktree") "/db/" run-id ".db"))
(dbstruct #f) ;; NOT USED
(testdat (rmt:get-test-info-by-id run-id test-id)) ;; (db:get-test-info-by-id dbstruct run-id test-id))
(db-mod-time 0) ;; (file-modification-time db-path))
(last-update 0) ;; (current-seconds))
(request-update #t))
ADDED dashboard-transport-mode.scm
Index: dashboard-transport-mode.scm
==================================================================
--- /dev/null
+++ dashboard-transport-mode.scm
@@ -0,0 +1,22 @@
+;;======================================================================
+;; set up transport, db cache and sync methods
+;;
+;; sync-method: 'original, 'attach or 'none
+;; cache-method: 'tmp or 'none
+;; rmt:transport-mode: 'http, 'tcp, 'nfs
+;;
+;; NOTE: NOT ALL COMBINATIONS WORK
+;;
+;;======================================================================
+
+;; uncomment this block to test without tcp or cachedb
+;; (dbfile:sync-method 'none)
+;; (dbfile:cache-method 'none)
+;; (rmt:transport-mode 'nfs)
+
+;; uncomment this block to test with tcp and cachedb
+(dbfile:sync-method 'none) ;; original was causing crash on start.
+(dbfile:cache-method 'none)
+(rmt:transport-mode 'nfs)
+
+
Index: dashboard-transport-mode.scm.template
==================================================================
--- dashboard-transport-mode.scm.template
+++ dashboard-transport-mode.scm.template
@@ -13,10 +13,10 @@
;; (dbfile:sync-method 'none)
;; (dbfile:cache-method 'none)
;; (rmt:transport-mode 'nfs)
;; uncomment this block to test with tcp and cachedb
-(dbfile:sync-method 'attach) ;; original was causing crash on start.
+(dbfile:sync-method 'none) ;; original was causing crash on start.
(dbfile:cache-method 'none)
(rmt:transport-mode 'nfs)
Index: dashboard.scm
==================================================================
--- dashboard.scm
+++ dashboard.scm
@@ -25,10 +25,14 @@
(declare (uses items))
(declare (uses debugprint))
(declare (uses debugprint.import))
(declare (uses db))
(declare (uses configf))
+(declare (uses configfmod))
+(declare (uses configfmod.import))
+(declare (uses processmod))
+(declare (uses processmod.import))
(declare (uses process))
(declare (uses launch))
(declare (uses runs))
(declare (uses dashboard-tests))
(declare (uses tree))
@@ -36,12 +40,14 @@
(declare (uses dashboard-context-menu))
(declare (uses vg))
(declare (uses subrun))
(declare (uses mt))
(declare (uses dbmod))
-(declare (uses rmtmod))
(declare (uses dbfile))
+(declare (uses dbfile.import))
+(declare (uses rmtmod))
+(declare (uses rmtmod.import))
(declare (uses commonmod))
(declare (uses commonmod.import))
(use format)
@@ -54,10 +60,12 @@
(use ducttape-lib)
(use sqlite3 srfi-1 posix regex regex-case srfi-69 typed-records sparse-vectors) ;; defstruct
(import commonmod
+ configfmod
+ processmod
(prefix mtargs args:)
dbmod
dbfile
rmtmod
debugprint)
@@ -74,10 +82,12 @@
;; executables such as dashboard and mtutil
;;
(include "dashboard-transport-mode.scm")
(dbfile:db-init-proc db:initialize-main-db)
(set! rmtmod:send-receive rmt:send-receive)
+
+(debug:print-info 0 *default-log-port* "transport-mode="(rmt:transport-mode))
(define help (conc
"Megatest Dashboard, documentation at http://www.kiatoa.com/fossils/megatest version " megatest-version
" license GPL, Copyright (C) Matt Welland 2012-2017
@@ -117,12 +127,12 @@
args:arg-hash
0))
(if (args:get-arg "-mode")
(let* ((mode (string->symbol (args:get-arg "-mode"))))
- (rmt:transport-mode mode))
- (rmt:transport-mode 'tcp))
+ (rmt:transport-mode mode)))
+;; (rmt:transport-mode 'tcp))
(if (args:get-arg "-test") ;; need to use tcp for test control panel
(rmt:transport-mode 'tcp))
;; RA => Might require revert for filters
@@ -139,33 +149,35 @@
;; (hash-table-set! args:arg-hash "-use-db-cache" #t)));;;)
;;)
;; data common to all tabs goes here
;;
-(defstruct dboard:commondat
- ((curr-tab-num 0) : number)
- please-update
- tabdats
- update-mutex
- updaters
- updating
- uidat ;; needs to move to tabdat at some time
- hide-not-hide-tabs
- target
- )
-
-(define (dboard:commondat-make)
- (make-dboard:commondat
- curr-tab-num: 0
- tabdats: (make-hash-table)
- please-update: #t
- update-mutex: (make-mutex)
- updaters: (make-hash-table)
- updating: #f
- hide-not-hide-tabs: #f
- target: ""
- ))
+;; Moved to dcommon.scm
+;;
+;; (defstruct dboard:commondat
+;; ((curr-tab-num 0) : number)
+;; please-update
+;; tabdats
+;; update-mutex
+;; updaters
+;; updating
+;; uidat ;; needs to move to tabdat at some time
+;; hide-not-hide-tabs
+;; target
+;; )
+;;
+;; (define (dboard:commondat-make)
+;; (make-dboard:commondat
+;; curr-tab-num: 0
+;; tabdats: (make-hash-table)
+;; please-update: #t
+;; update-mutex: (make-mutex)
+;; updaters: (make-hash-table)
+;; updating: #f
+;; hide-not-hide-tabs: #f
+;; target: ""
+;; ))
;;======================================================================
;; buttons color using image
;;======================================================================
@@ -208,39 +220,17 @@
;; (iup:attribute-set! img1 "2" "255 0 0")
(hash-table-set! images name img1)
name)))
-;; RA => returns the tabdat stored at hashkey passed in commondat-tabdats table (e.g. 0 gives summary)
-;;
-(define (dboard:common-get-tabdat commondat #!key (tab-num #f))
- (let* ((tnum (or tab-num
- (dboard:commondat-curr-tab-num commondat)
- 0)) ;; tab-num value is curr-tab-num value in passed commondat
- (ht (dboard:commondat-tabdats commondat))
- (res (hash-table-ref/default ht tnum #f)))
- (or res
- (let ((new-tabdat (dboard:tabdat-make-data)))
- (hash-table-set! ht tnum new-tabdat)
- new-tabdat))))
-
-;; RA => sets the tabdat passed to the hashkey at commondat:tabdats hash table
-;;
-(define (dboard:common-set-tabdat! commondat tabnum tabdat)
- (hash-table-set!
- (dboard:commondat-tabdats commondat)
- tabnum
- tabdat))
-
;; gets and calls updater list based on curr-tab-num
;;
(define (dboard:common-run-curr-updaters commondat #!key (tab-num #f))
;; (sync-db-to-tmp (dboard:common-get-tabdat commondat tab-num: tab-num)) ;; no longer applies
;; maybe need sleep here?
-
(if (dboard:common-get-tabdat commondat tab-num: tab-num) ;; only update if there is a tabdat
(let* ((tnum (or tab-num (dboard:commondat-curr-tab-num commondat)))
(updaters (hash-table-ref/default (dboard:commondat-updaters commondat)
tnum
'())))
@@ -402,12 +392,12 @@
(dboard:setup-tabdat dat)
(dboard:setup-num-rows dat)
dat))
(define (dboard:setup-tabdat tabdat)
- (dboard:tabdat-dbdir-set! tabdat (db:dbfile-path)) ;; (conc (configf:lookup *configdat* "setup" "linktree") "/.db"))
- (dboard:tabdat-dbfpath-set! tabdat (db:dbfile-path))
+ (dboard:tabdat-dbdir-set! tabdat (common:make-tmpdir-name *toppath* "")) ;; (conc (configf:lookup *configdat* "setup" "linktree") "/.db"))
+ (dboard:tabdat-dbfpath-set! tabdat (common:make-tmpdir-name *toppath* ""))
(dboard:tabdat-monitor-db-path-set! tabdat (conc (dboard:tabdat-dbdir tabdat) "/monitor.db"))
;; HACK ALERT: this is a hack, please fix.
(dboard:tabdat-ro-set! tabdat (not (file-read-access? (dboard:tabdat-dbfpath tabdat))))
@@ -671,11 +661,11 @@
;;
(define (dboard:get-tests-for-run-duplicate tabdat run-id run testnamepatt key-vals)
(let* ((start-time (current-seconds))
(access-mode (dboard:tabdat-access-mode tabdat))
(num-to-get (string->number (or (configf:lookup *configdat* "setup" "num-tests-to-get")
- "200")))
+ "1000")))
(states (hash-table-keys (dboard:tabdat-state-ignore-hash tabdat)))
(statuses (hash-table-keys (dboard:tabdat-status-ignore-hash tabdat)))
(do-not-use-db-file-timestamps #f) ;; (configf:lookup *configdat* "setup" "do-not-use-db-file-timestamps")) ;; this still hosts runs-summary-tab
(do-not-use-query-timestamps #t) ;; (configf:lookup *configdat* "setup" "do-not-use-query-timestamps")) ;; this no longer troubles runs-summary-tab
(sort-info (get-curr-sort))
@@ -749,16 +739,16 @@
(for-each
(lambda (tdat)
(let ((test-id (db:test-get-id tdat))
(state (db:test-get-state tdat)))
- (dboard:rundat-data-changed-set! run-dat #t)
- (if (equal? state "DELETED")
- (hash-table-delete! tests-ht test-id)
- (hash-table-set! tests-ht test-id tdat))))
- tmptests)
-
+ (dboard:rundat-data-changed-set! run-dat #t)
+ (if (equal? state "DELETED")
+ (hash-table-delete! tests-ht test-id)
+ (hash-table-set! tests-ht test-id tdat))))
+ tmptests)
+
tests-ht))
;; tmptests - new tests data
;; prev-tests - old tests data
;;
@@ -853,10 +843,16 @@
(loop run tal new-res newmaxtests) ;; not done getting data for this run
(loop (car tal)(cdr tal) new-res newmaxtests)))))))
(dboard:tabdat-filters-changed-set! tabdat #f)
(dboard:update-tree tabdat runs-hash header tb)))
+
+(define *dashboard-last-run-id-update* (make-hash-table)) ;; id => seconds
+
+(define (dboard:clear-run-id-update-hash)
+ (hash-table-clear! *dashboard-last-run-id-update*))
+
;; this calls dboard:get-tests-for-run-duplicate for each run
;;
;; create a virtual table of all the tests
;; keypatts: ( (KEY1 "abc%def")(KEY2 "%") )
;;
@@ -889,63 +885,82 @@
(dboard:tabdat-item-test-names-set! tabdat '())
(hash-table-clear! (dboard:tabdat-allruns-by-id tabdat)))
(let loop ((run (car runs))
(tal (cdr runs))
(res '())
- (maxtests 0))
+ (maxtests 0)
+ (cont-run #f))
(let* ((run-id (db:get-value-by-header run header "id"))
+ (recently-done (< (- (current-seconds)
+ (hash-table-ref/default *dashboard-last-run-id-update* run-id 0)) 1))
(run-struct (hash-table-ref/default (dboard:tabdat-allruns-by-id tabdat) run-id #f))
;; (last-update (if run-struct (dboard:rundat-last-update run-struct) 0))
(key-vals (rmt:get-key-vals run-id))
- (tests-ht (dboard:get-tests-for-run-duplicate tabdat run-id run testnamepatt key-vals))
+ (tests-ht (let* ((tht (if (and recently-done run-struct)
+ (let ((rht (dboard:rundat-tests run-struct))) ;; (dboard:tabdat-allruns-by-id tabdat)))
+ (or rht
+ (dboard:get-tests-for-run-duplicate tabdat run-id run testnamepatt key-vals)))
+ (dboard:get-tests-for-run-duplicate tabdat run-id run testnamepatt key-vals))))
+ (assert (hash-table? tht) "FATAL: But here tht should be a hash-table")
+ tht))
;; GET RID OF dboard:get-tests-dat - it is superceded by dboard:get-tests-for-run-duplicate
;; dboard:get-tests-for-run-duplicate - returns a hash table
;; (dboard:get-tests-dat tabdat run-id last-update))
(all-test-ids (hash-table-keys tests-ht))
- (num-tests (length all-test-ids)))
- ;; (print "run-struct: " run-struct)
- ;; NOTE: bubble-up also sets the global (dboard:tabdat-item-test-names tabdat)
- ;; (tests (bubble-up tmptests priority: bubble-type))
- ;; NOTE: 11/01/2013 This routine is *NOT* getting called excessively.
- ;; (debug:print 0 *default-log-port* "Getting data for run " run-id " with key-vals=" key-vals)
- ;; Not sure this is needed?
- (let* ((newmaxtests (max num-tests maxtests))
- ;; (last-update (- (current-seconds) 10))
- (run-struct (or run-struct
- (dboard:rundat-make-init
- run: run
- tests: tests-ht
- key-vals: key-vals)))
- (new-res (if (null? all-test-ids)
- res
- (delete-duplicates
- (cons run-struct res)
- (lambda (a b)
- (eq? (db:get-value-by-header (dboard:rundat-run a) header "id")
- (db:get-value-by-header (dboard:rundat-run b) header "id"))))))
- (elapsed-time (- (current-seconds) start-time)))
- (if (null? all-test-ids)
+ (num-tests (length all-test-ids))
+ ;; (print "run-struct: " run-struct)
+ ;; NOTE: bubble-up also sets the global (dboard:tabdat-item-test-names tabdat)
+ ;; (tests (bubble-up tmptests priority: bubble-type))
+ ;; NOTE: 11/01/2013 This routine is *NOT* getting called excessively.
+ ;; (debug:print 0 *default-log-port* "Getting data for run " run-id " with key-vals=" key-vals)
+ ;; Not sure this is needed?
+ (newmaxtests (max num-tests maxtests))
+ ;; (last-update (- (current-seconds) 10))
+ (run-struct (or run-struct
+ (dboard:rundat-make-init
+ run: run
+ tests: tests-ht
+ key-vals: key-vals)))
+ (new-res (if (null? all-test-ids)
+ res
+ (delete-duplicates
+ (cons run-struct res)
+ (lambda (a b)
+ (eq? (db:get-value-by-header (dboard:rundat-run a) header "id")
+ (db:get-value-by-header (dboard:rundat-run b) header "id"))))))
+ (elapsed-time (- (current-seconds) start-time)))
+ (if (null? all-test-ids)
(hash-table-delete! (dboard:tabdat-allruns-by-id tabdat) run-id)
(hash-table-set! (dboard:tabdat-allruns-by-id tabdat) run-id run-struct))
- (if (or (null? tal)
- (> elapsed-time 2)) ;; stop loading data after 5 seconds, on the next call more data *should* be loaded since get-tests-for-run uses last update
- (begin
- (when (> elapsed-time 2)
- (debug:print 0 *default-log-port* "NOTE: updates are taking a long time, " elapsed-time "s elapsed.")
- (let* ((old-val (iup:attribute *tim* "TIME"))
- (new-val (number->string (inexact->exact (floor (* 2 (string->number old-val)))))))
- (if (< (string->number new-val) 5000)
- (begin
- (debug:print 0 *default-log-port* "NOTE: increasing poll interval from "old-val" to "new-val)
- (iup:attribute-set! *tim* "TIME" new-val)))))
- (dboard:tabdat-allruns-set! tabdat new-res)
- maxtests)
- (if (> (dboard:rundat-run-data-offset run-struct) 0)
- (loop run tal new-res newmaxtests) ;; not done getting data for this run
- (loop (car tal)(cdr tal) new-res newmaxtests)))))))
- (dboard:tabdat-filters-changed-set! tabdat #f)
- (dboard:update-tree tabdat runs-hash header tb)))
+
+ (if (or (null? tal)
+ (> elapsed-time 2)) ;; stop loading data after 5
+ ;; seconds, on the next call
+ ;; more data *should* be
+ ;; loaded since
+ ;; get-tests-for-run uses last
+ ;; update
+ (begin
+ (when (> elapsed-time 2)
+ (debug:print 2 *default-log-port* "NOTE: updates are taking a long time, " elapsed-time "s elapsed.")
+ (let* ((old-val (iup:attribute *tim* "TIME"))
+ (new-val (number->string (inexact->exact (floor (* 2 (string->number old-val)))))))
+ (if (< (string->number new-val) 5000)
+ (begin
+ (debug:print 2 *default-log-port* "NOTE: increasing poll interval from "old-val" to "new-val)
+ (iup:attribute-set! *tim* "TIME" new-val)))))
+ (dboard:tabdat-allruns-set! tabdat new-res)
+ maxtests)
+ (if (> (dboard:rundat-run-data-offset run-struct) 0)
+ (begin
+ (thread-sleep! 0.2) ;; let the gui re-draw
+ (loop run tal new-res newmaxtests #t)) ;; not done getting data for this run
+ (begin
+ (hash-table-set! *dashboard-last-run-id-update* run-id (current-seconds))
+ (loop (car tal)(cdr tal) new-res newmaxtests #f)))))))
+ (dboard:tabdat-filters-changed-set! tabdat #f)
+ (dboard:update-tree tabdat runs-hash header tb)))
(define *collapsed* (make-hash-table))
(define (toggle-hide lnum uidat) ; fulltestname)
(let* ((btn (vector-ref (dboard:uidat-get-lftcol uidat) lnum))
@@ -1153,15 +1168,15 @@
(drop (dboard:tabdat-all-test-names tabdat)
(dboard:tabdat-start-test-offset tabdat))
'())))
(append xl (make-list (- (dboard:tabdat-num-tests tabdat) (length xl)) ""))))
(update-labels uidat (dboard:tabdat-all-test-names tabdat))
- (for-each
+ (for-each ;;run
(lambda (rundat)
- ;; if rundat is junk clobber it with a decent placeholder
(if (or (not rundat) ;; handle padded runs
(not (dboard:rundat-run rundat)))
+ ;; Need to put an empty column in to erase previous contents.
(set! rundat (dboard:rundat-make-init
key-vals: (map (lambda (x) "")(dboard:tabdat-keys tabdat)))))
(let* ((run (dboard:rundat-run rundat))
(testsdat-by-name (dboard:rundat-tests-by-name rundat))
(key-val-dat (dboard:rundat-key-vals rundat))
@@ -1168,23 +1183,22 @@
(run-id (db:get-value-by-header run (dboard:tabdat-header tabdat) "id"))
(key-vals (append key-val-dat
(list (let ((x (db:get-value-by-header run (dboard:tabdat-header tabdat) "runname")))
(if (string? x) x "")))))
(run-key (string-intersperse key-vals "\n")))
-
+
;; fill in the run header key values
;;
- (let ((rown 0)
+ (let ((rown 0)
(headercol (vector-ref tableheader coln)))
(for-each (lambda (kval)
(let* ((labl (vector-ref headercol rown)))
(if (not (equal? kval (iup:attribute labl "TITLE")))
(iup:attribute-set! (vector-ref headercol rown) "TITLE" kval))
(set! rown (+ rown 1))))
key-vals))
-
- ;; For this run now fill in the buttons for each test
+ ;; For this run now fill in the buttons for each test
;;
(let ((rown 0)
(columndat (vector-ref table coln)))
(for-each
(lambda (testname)
@@ -1197,17 +1211,12 @@
;; testsdat)))
(if (not matching)
(vector -1 -1 "" "" "" 0 "" "" 0 "" "" "" 0 "" "")
;; (car matching))))
matching)))
- (testname (db:test-get-testname testdat))
- (itempath (db:test-get-item-path testdat))
- (testfullname (test:test-get-fullname testdat))
(teststatus (db:test-get-status testdat))
(teststate (db:test-get-state testdat))
- ;;(teststart (db:test-get-event_time test))
- ;;(runtime (db:test-get-run_duration test))
(buttontxt (cond
((member teststate '("COMPLETED" "ARCHIVED")) teststatus)
((and (equal? teststate "NOT_STARTED")
(member teststatus '("ZERO_ITEMS" "BLOCKED" "PREQ_FAIL" "PREQ_DISCARDED" "TIMED_OUT" "KEEP_TRYING" "TEN_STRIKES")))
teststatus)
@@ -1402,11 +1411,15 @@
tp)))
(states (dboard:tabdat-states tabdat))
(statuses (dboard:tabdat-statuses tabdat))
(target (let ((targ-list (dboard:tabdat-target tabdat)))
(if targ-list (string-intersperse targ-list "/") "no-target-selected")))
- (run-name (dboard:tabdat-run-name tabdat))
+ (run-name (let ((run-input (dboard:tabdat-run-name tabdat))
+ )
+ (if (equal? run-input "")
+ "no-runname-specified"
+ run-input)))
(states-str (if (or (not states)
(null? states))
""
(conc " -state " (string-intersperse states ","))))
(statuses-str (if (or (not statuses)
@@ -2404,20 +2417,21 @@
)
)) "runs-summary-click-callback"))))
(runs-summary-updater
(lambda ()
- (mutex-lock! update-mutex)
+ ;; (mutex-lock! update-mutex)
(if (or (dashboard:database-changed? commondat tabdat context-key: 'runs-summary-updater)
(dboard:tabdat-view-changed tabdat))
(debug:catch-and-dump
(lambda () ;; check that run-matrix is initialized before calling the updater
(if run-matrix
(dashboard:runs-summary-updater commondat tabdat tb cell-lookup run-matrix)))
"dashboard:runs-summary-updater")
)
- (mutex-unlock! update-mutex)))
+ #;(mutex-unlock! update-mutex)
+ ))
(runs-summary-control-panel (dashboard:runs-summary-control-panel tabdat))
)
(dboard:commondat-add-updater commondat runs-summary-updater tab-num: tab-num)
(dboard:tabdat-runs-tree-set! tabdat tb)
(iup:vbox
@@ -2460,11 +2474,11 @@
(iup:vbox
(iup:textbox #:size "120x15" #:fontsize "10" #:value "%"
#:expand "NO"
#:action (lambda (obj unk val)
(debug:catch-and-dump
- (lambda ()
+ (lambda ()57
(mark-for-update tabdat)
(update-search commondat tabdat "test-name" val))
"make-controls")))
(iup:hbox
(iup:button "Quit" #:action (lambda (obj)
@@ -2479,10 +2493,11 @@
(dboard:tabdat-allruns-by-id-set! tabdat (make-hash-table))
(dboard:tabdat-done-runs-set! tabdat '())
(dboard:tabdat-not-done-runs-set! tabdat '())
(dboard:tabdat-view-changed-set! tabdat #t)
(dboard:commondat-please-update-set! commondat #t)
+ (dboard:clear-run-id-update-hash)
(mark-for-update tabdat))
#:expand "NO" #:size "40x15")
(iup:button "Collapse" #:action (lambda (obj)
(debug:catch-and-dump
(lambda ()
@@ -3112,11 +3127,11 @@
(debug:print 2 *default-log-port* "WARNING: error in accessing databases in get-youngest-run-db-mod-time: "
((condition-property-accessor 'exn 'message) exn) " db-dir="dbdir ", exn=" exn)
(current-seconds)) ;; something went wrong - just print an error and return current-seconds
(common:max (map (lambda (filen)
(file-modification-time filen))
- (glob (conc dbdir "/*.db*"))))))
+ (cons (conc dbdir "/main.db") (glob (conc dbdir "/?.db")))))))
(define (dashboard:monitor-changed? commondat tabdat)
(let* ((run-update-time (current-seconds))
(monitor-db-path (dboard:tabdat-monitor-db-path tabdat))
(monitor-modtime (if (and monitor-db-path (common:file-exists? monitor-db-path))
@@ -3137,11 +3152,11 @@
(hash-table-set! (dboard:tabdat-last-db-update tabdat) context newtime))
;;
(define (dashboard:database-changed? commondat tabdat #!key (context-key 'default))
(let* ((run-update-time (current-seconds))
- (dbdir (conc *toppath* "/.mtdb"`))
+ (dbdir (conc *toppath* "/.mtdb"))
(modtime (dashboard:get-youngest-run-db-mod-time dbdir))
(recalc (dashboard:recalc modtime
(dboard:commondat-please-update commondat)
(dboard:get-last-db-update tabdat context-key))))
(if recalc
@@ -3344,14 +3359,14 @@
(vch (dboard:tabdat-view-changed tabdat)))
(if (and cnv dwg vch)
(begin
(vg:drawing-xoff-set! dwg (dboard:tabdat-xadj tabdat))
(vg:drawing-yoff-set! dwg (dboard:tabdat-yadj tabdat))
- (mutex-lock! mtx)
+ ;; (mutex-lock! mtx)
(canvas-clear! cnv)
(vg:draw dwg tabdat)
- (mutex-unlock! mtx)
+ ;; (mutex-unlock! mtx)
(dboard:tabdat-view-changed-set! tabdat #f)))))
;; doesn't work.
;;
;;(define (gotoescape tabdat escape)
@@ -3631,17 +3646,17 @@
(graph-uly (- (calc-y 0) canvas-margin))
(sec-per-50pt (/ 50 timescale))
)
;; (print "timeoffset: " timeoffset " timescale: " timescale " run-duration: " (seconds->hr-min-sec run-duration) " width: " width " sec-per-50pt: " sec-per-50pt)
;; (print "timescale: " timescale " timeoffset: " timeoffset " sizex: " sizex " originx: " originx)
- (mutex-lock! mtx)
+ ;; (mutex-lock! mtx)
(vg:add-comp-to-lib runslib run-full-name runcomp)
;; Have to keep moving the instantiated box as it is anchored at the lower left
;; this should have worked for x in next statement? (maptime run-start)
;; add 60 to make room for the graph
(vg:instantiate drawing "runslib" run-full-name run-full-name 8 (- (calc-y curr-run-start-row) (+ 5 graph-height run-to-run-margin)))
- (mutex-unlock! mtx)
+ ;; (mutex-unlock! mtx)
;; (set! run-start-row (+ max-row 2))
;; (dboard:tabdat-start-row-set! tabdat (+ new-run-start-row 1))
;; get tests in list sorted by event time ascending
(let testsloop ((test-ids (car hierdat)) ;; loop on tests (NOTE: not items!)
(tests-tal (cdr hierdat))
@@ -3742,13 +3757,13 @@
(outln (vg:make-rect-obj -5 lly ulx uly
text: run-full-name
line-color: (vg:rgb->number 255 0 255 a: 128))))
; (vg:components-get-extents d1 c1)))
;; this is the box around the run
- (mutex-lock! mtx)
+ ;; (mutex-lock! mtx)
(vg:add-obj-to-comp runcomp outln)
- (mutex-unlock! mtx)
+ ;; (mutex-unlock! mtx)
;; this is where we have enough info to place the graph
(dboard:graph commondat tabdat tab-num -5 (+ uly 10) ulx (+ uly graph-height 3) run-start run-end timescale maptime run-full-name canvas-margin)
(dboard:tabdat-max-row-set! tabdat (+ (dboard:tabdat-max-row tabdat)(quotient (+ graph-height 40 3) row-height)))
;; (vg:instance-move drawing run-full-name 0 (dboard:tabdat-max-row tabdat))
))
@@ -3887,22 +3902,22 @@
;; tab-num: 2)
(iup:callback-set! *tim*
"ACTION_CB"
(lambda (time-obj)
(let ((update-is-running #f))
- (mutex-lock! (dboard:commondat-update-mutex commondat))
- (set! update-is-running (dboard:commondat-updating commondat))
- (if (not update-is-running)
- (dboard:commondat-updating-set! commondat #t))
- (mutex-unlock! (dboard:commondat-update-mutex commondat))
- (if (not update-is-running) ;; we know that the update was not running and we now have a lock on doing an update
+ ;; (mutex-lock! (dboard:commondat-update-mutex commondat))
+ (set! update-is-running (dboard:commondat-updating commondat))
+ (if (not update-is-running)
+ (dboard:commondat-updating-set! commondat #t))
+ ;; (mutex-unlock! (dboard:commondat-update-mutex commondat))
+ (if (not update-is-running) ;; we know that the update was not running and we now have a lock on doing an update
(begin
(dboard:common-run-curr-updaters commondat) ;; (dashboard:run-update commondat)
- (mutex-lock! (dboard:commondat-update-mutex commondat))
+ ;; (mutex-lock! (dboard:commondat-update-mutex commondat))
(dboard:commondat-updating-set! commondat #f)
- (mutex-unlock! (dboard:commondat-update-mutex commondat)))
- ))
+ ;; (mutex-unlock! (dboard:commondat-update-mutex commondat))
+ )))
1))))
;; (debug:print 0 *default-log-port* "Starting updaters")
(let ((th1 (make-thread (lambda ()
(thread-sleep! 1)
(dboard:common-run-curr-updaters commondat 0) ;; force update of summary tab
@@ -3923,11 +3938,11 @@
(define (sync-db-to-tmp tabdat)
(let* ((db-file "./.mtdb/main.db"))
(if (and (not (file-write-access? db-file)) ( > (current-seconds) (+ last-copy-time 5)))
(begin
- (db:multi-db-sync (db:setup #f) 'old2new)
+ (db:multi-db-sync (db:setup) 'old2new)
(set! last-copy-time (current-seconds))
)
)
)
)
@@ -3944,11 +3959,14 @@
(exit 1))))
'("MT_RUN_AREA_HOME" "MT_MEGATEST" "MT_CMDINFO" "MT_TEST_RUN_DIR" "MT_LINKTREE" "MT_TESTSUITENAME"))
)
)
-(setenv "MT_RUN_AREA_HOME" (get-environment-variable "PWD"))
+;; This is NOT good
+;; (setenv "MT_RUN_AREA_HOME" (get-environment-variable "PWD"))
+;; This should be OK but it really should not be necessary
+(setenv "MT_RUN_AREA_HOME" (current-directory))
(if (not (null? remargs))
(if remargs
(begin
(debug:print 0 *default-log-port* "Unrecognised arguments: " (string-intersperse remargs " "))
Index: db.scm
==================================================================
--- db.scm
+++ db.scm
@@ -31,14 +31,16 @@
(declare (uses dbfile))
(declare (uses keys))
(declare (uses ods))
(declare (uses mt))
(declare (uses commonmod))
+(declare (uses configfmod))
(declare (uses mtargs))
(declare (uses rmtmod))
(import commonmod
+ configfmod
(prefix mtargs args:))
(use (srfi 18)
extras
;; tcp
@@ -131,15 +133,15 @@
(debug:print-error 0 *default-log-port* " query " stmt " failed, params: " params ", error: " ((condition-property-accessor 'exn 'message) exn) ", exn=" exn)
(print-call-chain (current-error-port))
default)))
(apply sqlite3:first-result db stmt params)))
-(define (db:setup do-sync)
+(define (db:setup)
(assert *toppath* "FATAL: db:setup called before launch:setup has been run.")
- (let* ((tmpdir (common:get-db-tmp-area)))
+ (let* ((tmpdir (common:make-tmpdir-name *toppath* "")))
(if (not *dbstruct-dbs*)
- (dbfile:setup do-sync *toppath* tmpdir)
+ (dbfile:setup (conc *toppath* "/.mtdb") tmpdir)
*dbstruct-dbs*)))
;; moved from dbfile
;;
;; ADD run-id SUPPORT
@@ -267,17 +269,10 @@
", arguments: " ((condition-property-accessor 'exn 'arguments) exn)
", location: " ((condition-property-accessor 'exn 'location) exn)
))
-;; NB// #f => return dbdir only
-;; (was planned to be; zeroth db with name=main.db)
-;;
-;; If run-id is #f return to create and retrieve the path where the db will live.
-;;
-(define db:dbfile-path common:get-db-tmp-area)
-
(define (db:set-sync db)
(let ((syncprag (configf:lookup *configdat* "setup" "sychronous")))
(sqlite3:execute db (conc "PRAGMA synchronous = " (or syncprag 0) ";"))))
@@ -467,11 +462,11 @@
(get-mtime shm-file))))
;; (define (db:all-db-sync dbstruct)
;; (let* ((dbdat (db:open-db dbstruct #f db:initialize-main-db))
;; (data-synced 0) ;; count of changed records
-;; (tmp-area (common:get-db-tmp-area))
+;; (tmp-area (common:make-tmpdir-name *toppath*))
;; (dbfiles (glob (conc tmp-area"/.mtdb/*.db")))
;; (sync-durations (make-hash-table))
;; (no-sync-db (db:open-no-sync-db)))
;; (for-each
;; (lambda (file) ;; tmp db file
@@ -528,23 +523,63 @@
;; (if dbdat (dbfile:add-dbdat dbstruct #f dbdat))
;; )
;; #t)
(define (db:kill-servers)
- (let* ((servers (server:choose-server *toppath* 'all-valid))) ;; (server:get-list *toppath*))
- (for-each
- (lambda (server)
- (handle-exceptions
- exn
- (begin
- (debug:print-info 0 *default-log-port* "Unable to get host and/or port from " server ", exn=" exn)
- #f)
- (match-let (((mod-time host port start-time server-id pid) server))
- (if (and host pid)
- (tasks:kill-server host pid)))))
- servers)
- (delete-file* (common:get-sync-lock-filepath))))
+ (let* ((tl (launch:setup)) ;; need this to initialize *toppath*
+ (servdir (conc *toppath* "/.servinfo"))
+ (servfiles (glob (conc servdir "/*:*.db")))
+ (fmtstr "~10a~22a~10a~25a~25a~8a\n")
+ (dbfiles (append (glob (conc *toppath* "/.mtdb/main.db")) (glob (conc *toppath* "/.mtdb/?.db"))(glob (conc *toppath* "/.mtdb/??.db"))))
+ (ttdat (make-tt areapath: *toppath*))
+ )
+ (format #t fmtstr "DB" "host:port" "PID" "age" "last mod" "state")
+ (for-each
+ (lambda (dbfile)
+ (let* (
+ (dbfname (conc (pathname-file dbfile) ".db"))
+ (sfiles (tt:find-server *toppath* dbfname))
+ )
+ (for-each
+ (lambda (sfile)
+ (let (
+ (sinfos (tt:get-server-info-sorted ttdat dbfname))
+ )
+ (for-each
+ (lambda (sinfo)
+ (let* (
+ (db (list-ref sinfo 5))
+ (pid (list-ref sinfo 4))
+ (host (list-ref sinfo 0))
+ (port (list-ref sinfo 1))
+ (server-id (list-ref sinfo 3))
+ (age (seconds->hr-min-sec (- (current-seconds) (list-ref sinfo 2))))
+ (last-mod (seconds->string (list-ref sinfo 2)))
+ (killed (system (conc "ssh " host " kill " pid " > /dev/null")))
+ (dummy2 (sleep 1))
+ (state (if (> (system (conc "ssh " host " ps " pid " > /dev/null")) 0) "dead" "alive"))
+ )
+ (format #t fmtstr db (conc host ":" port) pid age last-mod state)
+ (system (conc "rm " sfile))
+ )
+ )
+ sinfos
+ )
+ )
+ )
+ sfiles
+ )
+ )
+ )
+ dbfiles
+ )
+ ;; remove this db, because otherwise metadata contains records for old servers, and this causes a problem with db:no-sync-get-lock-with-id.
+ (if (file-exists? (conc *toppath* "/.mtdb/no-sync.db"))
+ (delete-file (conc *toppath* "/.mtdb/no-sync.db"))
+ )
+ )
+)
;; options:
;;
;; 'killservers - kills all servers
;; 'dejunk - removes junk records
@@ -556,34 +591,34 @@
;; run-ids: '(1 2 3 ...) or #f (for all)
;;
(define (db:multi-db-sync dbstruct . options)
(let* (;; (dbdat (db:open-db dbstruct #f dbfile:db-init-proc))
(data-synced 0) ;; count of changed records
- (tmp-area (common:get-db-tmp-area))
+ (tmp-area (common:make-tmpdir-name *toppath* ""))
(old2new (member 'old2new options))
(dejunk (member 'dejunk options))
(killservers (member 'killservers options))
(src-area (if old2new *toppath* tmp-area))
- (dest-area (if old2new tmp-area *toppath*))
+ (dest-area (if old2new tmp-area (conc *toppath* "/.mtdb")))
(dbfiles (if old2new (glob (conc *toppath* "/.mtdb/*.db"))
- (glob (conc tmp-area "/.mtdb/*.db"))))
+ (glob (conc tmp-area "/*.db"))))
(keys (db:get-keys dbstruct))
(sync-durations (make-hash-table)))
;; kill servers
- (if killservers (db:kill-servers))
+ ;; (if killservers (db:kill-servers))
(if (not dbfiles)
(debug:print-error 0 *default-log-port* "no dbfiles found in " (conc *toppath* "/.mtdb"))
(for-each
(lambda (srcfile)
(debug:print-info 3 *default-log-port* "file: " srcfile)
(let* ((fname (conc (pathname-file srcfile) ".db"))
(basename (pathname-file srcfile))
(run-id (if (string= basename "main") #f (string->number basename)))
- (destfile (conc dest-area "/.mtdb/" fname))
- (dest-directory (conc dest-area "/.mtdb/"))
+ (destfile (conc dest-area "/" fname))
+ (dest-directory dest-area)
(time1 (file-modification-time srcfile))
(time2 (if (file-exists? destfile)
(begin
(debug:print-info 2 *default-log-port* "destfile " destfile " exists")
(file-modification-time destfile))
@@ -603,33 +638,37 @@
#t)
((and changed *time-to-exit*) ;; last sync
#t)
(else
#f))))
- (if (or dejunk do-cp)
+
+ (if (or dejunk do-cp)
(let* ((start-time (current-milliseconds))
- ;; subdb is misnamed - should be dbdat (I think...)
- (subdb (dbfile:open-db dbstruct run-id dbfile:db-init-proc))
- ;; (or (dbfile:get-subdb dbstruct run-id)
- ;; (dbfile:init-subdb dbstruct run-id dbfile:db-init-proc)))
+ (subdb (or (dbfile:get-subdb dbstruct run-id) (dbfile:init-subdb dbstruct run-id dbfile:db-init-proc)))
+ (dbdat (or (dbfile:get-dbdat dbstruct run-id) (dbfile:open-db dbstruct run-id dbfile:db-init-proc)))
(mtdb (dbr:subdb-mtdbdat subdb))
;;
;; BUG: -mrw- I think this next line is wrong. run-id should be the path to .mtdb/.db
;;
(tmpdb (dbfile:open-db dbstruct run-id dbfile:db-init-proc)))
+ (if dejunk
+ (begin
+ (debug:print 0 *default-log-port* "Cleaning tmp DB")
+ (db:clean-up run-id tmpdb)
+ (debug:print 0 *default-log-port* "Cleaning nfs DB")
+ (db:clean-up run-id mtdb)
+ )
+ )
(debug:print-info 2 *default-log-port* "delta syncing file: " srcfile ", time diff: " (- time1 time2) " seconds")
(if old2new
(begin
- (if dejunk (db:clean-up run-id mtdb))
(db:sync-tables (db:sync-all-tables-list
- dbstruct
(db:get-keys dbstruct))
#f mtdb tmpdb))
(begin
- (if dejunk (db:clean-up run-id tmpdb))
- (db:sync-tables (db:sync-all-tables-list dbstruct (db:get-keys dbstruct)) #f tmpdb mtdb)))
+ (db:sync-tables (db:sync-all-tables-list (db:get-keys dbstruct)) #f tmpdb mtdb)))
(hash-table-set! sync-durations (conc srcfile ".db") (- (current-milliseconds) start-time)))
(debug:print-info 2 *default-log-port* "skipping delta sync. " srcfile " is up to date"))))
dbfiles))
data-synced))
@@ -641,11 +680,11 @@
(for-each
(lambda (subdb)
(let* ((mtdb (dbr:subdb-mtdb subdb))
(tmpdb (db:get-subdb dbstruct run-id))
(refndb (dbr:subdb-refndb subdb))
- (newres (db:sync-tables (db:sync-all-tables-list dbstruct (db:get-keys dbstruct)) last-update tmpdb refndb mtdb)))
+ (newres (db:sync-tables (db:sync-all-tables-list (db:get-keys dbstruct)) last-update tmpdb refndb mtdb)))
;; (stack-push! (dbr:subdb-dbstack subdb) tmpdb)
;; BUG: verify this is really needed
(dbfile:add-dbdat dbstruct run-id tmpdb)
(set! res (cons newres res))))
subdbs)
@@ -1149,16 +1188,19 @@
;; 2. Look at run records
;; a. If have tests that are not deleted, set state='unknown'
;; b. ....
;;
(define (db:clean-up run-id dbdat)
- (debug:print 2 *default-log-port* "db:clean-up")
-
-
(if run-id
- (db:clean-up-rundb dbdat)
- (db:clean-up-maindb dbdat)
+ (begin
+ (debug:print 0 *default-log-port* "Cleaning run DB " run-id)
+ (db:clean-up-rundb dbdat run-id)
+ )
+ (begin
+ (debug:print 0 *default-log-port* "Cleaning main DB ")
+ (db:clean-up-maindb dbdat)
+ )
)
)
;; Clean out old junk and vacuum the database
@@ -1170,38 +1212,42 @@
;; b. If test dir gone, delete the test record
;; 2. Look at run records
;; a. If have tests that are not deleted, set state='unknown'
;; b. ....
;;
-(define (db:clean-up-rundb dbdat)
+(define (db:clean-up-rundb dbdat run-id)
;; (debug:print 0 *default-log-port* "WARNING: db clean up not fully ported to v1.60, cleanup action will be on megatest.db")
(let* ((db (dbr:dbdat-dbh dbdat))
- (count-stmt (sqlite3:prepare db "SELECT (SELECT count(id) FROM tests);"))
+ (test-count-stmt (sqlite3:prepare db "SELECT (SELECT count(id) FROM tests);"))
+ (step-count-stmt (sqlite3:prepare db "SELECT (SELECT count(id) FROM test_steps);"))
(statements
(map (lambda (stmt)
(sqlite3:prepare db stmt))
(list
- ;; delete all tests that belong to runs that are 'deleted'
- ;; (conc "DELETE FROM tests WHERE run_id NOT IN (" (string-intersperse (map conc valid-runs) ",") ");")
- ;; delete all tests that are 'DELETED'
"DELETE FROM tests WHERE state='DELETED';"
+ "DELETE FROM test_steps WHERE status = 'DELETED';"
+ "DELETE FROM tests WHERE run_id IN (SELECT id FROM runs WHERE state = 'deleted');"
))))
- ;; (db:delay-if-busy dbdat)
(sqlite3:with-transaction
db
(lambda ()
(sqlite3:for-each-row (lambda (tot)
- (debug:print-info 0 *default-log-port* "Records count before clean: " tot))
- count-stmt)
+ (debug:print-info 0 *default-log-port* "Test records count before clean: " tot))
+ test-count-stmt)
+ (sqlite3:for-each-row (lambda (tot)
+ (debug:print-info 0 *default-log-port* "Test_step records count before clean: " tot))
+ step-count-stmt)
(map sqlite3:execute statements)
(sqlite3:for-each-row (lambda (tot)
- (debug:print-info 0 *default-log-port* "Records count after clean: " tot))
- count-stmt)))
+ (debug:print-info 0 *default-log-port* "Test records count after clean: " tot))
+ test-count-stmt)
+ (sqlite3:for-each-row (lambda (tot)
+ (debug:print-info 0 *default-log-port* "Test_step records count after clean: " tot))
+ step-count-stmt)))
(map sqlite3:finalize! statements)
- (sqlite3:finalize! count-stmt)
- ;; (db:find-and-mark-incomplete db)
- ;; (db:delay-if-busy dbdat)
+ (sqlite3:finalize! test-count-stmt)
+ (sqlite3:finalize! step-count-stmt)
(sqlite3:execute db "VACUUM;")))
;; Clean out old junk and vacuum the database
;;
;; Ultimately do something like this:
@@ -1235,15 +1281,15 @@
;; (db:delay-if-busy dbdat)
(sqlite3:with-transaction
db
(lambda ()
(sqlite3:for-each-row (lambda (tot)
- (debug:print-info 0 *default-log-port* "Records count before clean: " tot))
+ (debug:print-info 0 *default-log-port* "Run records count before clean: " tot))
count-stmt)
(map sqlite3:execute statements)
(sqlite3:for-each-row (lambda (tot)
- (debug:print-info 0 *default-log-port* "Records count after clean: " tot))
+ (debug:print-info 0 *default-log-port* "Run records count after clean: " tot))
count-stmt)))
(map sqlite3:finalize! statements)
(sqlite3:finalize! count-stmt)
;; (db:find-and-mark-incomplete db)
;; (db:delay-if-busy dbdat)
@@ -1254,11 +1300,11 @@
;; no-sync.db - small bits of data to be shared between servers
;;======================================================================
(define (db:get-dbsync-path)
(case (rmt:transport-mode)
- ((http)(common:get-db-tmp-area))
+ ((http)(common:make-tmpdir-name *toppath* ""))
((tcp) (conc *toppath*"/.mtdb"))
((nfs) (conc *toppath*"/.mtdb"))
(else "/tmp/dunno-this-gonna-exist")))
;; This is needed for api.scm
@@ -1419,62 +1465,85 @@
#f
(simple-run-id (car runs)))))
;; called with run-id=#f so will operate on main.db
;;
-(define (db:insert-run dbstruct target runname run-meta)
+(define (db:insert-run dbstruct run-id target runname run-meta)
(let* ((keys (db:get-keys dbstruct))
(runs (db:simple-get-runs dbstruct runname #f #f target #f))) ;; runpatt count offset target last-update
;; need to insert run based on target and runname
(let* ((targvals (string-split target "/"))
(keystr (string-intersperse keys ","))
(key?str (string-intersperse (make-list (length targvals) "?") ","))
- (qrystr (conc "INSERT INTO runs (runname,"keystr") VALUES (?,"key?str")"))
+ (qrystr (conc "INSERT INTO runs (id,runname,"keystr") VALUES (?,?,"key?str")"))
(get-var (lambda (db qrystr)
(let* ((res #f))
(sqlite3:for-each-row
(lambda row
(set res (car row)))
- db qrystr runname)
+ db qrystr run-id runname)
res))))
(if (null? runs)
- (db:create-initial-run-record dbstruct runname target))
- (let* ((run-id (db:get-run-id dbstruct runname target)))
- (db:with-db
+ (begin
+ (db:create-initial-run-record dbstruct run-id runname target)
+ )
+ )
+ (let* ()
+ ;;(debug:print 0 *default-log-port* "db:insert-run: Calling db:with-db to update the run record")
+ (debug:print 0 *default-log-port* "db:insert-run: runid = " run-id)
+#; (db:with-db
dbstruct
#f #t
(lambda (dbdat db)
+ (debug:print 0 *default-log-port* "In the lambda proc for " dbdat " " db)
(for-each
(lambda (keyval)
+ (debug:print 0 *default-log-port* "In the lambda proc for " keyval)
(let* ((fieldname (car keyval))
(getqry (conc "SELECT "fieldname" FROM runs WHERE id=?;"))
(setqry (conc "UPDATE runs SET "fieldname"=? WHERE id=?;"))
(val (cdr keyval))
(valnum (if (number? val)
val
(if (string? val)
(string->number val)
#f))))
+ (debug:print 0 *default-log-port* "fieldname " fieldname " val " val " valnum " valnum)
(if (not (member fieldname (cons "runname" keys))) ;; don't attempt to tweak these
(let* ((curr-val (get-var db getqry))
(have-it (or (equal? curr-val val)
(equal? curr-val valnum))))
+ (debug:print 0 *default-log-port* "have-it = " have-it)
(if (not have-it)
- (sqlite3:execute db setqry (or valnum val) run-id))))))
+ (begin
+ (debug:print 0 *default-log-port* "Do sqlite3:execute")
+ ;; (sqlite3:execute db setqry (or valnum val) run-id)
+ )
+ )
+ )
+ )
+ (debug:print 0 *default-log-port* "Done with update")
+ )
+ (debug:print 0 *default-log-port* "next keyval")
+ )
run-meta)))
run-id))))
-(define (db:create-initial-run-record dbstruct runname target)
+(define (db:create-initial-run-record dbstruct run-id runname target)
(let* ((keys (db:get-keys dbstruct))
(targvals (string-split target "/"))
(keystr (string-intersperse keys ","))
- (key?str (string-intersperse (make-list (length targvals) "?") ","))
- (qrystr (conc "INSERT INTO runs (runname,"keystr") VALUES (?,"key?str")")))
+ (key?str (string-intersperse (make-list (length targvals) "?") ",")) ;; a string with the same length as targvals, where each element is "?" and interspersed with commas.
+ (qrystr (conc "INSERT INTO runs (id,runname,"keystr") VALUES (?,?,"key?str")")))
+ (debug:print 0 *default-log-port* "db:create-initial-run-record")
+ (debug:print 0 *default-log-port* "qrystr = " qrystr)
+
(db:with-db
- dbstruct #f #t
+ dbstruct #f #t ;; run-id writable
(lambda (dbdat db)
- (apply sqlite3:execute db qrystr runname targvals)))))
+ (debug:print 0 *default-log-port* "lambda proc: dbdat: " dbdat " db: " db)
+ (apply sqlite3:execute db qrystr run-id runname targvals)))))
(define (db:insert-test dbstruct run-id test-rec)
(let* ((testname (alist-ref "testname" test-rec equal?))
(item-path (alist-ref "item_path" test-rec equal?))
(id (db:get-test-id dbstruct run-id testname item-path))
@@ -1484,11 +1553,11 @@
(conc (car dat)"=?"))
fieldvals)
",")" WHERE id=?;"))
(insqry (conc "INSERT INTO tests ("(string-intersperse (map (lambda (x) (car x)) fieldvals) ",")
") VALUES ("(string-intersperse (make-list (length fieldvals) "?") ",")");")))
- (debug:print 0 *default-log-port* "id: "id"\nset: "setqry"\ninsqry: "insqry)
+ ;; (debug:print 0 *default-log-port* "id: "id"\nset: "setqry"\ninsqry: "insqry)
(db:with-db
dbstruct
run-id #t
(lambda (dbdat db)
(if id
@@ -1580,11 +1649,11 @@
;; TODO: Switch this to use max(update_time) from each run db? Then if using a server there is no disk traffic (using cachedb db) ???
;;
;; NOTE: This DOESN'T (necessarily) get the real run ids, but the number of the .db!!
(define (db:get-changed-run-ids since-time)
- (let* ((dbdir (db:dbfile-path)) ;; (configf:lookup *configdat* "setup" "dbdir"))
+ (let* ((dbdir (common:make-tmpdir-name *toppath* "")) ;; (configf:lookup *configdat* "setup" "dbdir"))
(alldbs (glob (conc *toppath* "/.mtdb/[0-9]*.db*")))
(changed (filter (lambda (dbfile)
(> (file-modification-time dbfile) since-time))
alldbs)))
(delete-duplicates
@@ -2234,21 +2303,24 @@
qry
run-id
(or last-update 0))))))
(define (db:get-testinfo-state-status dbstruct run-id test-id)
- (let ((res #f))
- (db:with-db dbstruct run-id #f
- (lambda (dbdat db)
- (sqlite3:for-each-row
- (lambda (run-id testname item-path state status)
- ;; id,run_id,testname,state,status,event_time,host,cpuload,diskfree,uname,rundir,item_path,run_duration,final_logf,comment
- (set! res (vector test-id run-id testname state status -1 "" -1 -1 "" "-" item-path -1 "-" "-")))
- db
- "SELECT run_id,testname,item_path,state,status FROM tests WHERE id=? and run_id=?;"
- test-id run-id)))
- res))
+ (db:with-db
+ dbstruct run-id #f
+ (lambda (dbdat db)
+ (let* ((res #f)
+ (stmth (db:get-cache-stmth dbdat db "SELECT run_id,testname,item_path,state,status FROM tests WHERE id=? and run_id=?;")))
+ (sqlite3:for-each-row
+ (lambda (run-id testname item-path state status)
+ ;; id,run_id,testname,state,status,event_time,host,cpuload,diskfree,uname,rundir,item_path,run_duration,final_logf,comment
+ (set! res (vector test-id run-id testname state status -1 "" -1 -1 "" "-" item-path -1 "-" "-")))
+ ;; db
+ ;; "SELECT run_id,testname,item_path,state,status FROM tests WHERE id=? and run_id=?;"
+ stmth
+ test-id run-id)
+ res))))
;; get a useful subset of the tests data (used in dashboard
;; use db:mintest-get-{id ,run_id,testname ...}
;;
(define (db:get-tests-for-run-mindata dbstruct run-id testpatt states statuses not-in)
@@ -2279,25 +2351,37 @@
dbstruct run-id #t
(lambda (dbdat db)
(sqlite3:execute db "UPDATE tests SET state='DELETED',status='n/a',comment='' WHERE id=?;" test-id))))
;;
-(define (db:delete-old-deleted-test-records dbstruct)
- (let ((targtime (- (current-seconds)
- (or (configf:lookup-number *configdat* "setup" "keep-deleted-records")
- (* 30 24 60 60))))) ;; one month in the past
+(define (db:delete-old-deleted-test-records dbstruct run-id)
+ (let* ((targtime (- (current-seconds)
+ (or (configf:lookup-number *configdat* "setup" "keep-deleted-records")
+ (* 7 24 60 60)))) ;; cleanup if over one week old
+ (mtdbfile (dbmod:run-id->full-dbfname dbstruct run-id))
+ (qry1 "DELETE FROM test_steps WHERE test_id IN (SELECT id FROM tests WHERE state='DELETED' AND event_timealist res)))))
+;; testmeta doesn't change, we can cache it for up too an hour
+
+(define *db:testmeta-cache* (make-hash-table))
+(define *db:testmeta-last-update* 0)
+
;; read the record given a testname
(define (db:testmeta-get-record dbstruct testname)
- (let ((res #f))
- (db:with-db
- dbstruct
- #f
- #f
- (lambda (dbdat db)
- (sqlite3:for-each-row
- (lambda (id testname author owner description reviewed iterated avg_runtime avg_disk tags jobgroup)
- (set! res (vector id testname author owner description reviewed iterated avg_runtime avg_disk tags jobgroup)))
- db
- "SELECT id,testname,author,owner,description,reviewed,iterated,avg_runtime,avg_disk,tags,jobgroup FROM test_meta WHERE testname=?;"
- testname)
- res))))
+ (if (and (< (- (current-seconds) *db:testmeta-last-update*) 600)
+ (hash-table-exists? *db:testmeta-cache* testname))
+ (hash-table-ref *db:testmeta-cache* testname)
+ (let ((res #f))
+ (db:with-db
+ dbstruct
+ #f
+ #f
+ (lambda (dbdat db)
+ (sqlite3:for-each-row
+ (lambda (id testname author owner description reviewed iterated avg_runtime avg_disk tags jobgroup)
+ (set! res (vector id testname author owner description reviewed iterated avg_runtime avg_disk tags jobgroup)))
+ db
+ "SELECT id,testname,author,owner,description,reviewed,iterated,avg_runtime,avg_disk,tags,jobgroup FROM test_meta WHERE testname=?;"
+ testname)))
+ (hash-table-set! *db:testmeta-cache* testname res)
+ (set! *db:testmeta-last-update* (current-seconds))
+ res)))
;; create a new record for a given testname
(define (db:testmeta-add-record dbstruct testname)
(db:with-db dbstruct #f #t
(lambda (dbdat db)
@@ -4314,11 +4408,11 @@
))))
;; sync for filesystem local db writes
;;
(define (db:run-lock-and-sync no-sync-db)
- (let* ((tmp-area (common:get-db-tmp-area))
+ (let* ((tmp-area (common:make-tmpdir-name *toppath* ""))
(dbfiles (glob (conc tmp-area"/.mtdb/*.db")))
(sync-durations (make-hash-table)))
;; (debug:print-info 0 *default-log-port* "lock-and-sync, dbfiles: "dbfiles)
(for-each
(lambda (file)
@@ -4370,11 +4464,11 @@
(sync-stale-seconds (configf:lookup-number *configdat* "server" "sync-stale-seconds" default: 300))
(debug-mode (debug:debug-mode 1))
(last-time (current-seconds)) ;; last time through the sync loop
(no-sync-db (db:open-no-sync-db))
(sync-duration 0) ;; run time of the sync in milliseconds
- (tmp-area (common:get-db-tmp-area)))
+ (tmp-area (common:make-tmpdir-name *toppath* "")))
;; Sync moved to http-transport keep-running loop
(debug:print-info 2 *default-log-port* "Periodic copy-based sync thread started. syncer is copy-sync, tmp-area is " tmp-area)
(debug:print-info 3 *default-log-port* "watchdog starting. syncer is copy-sync pid="(current-process-id));; " this-wd-num="this-wd-num)
(if (and legacy-sync (not *time-to-exit*))
@@ -4478,11 +4572,11 @@
(for-each
(lambda (subdb)
(let* (;;(dbstruct (db:setup))
(mtdb (dbr:subdb-mtdb subdb))
(mtpath (db:dbdat-get-path mtdb))
- (tmp-area (common:get-db-tmp-area))
+ (tmp-area (common:make-tmpdir-name *toppath* ""))
(res (db:sync-to-megatest.db dbstruct no-sync-db: no-sync-db))) ;; did we sync any data? If so need to set the db touched flag to keep the server alive
(set! sync-duration (- (current-milliseconds) sync-start))
(if (> res 0) ;; some records were transferred, keep the db alive
(begin
(mutex-lock! *heartbeat-mutex*)
@@ -4526,11 +4620,10 @@
;; (db:no-sync-close-db no-sync-db stmt-cache)
(if (common:low-noise-print 30)
(debug:print-info 0 *default-log-port* "Exiting watchdog timer, *time-to-exit* = " *time-to-exit*" pid="(current-process-id) ))))
))
-
(define (std-exit-procedure)
;;(common:telemetry-log-close)
(on-exit (lambda () 0)) ;; why is this here?
;;(debug:print-info 13 *default-log-port* "std-exit-procedure called; *time-to-exit*="*time-to-exit*)
(let ((no-hurry (if *time-to-exit* ;; hurry up
@@ -4539,11 +4632,11 @@
(set! *time-to-exit* #t)
#t))))
(debug:print-info 4 *default-log-port* "starting exit process, finalizing databases.")
(if (and no-hurry
(debug:debug-mode 18))
- (rmt:print-db-stats))
+ (dbmod:print-db-stats))
(let ((th1 (make-thread (lambda () ;; thread for cleaning up, give it five seconds
(if *dbstruct-dbs* (db:close-all *dbstruct-dbs*)) ;; one second allocated
(if (list? *on-exit-procs*)
(for-each
(lambda (proc)
Index: dbfile.scm
==================================================================
--- dbfile.scm
+++ dbfile.scm
@@ -21,16 +21,20 @@
(use srfi-18 posix hostinfo)
(declare (unit dbfile))
(declare (uses debugprint))
(declare (uses commonmod))
+(declare (uses configfmod))
(module dbfile
*
-
- (import scheme
- chicken
+(import scheme)
+
+(cond-expand
+ (chicken-4
+
+ (import chicken
data-structures
extras
matchable
(prefix sqlite3 sqlite3:)
@@ -42,14 +46,58 @@
stack
files
ports
hostinfo
+ commonmod
+ configfmod
+ debugprint
+ )
+ )
+ (chicken-5
+ (import (prefix sqlite3 sqlite3:)
+ ;; data-structures
+ ;; extras
+ ;; files
+ ;; posix
+ ;; posix-extras
+ chicken.base
+ chicken.condition
+ chicken.file
+ chicken.file.posix
+ chicken.format
+ chicken.io
+ chicken.pathname
+ chicken.port
+ chicken.process
+ chicken.process-context
+ chicken.process-context.posix
+ chicken.sort
+ chicken.string
+ chicken.time
+ chicken.time.posix
+
+ matchable
+ md5
+ message-digest
+ pathname-expand
+ regex
+ regex-case
+ srfi-1
+ srfi-18
+ srfi-69
+ typed-records
+ stack
+ system-information
+
commonmod
debugprint
)
-
+ (define file-write-access? file-writable?)
+ (define file-move move-file)
+ ))
+
;; parameters
;;
(define dbfile:testsuite-name (make-parameter #f))
(define keep-age-param (make-parameter 10)) ;; qif file age, if over move to attic
@@ -242,11 +290,12 @@
#f
)
)
(define (dbfile:make-tmpdir-name areapath tmpadj)
- (let* ((dname (conc "/tmp/"(current-user-name)"/" (string-translate areapath "/" ".") tmpadj)))
+ (let* ((area (pathname-file areapath))
+ (dname (conc "/tmp/"(current-user-name)"/megatest_localdb/" area "/" (string-translate areapath "/" ".") tmpadj "/.mtdb")))
(unless (directory-exists? dname)
(create-directory dname #t))
dname))
(define (dbfile:run-id->path apath run-id)
@@ -267,18 +316,18 @@
(define (dbfile:run-id->dbfname run-id)
(conc (dbfile:run-id->dbnum run-id)".db"))
;; the path in MTRAH with the filename
(define (dbfile:run-id->dbname run-id)
- (conc ".mtdb/"(dbfile:run-id->dbfname run-id)))
+ (conc (dbfile:run-id->dbfname run-id)))
;; Make the dbstruct, setup up auxillary db's and call for main db at least once
;;
;; called in http-transport and replicated in rmt.scm for *local* access.
;;
-(define (dbfile:setup do-sync areapath tmppath)
+(define (dbfile:setup areapath tmppath)
(cond
(*dbstruct-dbs*
(dbfile:print-err "WARNING: dbfile:setup called when *dbstruct-dbs* is already initialized")
*dbstruct-dbs*) ;; TODO: when multiple areas are supported, this optimization will be a hazard
(else
@@ -358,11 +407,12 @@
(if dbdat
dbdat
(let* ((tmppath (dbr:dbstruct-tmppath dbstruct))
(tmpdbpath (dbfile:run-id->path tmppath run-id))
(dbdat (dbfile:open-sqlite3-db tmpdbpath init-proc sync-mode: 0 journal-mode: "WAL")))
- ;; the following line short-circuits the "one db handle per thread" model
+
+ ;; the following line short-circuits the "one db handle per thread" model
;;
;; (dbfile:add-dbdat dbstruct run-id dbdat)
;;
dbdat))))))
@@ -445,19 +495,20 @@
(if journal-mode
(sqlite3:execute db (conc "PRAGMA journal_mode = "journal-mode";")))
(if (and init-proc (or force-init
(not db-exists)))
(init-proc db))
- db)))
+ db))
+ expire-time: 5)
(begin
(if (file-exists? fname )
(let ((db (sqlite3:open-database fname)))
;; pragmas synchronous not needed because this db is used read-only
;; (sqlite3:execute db (conc "PRAGMA synchronous = "mode";")
(sqlite3:set-busy-handler! db (sqlite3:make-busy-timeout 30000)) ;; read-only but still need timeout
db )
- (print "file doesn't exist: " fname))))
+ (print "cautious-open-database: file doesn't exist: " fname))))
(exn (io-error)
(dbfile:print-err exn "ERROR: i/o error with " fname ". Check permissions, disk space etc. and try again.")
(retry))
(exn (corrupt)
(dbfile:print-err exn "ERROR: database " fname " is corrupt. Repair it to proceed.")
@@ -487,11 +538,11 @@
;; NOTE: this is already protected by mutex *no-sync-db-mutex*
;;
(define (dbfile:raw-open-no-sync-db dbpath)
(if (not (file-exists? dbpath))
(create-directory dbpath #t))
- (debug:print-info 0 *default-log-port* "Opening "dbpath"/no-sync.db")
+ (debug:print-info 2 *default-log-port* "(dbfile:raw-open-no-sync-db: Opening "dbpath"/no-sync.db")
(let* ((dbname (conc dbpath "/no-sync.db"))
(db-exists (file-exists? dbname))
(init-proc (lambda (db)
(sqlite3:with-transaction
db
@@ -525,18 +576,19 @@
reason TEXT DEFAULT 'none',
CONSTRAINT no_sync_processes UNIQUE (host,pid));"
))))))
(on-tmp (equal? (car (string-split dbpath "/")) "tmp"))
(db (if on-tmp
- (dbfile:cautious-open-database dbname init-proc 0 "WAL" force-init: #t)
- (dbfile:cautious-open-database dbname init-proc 0 #f force-init: #t)
+ (dbfile:cautious-open-database dbname init-proc 1 "WAL" force-init: #t) ;; WAL MODE should use syncronous=1
+ ;; (dbfile:cautious-open-database dbname init-proc 0 #f force-init: #t)
+ (dbfile:cautious-open-database dbname init-proc 0 "MEMORY" force-init: #t) ;; Journal mode = memory is fastest?
;; (sqlite3:open-database dbname)
)))
- (if on-tmp ;; done in cautious-open-database
- (begin
- (sqlite3:execute db "PRAGMA synchronous = 0;")
- (sqlite3:set-busy-handler! db (sqlite3:make-busy-timeout 136000))))
+ ;; (if on-tmp ;; done in cautious-open-database
+ ;; (begin
+ ;; (sqlite3:execute db "PRAGMA synchronous = 0;") ;; why was this here when is is handled by cautious-open-database?
+ (sqlite3:set-busy-handler! db (sqlite3:make-busy-timeout 136000)) ;; ))
db))
;; mtest processes registry calls
(define (dbfile:insert-or-update-process nsdb dat)
@@ -580,18 +632,20 @@
host port pid starttime endtime status purpose dbname mtversion))
(define (dbfile:set-process-status nsdb host pid newstatus)
(sqlite3:execute nsdb "UPDATE processes SET status=? WHERE host=? AND pid=?;" newstatus host pid))
+;; as sorted should be stable. can use to choose "winner"
+;;
(define (dbfile:get-process-options nsdb purpose dbname)
(sqlite3:fold-row
;; host port pid starttime status mtversion
(lambda (res . row)
(cons row res))
'()
nsdb
- "SELECT host,port,pid,starttime,endtime,status,mtversion FROM processes WHERE purpose=? AND dbname LIKE ? AND status='alive';"
+ "SELECT host,port,pid,starttime,endtime,status,mtversion FROM processes WHERE purpose=? AND dbname LIKE ? AND status IN ('running','alive') ORDER BY starttime ASC,host,port;"
purpose dbname))
(define (dbfile:get-process-info nsdb host pid)
(let ((res (sqlite3:fold-row
;; host port pid starttime status mtversion
@@ -602,17 +656,25 @@
"SELECT host,port,pid,starttime,endtime,status,purpose,dbname,mtversion FROM processes WHERE host=? AND pid=?;"
host pid)))
(if (null? res)
#f
(car res))))
+
+(define (dbfile:row->procinf row)
+ (match row
+ ((host port pid starttime endtime status mtversion)
+ (make-procinf host: host port: port pid: pid starttime: starttime endtime: endtime status: status mtversion: mtversion))
+ (else
+ (debug:print 0 *default-log-port* "ERROR: row "row" did not match host,port,pid,starttime,endtime,status,mtversion")
+ #f)))
(define (dbfile:set-process-done nsdb host pid reason)
- (sqlite3:execute nsdb "UPDATE processes SET status='ended',endtime=?,reason=? WHERE host=? AND pid=?;" (current-seconds) reason host pid)
+ (sqlite3:execute nsdb "UPDATE processes SET status='done',endtime=?,reason=? WHERE host=? AND pid=?;" (current-seconds) reason host pid)
(dbfile:cleanup-old-entries nsdb))
(define (dbfile:cleanup-old-entries nsdb)
- (sqlite3:execute nsdb "DELETE FROM process WHERE status='ended' AND endtimetimestamp, identifier
((timestamp . ident)
(cons (equal? ident identifier) timestamp))
- (else (cons #f 'malformed-lock))) ;; lock malformed
+ (else
+ (debug:print 2 *default-log-port* "db:no-sync-get-lock-with-id: malformed lock")
+ (cons #f 'malformed-lock)
+ )
+ ) ;; lock malformed
(let ((curr-sec (current-seconds))
(lock-value (if identifier
(conc (current-seconds)"+"identifier)
(current-seconds))))
(sqlite3:execute db "INSERT OR REPLACE INTO no_sync_metadat (var,val) VALUES(?,?);" keyname lock-value)
@@ -1572,7 +1640,15 @@
;; (db:hoh-set! stmt-cache db stmt newstmth)
(hash-table-set! stmt-cache stmt newstmth)
newstmth))))
(mutex-unlock! *get-cache-stmth-mutex*)
result))
+
+;; (define *mutex-stmth-call* (make-mutex))
+;;
+;; (define (db:with-mutex-for-stmth proc)
+;; (mutex-lock! *mutex-stmth-call*)
+;; (let* ((res (proc)))
+;; (mutex-unlock! *mutex-stmth-call*)
+;; res))
)
Index: dbmod.scm
==================================================================
--- dbmod.scm
+++ dbmod.scm
@@ -20,33 +20,55 @@
;;======================================================================
(declare (unit dbmod))
(declare (uses dbfile))
(declare (uses commonmod))
+(declare (uses configfmod))
(declare (uses debugprint))
(module dbmod
*
-(import scheme
- chicken
- data-structures
- extras
- files
+(import scheme)
+
+(cond-expand
+ (chicken-4
+ (import chicken
+ data-structures
+ extras
+ files
+
+ posix
+
+ ))
+ (chicken-5
+ (import chicken.base
+ chicken.condition
+ chicken.file
+ chicken.pathname
+ chicken.process
+ chicken.sort
+ chicken.string
+ chicken.time
+
+ )
+ (define file-read-access? file-readable?)
+ (define file-copy copy-file)
+ ))
+(import format
(prefix sqlite3 sqlite3:)
matchable
- posix
typed-records
srfi-1
srfi-18
srfi-69
commonmod
+ configfmod
dbfile
- debugprint
- )
+ debugprint)
;; NOTE: This returns only the name "1.db", "main.db", not the path
;;
(define (dbmod:run-id->dbfname run-id)
(conc (dbfile:run-id->dbnum run-id)".db"))
@@ -58,15 +80,12 @@
(not (file-exists? dbdir)))
(create-directory dbdir))
dbdir))
(define (dbmod:run-id->full-dbfname dbstruct run-id)
- (conc (dbmod:get-dbdir dbstruct
-
- run-id
-
- )"/"(dbmod:run-id->dbfname run-id)))
+ (conc (dbmod:get-dbdir dbstruct)
+ "/"(dbmod:run-id->dbfname run-id)))
;;======================================================================
;; Read-only cachedb cached direct from disk method
;;======================================================================
@@ -87,19 +106,19 @@
;; The cachedb one-db file per server method goes in here
;;======================================================================
;; NOTE: the r/w is now w/r, #t=db modified by query, #f=db NOT modified by query
(define (dbmod:with-db dbstruct run-id w/r proc params)
- (let* ((use-mutex (or (and w/r ;; use the mutex on queries that modify the db and for sync to disk
- (> *api-process-request-count* 5)) ;; when writes are happening throttle more
- (> *api-process-request-count* 50)))
+ (let* ((use-mutex w/r) ;; (or (and w/r ;; use the mutex on queries that modify the db and for sync to disk
+ ;; (> *api-process-request-count* 5)) ;; when writes are happening throttle more
+ ;; (> *api-process-request-count* 50)))
(dbdat (dbmod:open-db dbstruct run-id (dbfile:db-init-proc)))
(dbh (dbr:dbdat-dbh dbdat)) ;; this will be the cachedb handle
(dbfile (dbr:dbdat-dbfile dbdat)))
;; if nfs mode do a sync if delta > 2
- (let* ((last-update (dbr:dbstruct-last-update dbstruct))
- (sync-proc (dbr:dbstruct-sync-proc dbstruct))
+ #;(let* ((last-update (dbr:dbstruct-last-update dbstruct))
+ ;; (sync-proc (dbr:dbstruct-sync-proc dbstruct))
(curr-secs (current-seconds)))
(if (> (- curr-secs last-update) 5)
(begin
(sync-proc last-update)
@@ -119,11 +138,11 @@
(loop (- count 1)))
(begin
(debug:print-info 0 *default-log-port* "dbmod:with-db, database is busy, giving up.")
(exit 1))))
(exn ()
- (dbfile:print-err exn "ERROR: Unknown error with database for run-id "run-id", message: "
+ (dbfile:print-err exn "ERROR: dbmod:with-db: Unknown error with database for run-id "run-id", message: "
((condition-property-accessor 'exn 'message) exn))
(exit 2))))))
(if use-mutex (mutex-unlock! *db-with-db-mutex*))
res)))
@@ -198,11 +217,11 @@
(let* ((dbstruct (or dbstruct-in (make-dbr:dbstruct areapath: areapath)))
(dbfname (or dbfname-in (dbmod:run-id->dbfname run-id)))
(dbpath (dbmod:get-dbdir dbstruct)) ;; directory where all the .db files are kept
(dbfullname (conc dbpath"/"dbfname)) ;; (dbmod:run-id->full-dbfname dbstruct run-id))
(dbexists (file-exists? dbfullname))
- (tmpdir (dbfile:make-tmpdir-name areapath tmpadj))
+ (tmpdir (common:make-tmpdir-name areapath tmpadj))
(tmpdb (let* ((fname (conc tmpdir"/"dbfname)))
fname))
(cachedb (dbmod:open-cachedb-db init-proc
;; (if (eq? (dbfile:cache-method) 'cachedb)
;; #f
@@ -224,51 +243,22 @@
(dbr:dbstruct-dbtmpname-set! dbstruct tmpdb)
(dbr:dbstruct-dbfname-set! dbstruct dbfname)
(dbr:dbstruct-sync-proc-set! dbstruct
(lambda (last-update)
(if *sync-in-progress*
- (debug:print 3 *default-log-port* "WARNING: overlapping calls to sync to disk")
- (let* ((syncer-logfile (conc areapath"/logs/"dbfname"-syncer.log"))
- (sync-cmd (if (eq? syncdir 'todisk)
- (conc "(NBFAKE_LOG="syncer-logfile" nbfake megatest -db2db -from "tmpdb" -to "dbfullname" -period 5 -timeout 10 > /dev/null 2&>1)&")
- (conc "(NBFAKE_LOG="syncer-logfile" nbfake megatest -db2db -from "dbfullname" -to "tmpdb" -period 5 -timeout 10 > /dev/null 2&>1)&")))
- (synclock-file (conc dbfullname".lock"))
- (syncer-running-file (conc dbfullname"-sync-running"))
- (synclock-mod-time (if (file-exists? synclock-file)
- (handle-exceptions
- exn
- #f
- (file-modification-time synclock-file))
- #f))
- (thethread (lambda ()
- (thread-start!
- (make-thread
- (lambda ()
- (set! *sync-in-progress* #t)
- (debug:print-info "Running "sync-cmd)
- (if (file-exists? syncer-running-file)
- (debug:print-info 0 *default-log-port* "Syncer still running, skipping syncer start.")
- (system sync-cmd))
- (set! *sync-in-progress* #f)))))))
- (if ((if (eq? syncdir 'todisk) < >) ;; use less than for todisk, greater than for from disk
- (file-modification-time tmpdb)
- (file-modification-time dbfullname))
- (debug:print 4 *default-log-port* "Skipping sync, "tmpdb" older than "dbfullname)
- (if synclock-mod-time
- (if (> (- (current-seconds) synclock-mod-time) 20) ;; something wrong with sync, remove file
- (begin
- (handle-exceptions
- exn
- #f
- (begin
- (debug:print 0 *default-log-port* "Sync lock file " synclock-file "is older than 20 seconds (" synclock-mod-time " seconds). Removing it")
- (delete-file synclock-file)
- )
- )
- (thethread))
- (debug:print 0 *default-log-port* "Skipping sync, lockfile "synclock-file" found."))
- (thethread)))))))
+ (debug:print 0 *default-log-port* "WARNING: overlapping calls to sync to disk")
+ (begin
+ ;; turn off writes - send busy or block?
+ ;; call db2db internally
+ ;; turn writes back on
+ ;;
+ (set! *api-halt-writes* #t) ;; do we need a mutex?
+ ;; (dbmod:db-to-db-sync src-db dest-db last-update (dbfile:db-init-proc) keys)
+ (debug:print-info 2 *default-log-port* "Internal sync running from "tmpdb" to "dbfullname)
+ (dbmod:db-to-db-sync tmpdb dbfullname last-update (dbfile:db-init-proc) keys)
+ (set! *api-halt-writes* #f)
+ ))))
;; (dbmod:sync-tables tables #f db cachedb)
;;
(thread-sleep! 1) ;; let things settle before syncing in needed data
(dbmod:sync-gasket tables #f cachedb db dbfullname 'fromdest keys) ;; ) ;; load into cachedb
(dbr:dbstruct-last-update-set! dbstruct (+ (current-seconds) -10)) ;; should this be offset back in time by one second?
@@ -474,47 +464,63 @@
(set! has-last #t)))
dbh
(conc "SELECT name FROM pragma_table_info('"tablename"') as tblInfo;"))
has-last))
+(define (replace-question-marks-with-number str num)
+ (define (replace-helper str index result)
+ (if (>= index (string-length str))
+ result
+ (let ((char (string-ref str index)))
+ (if (char=? char #\?)
+ (replace-helper str (+ index 1) (string-append result (number->string num)))
+ (replace-helper str (+ index 1) (string-append result (string char)))))))
+
+ (replace-helper str 0 ""))
+
+
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;; tbls is ( ("tablename" ( "field1" [#f|proc1] ) ( "field2" [#f|proc2] ) .... ) )
;;
;; direction = fromdest, todisk
;; mode = 'full, 'incr
;;
;; Idea: youngest in dest is last_update time
-;;
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+
(define (dbmod:attach-sync tables dbh destdbfile direction #!key
(mode 'full)
(no-update '("keys")) ;; do
)
- (let* ((num-changes 0)
+ (debug:print-info 2 *default-log-port* "dbmod:attach-sync")
+ (let* ((num-changes 0)
(update-changed (lambda (num-changed table qryname)
(if (> num-changed 0)
(begin
(debug:print-info 0 *default-log-port* "Changed "num-changed" rows for table "table", qry "qryname)
(set! num-changes (+ num-changes num-changed)))))))
- (debug:print 0 *default-log-port* "Doing sync "direction" "destdbfile)
+ (debug:print 2 *default-log-port* "Doing sync "direction" "destdbfile)
(if (not (sqlite3:auto-committing? dbh))
(debug:print 0 *default-log-port* "Skipping sync due to transaction in flight.")
(let* ((table-names (map car tables))
(dest-exists (file-exists? destdbfile)))
(assert dest-exists "FATAL: sync called with non-existant file, "destdbfile)
;; attach the destdbfile
;; for each table
;; insert into dest. select * from src. where last_update>last_update
;; done
- (debug:print 0 *default-log-port* "Attaching "destdbfile" as auxdb")
+ (debug:print 2 *default-log-port* "Attaching "destdbfile" as auxdb")
(handle-exceptions
exn
(begin
(debug:print 0 "ATTACH failed, exiting. exn="(condition->list exn))
(exit 1))
(sqlite3:execute dbh (conc "ATTACH '"destdbfile"' AS auxdb;")))
(for-each
(lambda (table)
- (let* ((tbldat (alist-ref table tables equal?))
+ (let* ((dummy (debug:print 2 *default-log-port* "Doing table " table))
+ (tbldat (alist-ref table tables equal?))
(fields (map car tbldat))
(no-id-fields (filter (lambda (x)(not (equal? x "id"))) fields))
(fields-str (string-intersperse fields ","))
(no-id-fields-str (string-intersperse no-id-fields ","))
(dir (eq? direction 'todisk))
@@ -529,27 +535,38 @@
" SELECT * FROM "fromdb table";"))
(stmt2 (conc "INSERT OR IGNORE INTO "todb table
" SELECT * FROM "fromdb table" WHERE "fromdb table".id=?;"))
(stmt8 (conc "UPDATE "todb table" SET ("no-id-fields-str") = (SELECT "no-id-fields-str" FROM "fromdb table" WHERE "todb table".id="fromdb table".id"
(conc " AND "fromdb table".last_update > "todb table".last_update);")
- ");"))
- (stmt9 (conc "UPDATE "todb table" SET ("no-id-fields-str") = "
+ ");"))
+ (update-string (conc "UPDATE "todb table" SET "))
+ (split-update
+ (let ()
+ (for-each
+ (lambda (column)
+ (set! update-string (conc update-string column" = (SELECT "column" FROM "fromdb table" WHERE "fromdb table".id=?), "))
+ )
+ no-id-fields
+ )
+ ;; drop the last ", "
+ (conc (substring update-string 0 (-(string-length update-string) 2)) " WHERE "todb table".id=? ")
+ )
+ )
+
+
+ (stmt9 (conc "UPDATE "todb table" SET ("no-id-fields-str") = "
"(SELECT "no-id-fields-str" FROM "fromdb table" WHERE "fromdb table".id=?)"
" WHERE "todb table".id=?"))
(newrec (conc "SELECT id FROM "fromdb table" WHERE id NOT IN (SELECT id FROM "todb table");"))
- #;(changedrec (conc "SELECT id FROM "fromdb table" WHERE "fromdb table".last_update > "todb table".last_update AND "
- fromdb table".id="todb table".id;")) ;; main = fromdb
(changedrec (conc "SELECT "fromdb table".id FROM "fromdb table" join "todb table" on "fromdb table".id="todb table".id WHERE "fromdb table".last_update > "todb table".last_update;"))
- ;; SELECT main.tests.id FROM main.tests join auxdb.tests on main.tests.id=auxdb.tests.id WHERE main.tests.last_update > auxdb.tests.last_update;"
(start-ms (current-milliseconds))
(new-ids (sqlite3:fold-row (lambda (res id)(cons id res)) '() dbh newrec)))
- ;; (debug:print 0 *default-log-port* "Got "(length aux-ids)" in aux-ids and "(length main-ids)" in main-ids")
(update-changed (length new-ids) table "new records")
(mutex-lock! *db-transaction-mutex*)
(handle-exceptions
exn
- (debug:print 0 *default-log-port* "Transaction update of "table" failed.")
+ (debug:print 0 *default-log-port* "Transaction update of id fields in "table" failed.")
(sqlite3:with-transaction
dbh
(lambda ()
(for-each (lambda (id)
(sqlite3:execute dbh stmt2 id))
@@ -556,23 +573,40 @@
new-ids))))
(if (member "last_update" fields)
(handle-exceptions
exn
- (debug:print 0 *default-log-port* "Transaction update of "table" failed.")
+ (debug:print 0 *default-log-port* "Transaction update of non id fields in "table" failed.")
(sqlite3:with-transaction
dbh
(lambda ()
- (let* ((changed-ids (sqlite3:fold-row (lambda (res id)(cons id res)) '() dbh changedrec)))
+ (let* ((changed-ids (sqlite3:fold-row (lambda (res id)(cons id res)) '() dbh changedrec))
+ (sql-query "")
+ )
(update-changed (length changed-ids) table "changed records")
(for-each (lambda (id)
- (sqlite3:execute dbh stmt9 id id))
- changed-ids))))))
-
+ (let* ((update-with-ids (replace-question-marks-with-number split-update id))
+ )
+ (debug:print 2 *default-log-port* "about to do sqlite3:execute " dbh " " update-with-ids )
+ (handle-exceptions
+ exn
+ (debug:print 0 *default-log-port* "update from " fromdb table " to " todb table " failed: " ((condition-property-accessor 'exn 'message) exn))
+ (sqlite3:execute dbh update-with-ids)
+ )
+ (debug:print 2 *default-log-port* "after sqlite3:execute")
+ )
+ )
+ changed-ids
+ )
+ )
+ )
+ )
+ )
+ )
(mutex-unlock! *db-transaction-mutex*)
- (debug:print 0 *default-log-port* "Synced table "table
+ (debug:print 2 *default-log-port* "Synced table "table
" in "(- (current-milliseconds) start-ms)"ms")
))
table-names)
(sqlite3:execute dbh "DETACH auxdb;")))
@@ -627,11 +661,11 @@
(debug:print 0 *default-log-port* "stmt3="stmt3)
(if (sqlite3:auto-committing? dbh1)
(begin
(handle-exceptions
exn
- (debug:print 0 *default-log-port* "Transaction update of "table" failed.")
+ (debug:print 0 *default-log-port* "Transaction update of "table" failed. "(condition->list exn))
(sqlite3:with-transaction
dbh1
(lambda ()
(sqlite3:execute dbh1 stmt1) ;; get all new rows
@@ -856,6 +890,94 @@
(res (dbmod:sync-gasket tables last-update sdb ddb dest-db 'todisk keys)))
(sqlite3:finalize! sdb)
(sqlite3:finalize! ddb)
res)))
#f))
+
+;; ======================================================================
+;; dbstats
+;;======================================================================
+
+;; (define *dbstruct-dbs* #f) ;; used to cache the dbstruct in db:setup. Goal is to remove this.
+;; db stats
+(define *db-stats* (make-hash-table)) ;; hash of vectors < count duration-total >
+(define *db-stats-mutex* (make-mutex))
+
+(define (dbmod:print-db-stats)
+ (let ((fmtstr "~40a~8-d~20-d~20,2-f")) ;; "~20,2-f"
+ (debug:print 0 *default-log-port* "DB Stats\n========")
+ (debug:print 0 *default-log-port* (format #f "~40a~8a~20a~10a" "Cmd" "Count" "TotTime" "Avg"))
+ (for-each (lambda (cmd)
+ (let* ((dat (hash-table-ref *db-stats* cmd))
+ (count (dbstat-cnt dat))
+ (tottime (dbstat-tottime dat)))
+ (debug:print 0 *default-log-port*
+ (format #f fmtstr cmd count tottime
+ (/ tottime count)))))
+ (sort (hash-table-keys *db-stats*)
+ (lambda (a b)
+ (> (dbstat-tottime (hash-table-ref *db-stats* a))
+ (dbstat-tottime (hash-table-ref *db-stats* b))))))))
+
+(defstruct dbstat
+ (cnt 0)
+ (tottime 0))
+
+(define (db:add-stats cmd run-id params delta)
+ (let* ((modified-cmd (if (eq? cmd 'general-call)
+ (string->symbol (conc "general-call-" (car params)))
+ cmd))
+ (rec (hash-table-ref/default *db-stats* modified-cmd #f)))
+ (if (not rec)
+ (let ((new-rec (make-dbstat)))
+ (hash-table-set! *db-stats* modified-cmd new-rec)
+ (set! rec new-rec)))
+ (dbstat-cnt-set! rec (+ (dbstat-cnt rec) 1))
+ (dbstat-tottime-set! rec (+ (dbstat-tottime rec) delta))))
+
+
+
)
+
+
+;; ATTIC
+
+ #;(let* ((syncer-logfile (conc areapath"/logs/"dbfname"-syncer.log"))
+ (sync-cmd (if (eq? syncdir 'todisk)
+ (conc "(NBFAKE_LOG="syncer-logfile" nbfake megatest -db2db -from "tmpdb" -to "dbfullname" -period 5 -timeout 10 > /dev/null 2&>1)&")
+ (conc "(NBFAKE_LOG="syncer-logfile" nbfake megatest -db2db -from "dbfullname" -to "tmpdb" -period 5 -timeout 10 > /dev/null 2&>1)&")))
+ (synclock-file (conc dbfullname".lock"))
+ (syncer-running-file (conc dbfullname"-sync-running"))
+ (synclock-mod-time (if (file-exists? synclock-file)
+ (handle-exceptions
+ exn
+ #f
+ (file-modification-time synclock-file))
+ #f))
+ (thethread (lambda ()
+ (thread-start!
+ (make-thread
+ (lambda ()
+ (set! *sync-in-progress* #t)
+ (debug:print-info "Running "sync-cmd)
+ (if (file-exists? syncer-running-file)
+ (debug:print-info 0 *default-log-port* "Syncer still running, skipping syncer start.")
+ (system sync-cmd))
+ (set! *sync-in-progress* #f)))))))
+ (if ((if (eq? syncdir 'todisk) < >) ;; use less than for todisk, greater than for from disk
+ (file-modification-time tmpdb)
+ (file-modification-time dbfullname))
+ (debug:print 4 *default-log-port* "Skipping sync, "tmpdb" older than "dbfullname)
+ (if synclock-mod-time
+ (if (> (- (current-seconds) synclock-mod-time) 20) ;; something wrong with sync, remove file
+ (begin
+ (handle-exceptions
+ exn
+ #f
+ (begin
+ (debug:print 0 *default-log-port* "Sync lock file " synclock-file "is older than 20 seconds (" synclock-mod-time " seconds). Removing it")
+ (delete-file synclock-file)
+ )
+ )
+ (thethread))
+ (debug:print 0 *default-log-port* "Skipping sync, lockfile "synclock-file" found."))
+ (thethread))))
Index: dcommon.scm
==================================================================
--- dcommon.scm
+++ dcommon.scm
@@ -21,10 +21,11 @@
(declare (unit dcommon))
(declare (uses gutils))
(declare (uses db))
(declare (uses commonmod))
+(declare (uses configfmod))
(declare (uses rmtmod))
(use format)
(require-library iup)
(import (prefix iup iup:))
@@ -31,10 +32,11 @@
(use canvas-draw)
(import canvas-draw-iup)
(use regex typed-records matchable)
(import commonmod
+ configfmod
rmtmod
debugprint)
(include "megatest-version.scm")
(include "common_records.scm")
@@ -59,10 +61,11 @@
update-mutex
updaters
updating
uidat ;; needs to move to tabdat at some time
hide-not-hide-tabs
+ target
)
(define (dboard:commondat-make)
(make-dboard:commondat
curr-tab-num: 0
@@ -70,19 +73,41 @@
please-update: #t
update-mutex: (make-mutex)
updaters: (make-hash-table)
updating: #f
hide-not-hide-tabs: #f
+ target: ""
))
;; RADT => Matrix defstruct addition
(defstruct dboard:graph-dat
((id #f) : string)
((color #f) : vector)
((flag #t) : boolean)
((cell #f) : number)
)
+
+;; RA => returns the tabdat stored at hashkey passed in commondat-tabdats table (e.g. 0 gives summary)
+;;
+(define (dboard:common-get-tabdat commondat #!key (tab-num #f))
+ (let* ((tnum (or tab-num
+ (dboard:commondat-curr-tab-num commondat)
+ 0)) ;; tab-num value is curr-tab-num value in passed commondat
+ (ht (dboard:commondat-tabdats commondat))
+ (res (hash-table-ref/default ht tnum #f)))
+ (or res
+ (let ((new-tabdat (dboard:tabdat-make-data)))
+ (hash-table-set! ht tnum new-tabdat)
+ new-tabdat))))
+
+;; RA => sets the tabdat passed to the hashkey at commondat:tabdats hash table
+;;
+(define (dboard:common-set-tabdat! commondat tabnum tabdat)
+ (hash-table-set!
+ (dboard:commondat-tabdats commondat)
+ tabnum
+ tabdat))
;; data for runs, tests etc. was used in run summary?
;;
(defstruct dboard:runsdat
;; new system
@@ -1138,14 +1163,28 @@
#:readonly "YES"
#:font "Courier New, -12"
)))
(dboard:tabdat-command-tb-set! data tb)
tb)
+
(iup:button "Execute" #:size "50x"
#:action (lambda (obj)
- ;; (let ((cmd (conc ;; "xterm -geometry 180x20 -e \""
- (common:run-a-command (iup:attribute (dboard:tabdat-command-tb data) "VALUE")))))))
+ (let ((cmd (iup:attribute (dboard:tabdat-command-tb data) "VALUE")))
+ (if (substring-index "no-runname-specified" cmd)
+ (debug:print 0 *default-log-port* "ERROR: no runname specified")
+ (begin
+ (if (substring-index "no-target-selected" cmd)
+ (debug:print 0 *default-log-port* "ERROR: no target selected")
+ (begin
+ (if (not (substring-index "-run" cmd))
+ (debug:print 0 *default-log-port* "ERROR: No target selected")
+ (common:run-a-command (iup:attribute (dboard:tabdat-command-tb data) "VALUE"))
+ )
+ )
+ )
+ )
+ )))))))
;; ";echo Press any key to continue;bash -c 'read -n 1 -s'\" &")))
;; (system cmd)))))))
(define (dcommon:command-action-selector commondat tabdat #!key (tab-num #f))
(iup:frame
@@ -1170,11 +1209,10 @@
(let* ((default-run-name (seconds->work-week/day (current-seconds)))
(tb (iup:textbox #:expand "HORIZONTAL"
#:action (lambda (obj val txt)
(debug:catch-and-dump
(lambda ()
- ;; (print "obj: " obj " val: " val " unk: " unk)
(dboard:tabdat-run-name-set! tabdat txt) ;; (iup:attribute obj "VALUE"))
(dashboard:update-run-command tabdat))
"command-runname-selector tb action"))
#:value (or default-run-name (dboard:tabdat-run-name tabdat))))
(lb (iup:listbox #:expand "HORIZONTAL"
@@ -1196,11 +1234,10 @@
(runs-dat (vector-ref runs-for-targ 1))
(run-names (cons default-run-name
(map (lambda (x)
(db:get-value-by-header x runs-header "runname"))
runs-dat))))
- ;; (print "DEBUGINFO: run-names=" run-names)
;; (iup:attribute-set! lb "REMOVEITEM" "ALL")
(iuplistbox-fill-list lb run-names selected-item: default-run-name))))))
;; (dboard:tabdat-updater-for-runs-set! tabdat refresh-runs-list)
(dboard:commondat-add-updater commondat refresh-runs-list tab-num: tab-num)
;; (refresh-runs-list)
Index: docs/manual/Makefile
==================================================================
--- docs/manual/Makefile
+++ docs/manual/Makefile
@@ -37,10 +37,13 @@
# dos2unix megatest_manual.html
megatest_manual.pdf : megatest_manual.txt *.txt *png *.dot
a2x -a toc -f pdf megatest_manual.txt
+%.pdf : %.dot
+ dot -Tpdf $*.dot -o$*.pdf
+
server.ps : server.dot
dot -Tps server.dot > server.ps
client.ps : client.dot
dot -Tps client.dot > client.ps
Index: docs/manual/megatest_manual.pdf
==================================================================
--- docs/manual/megatest_manual.pdf
+++ docs/manual/megatest_manual.pdf
cannot compute difference between binary files
Index: docs/manual/server.dot
==================================================================
--- docs/manual/server.dot
+++ docs/manual/server.dot
@@ -12,67 +12,68 @@
// 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 .
+
digraph G {
- subgraph cluster_1 {
- node [style=filled,shape=box];
-
- check_available_queue -> remove_entries_over_10s_old;
- remove_entries_over_10s_old -> set_available [label="num_avail < 3"];
- remove_entries_over_10s_old -> exit [label="num_avail > 2"];
-
- set_available -> delay_2s;
- delay_2s -> check_place_in_queue;
-
- check_place_in_queue -> "http:transport-launch" [label="at head"];
- check_place_in_queue -> exit [label="not at head"];
-
- "client:login" -> "server:shutdown" [label="login failed"];
- "server:shutdown" -> exit;
-
- subgraph cluster_2 {
- "http:transport-launch" -> "http:transport-run";
- "http:transport-launch" -> "http:transport-keep-running";
-
- "http:transport-keep-running" -> "tests running?";
- "tests running?" -> "client:login" [label=yes];
- "tests running?" -> "server:shutdown" [label=no];
- "client:login" -> delay_5s [label="login ok"];
- delay_5s -> "http:transport-keep-running";
- }
-
- // start_server -> "server_running?";
- // "server_running?" -> set_available [label="no"];
- // "server_running?" -> delay_2s [label="yes"];
- // delay_2s -> "still_running?";
- // "still_running?" -> ping_server [label=yes];
- // "still_running?" -> set_available [label=no];
- // ping_server -> exit [label=alive];
- // ping_server -> remove_server_record [label=dead];
- // remove_server_record -> set_available;
- // set_available -> avail_delay [label="delay 3s"];
- // avail_delay -> "first_in_queue?";
- //
- // "first_in_queue?" -> set_running [label=yes];
- // set_running -> get_next_port -> handle_requests;
- // "first_in_queue?" -> "dead_entry_in_queue?" [label=no];
- // "dead_entry_in_queue?" -> "server_running?" [label=no];
- // "dead_entry_in_queue?" -> "remove_dead_entries" [label=yes];
- // remove_dead_entries -> "server_running?";
- //
- // handle_requests -> start_shutdown [label="no traffic\nno running tests"];
- // handle_requests -> shutdown_request;
- // start_shutdown -> shutdown_delay;
- // shutdown_request -> shutdown_delay;
- // shutdown_delay -> exit;
-
- label = "server:launch";
- color=brown;
- }
-
-// client_start_server -> start_server;
-// handle_requests -> read_write;
-// read_write -> handle_requests;
-}
+ label = "Server Start Sequences";
+ color=brown;
+ rankdir="TB";
+
+ subgraph cluster_1 {
+ label="Find Prime Main Server";
+
+ node [style=filled,shape=box];
+
+ START;
+ HaveServ [label="Look at .servinfo\nfiles for prime main"];
+ AskPrime [label="Ask Prime for main"];
+ PingPrime [label="Ping Prime"];
+ AskPrime [label="Ask .servinfo prime for server"];
+ StartServ [label="Launch Server Process for main.db"];
+
+ START -> HaveServ;
+ HaveServ -> PingPrime;
+ PingPrime -> AskPrime [label="Got response"];
+ PingPrime -> StartServ [label="No reponse"];
+ HaveServ -> StartServ [label="No files"];
+ StartServ -> "Delay 2s" -> START;
+ AskPrime -> DONE;
+ }
+
+ subgraph cluster_2 {
+ label="Starting non-prime server"
+ node [style=filled,shape=box];
+ StartTCPServer [label="Start tcp server"];
+ FindPrimeMain [label="Find Prime Main Server"];
+ RegisterProcessViaPrime [label="Register process via prime server"];
+
+ StartTCPServer -> FindPrimeMain -> START;
+ DONE -> RegisterProcessViaPrime -> READY;
+ }
+
+ subgraph cluster_3 {
+ label="Start Prime Main"
+ node [style=filled,shape=box];
+ StartTCPServer_prime [label="Start tcp server"];
+ GetServInfoFiles [label="Get servinfo files"];
+ CreateServInfoFile [label="Create servinfo file"];
+ RegisterProcess [label="Register process in no-sync (direct access)"];
+ ValidateServInfoFiles [label="Validate servinfo files with ping\nremove any files which do not respond to ping"];
+
+ CheckHost [label="Verify that current host matches\nexisting servinfo files host"]
+ StartTCPServer_prime -> GetServInfoFiles;
+ GetServInfoFiles -> CreateServInfoFile [label="No servinfo\nfiles"];
+ GetServInfoFiles -> ValidateServInfoFiles;
+ ValidateServInfoFiles -> CreateServInfoFile [label="No valid files"];
+ CreateServInfoFile -> GetServInfoFiles [label="servinfo file created"];
+ KeepRunning [label="READY"];
+
+ ValidateServInfoFiles -> CheckHost;
+ CheckHost -> RegisterProcess [label="Have valid\nservinfo files and same host"];
+ RegisterProcess -> KeepRunning;
+ CheckHost -> EXIT [label="Not same host"];
+ }
+}
+
Index: docs/manual/server.png
==================================================================
--- docs/manual/server.png
+++ docs/manual/server.png
cannot compute difference between binary files
Index: ezsteps.scm
==================================================================
--- ezsteps.scm
+++ ezsteps.scm
@@ -19,22 +19,24 @@
;; strftime('%m/%d/%Y %H:%M:%S','now','localtime')
(declare (unit ezsteps))
(declare (uses db))
+(declare (uses commonmod))
(declare (uses common))
+(declare (uses configfmod))
(declare (uses debugprint))
(declare (uses items))
(declare (uses runconfig))
-(declare (uses commonmod))
(declare (uses rmtmod))
(declare (uses mtargs))
(use srfi-1 posix regex srfi-69 directory-utils call-with-environment-variables posix-extras
z3 csv typed-records pathname-expand matchable)
(import commonmod
+ configfmod
debugprint
rmtmod
(prefix mtargs args:))
(include "common_records.scm")
Index: genexample.scm
==================================================================
--- genexample.scm
+++ genexample.scm
@@ -19,14 +19,19 @@
;;======================================================================
(declare (unit genexample))
(declare (uses mtargs))
(declare (uses debugprint))
+(declare (uses common))
+(declare (uses commonmod))
+(declare (uses configfmod))
(declare (uses rmtmod))
(use posix regex matchable)
(import (prefix mtargs args:)
+ commonmod
+ configfmod
rmtmod
debugprint)
(include "db_records.scm")
Index: items.scm
==================================================================
--- items.scm
+++ items.scm
@@ -21,13 +21,16 @@
;; (temperature "cool medium hot")
;; (season "summer winter fall spring")))
(declare (unit items))
(declare (uses common))
-(declare (uses debugprint))
(declare (uses commonmod))
+(declare (uses configfmod))
+(declare (uses debugprint))
+
(import commonmod
+ configfmod
debugprint)
(include "common_records.scm")
;; Puts out all combinations
Index: keys.scm
==================================================================
--- keys.scm
+++ keys.scm
@@ -23,17 +23,19 @@
(declare (unit keys))
(declare (uses common))
(declare (uses debugprint))
(declare (uses commonmod))
+(declare (uses configfmod))
(declare (uses mtargs))
(use sqlite3 srfi-1 posix regex regex-case srfi-69)
(import (prefix sqlite3 sqlite3:)
(prefix mtargs args:))
(import commonmod
+ configfmod
debugprint)
(include "key_records.scm")
(include "common_records.scm")
Index: launch.scm
==================================================================
--- launch.scm
+++ launch.scm
@@ -24,10 +24,12 @@
(declare (unit launch))
(declare (uses subrun))
(declare (uses common))
(declare (uses debugprint))
(declare (uses commonmod))
+(declare (uses processmod))
+(declare (uses configfmod))
(declare (uses configf))
(declare (uses db))
(declare (uses rmtmod))
(declare (uses ezsteps))
;; (declare (uses dbmod))
@@ -47,10 +49,12 @@
(include "key_records.scm")
(include "db_records.scm")
(include "megatest-fossil-hash.scm")
(import commonmod
+ processmod
+ configfmod
rmtmod
debugprint
;; dbmod
dbfile)
@@ -236,11 +240,10 @@
(let loop ((minutes (calc-minutes))
(cpu-load (alist-ref 'adj-core-load (common:get-normalized-cpu-load #f)))
(disk-free (get-df (current-directory)))
(last-sync (current-seconds)))
- ;; (common:telemetry-log "zombie" (conc "launch:monitor-job - top of loop encountered at "(current-seconds)" with last-sync="last-sync))
(let* ((over-time (> (current-seconds) (+ last-sync update-period)))
(new-cpu-load (let* ((load (alist-ref 'adj-core-load (common:get-normalized-cpu-load #f)))
(delta (abs (- load cpu-load))))
(if (> delta 0.1) ;; don't bother updating with small changes
load
@@ -256,15 +259,16 @@
(do-sync (or new-cpu-load new-disk-free over-time))
(test-info (rmt:get-test-state-status-by-id run-id test-id))
(state (car test-info));; (db:test-get-state test-info))
(status (cdr test-info));; (db:test-get-status test-info))
+ (killreq (equal? state "KILLREQ"))
(kill-reason "no kill reason specified")
(kill-job? #f))
;; (common:telemetry-log "zombie" (conc "launch:monitor-job - decision time encountered at "(current-seconds)" with last-sync="last-sync" do-sync="do-sync" over-time="over-time" update-period="update-period))
(cond
- ((test-get-kill-request run-id test-id)
+ (killreq
(set! kill-reason "KILLING TEST since received kill request (KILLREQ)")
(set! kill-job? #t))
((and runtlim (> (- (current-seconds) start-seconds) runtlim))
(set! kill-reason (conc "KILLING TEST DUE TO TIME LIMIT EXCEEDED! Runtime=" (- (current-seconds) start-seconds) " seconds, limit=" runtlim))
(set! kill-job? #t))
@@ -276,16 +280,11 @@
(debug:print 4 *default-log-port* "cpu: " new-cpu-load " disk: " new-disk-free " last-sync: " last-sync " do-sync: " do-sync)
(if (common:low-noise-print 600 "run zombie") ;; every five minutes is plenty
(launch:handle-zombie-tests run-id))
(when do-sync
- ;;(with-output-to-file (conc (getenv "MT_TEST_RUN_DIR") "/last-loadinfo.log" #:append)
- ;; (lambda () (pp (list (current-seconds) new-cpu-load new-disk-free (calc-minutes)))))
- ;; (common:telemetry-log "zombie" (conc "launch:monitor-job - dosync started at "(current-seconds)))
- (tests:update-central-meta-info run-id test-id new-cpu-load new-disk-free (calc-minutes) #f #f)
- ;; (common:telemetry-log "zombie" (conc "launch:monitor-job - dosync finished at "(current-seconds)))
- )
+ (tests:update-central-meta-info run-id test-id new-cpu-load new-disk-free (calc-minutes) #f #f))
(if kill-job?
(begin
(debug:print-info 0 *default-log-port* "proceeding to kill test: "kill-reason)
(mutex-lock! m)
@@ -331,20 +330,64 @@
)))
(mutex-unlock! m)
;; no point in sticking around. Exit now. But run end of run before exiting?
(launch:end-of-run-check run-id)
(exit)))
- (if (hash-table-ref/default misc-flags 'keep-going #f)
+ (if (hash-table-ref/default misc-flags 'keep-going #f) ;; keep originals for cpu-load and disk-free unless they change more than the allowed delta
(begin
- (thread-sleep! 3) ;; (+ 3 (random 6))) ;; add some jitter to the call home time to spread out the db accesses
- (if (hash-table-ref/default misc-flags 'keep-going #f) ;; keep originals for cpu-load and disk-free unless they change more than the allowed delta
- (loop (calc-minutes)
- (or new-cpu-load cpu-load)
- (or new-disk-free disk-free)
- (if do-sync (current-seconds) last-sync)))))))
- (tests:update-central-meta-info run-id test-id (get-cpu-load) (get-df (current-directory))(calc-minutes) #f #f))) ;; NOTE: Checking twice for keep-going is intentional
-
+ (thread-sleep! 6) ;; was 3
+ (loop (calc-minutes)
+ (or new-cpu-load cpu-load)
+ (or new-disk-free disk-free)
+ (if do-sync (current-seconds) last-sync))))))
+ (tests:update-central-meta-info run-id test-id (commonmod:get-cpu-load) (get-df (current-directory))(calc-minutes) #f #f))) ;; NOTE: Checking twice for keep-going is intentional
+
+
+;; read testconfig and create .logpro and script files
+;; - use #f for tconfigreg to re-read the testconfigs from disk
+;;
+(define (launch:extract-scripts-logpro test-dir test-name item-path tconfigreg-in)
+ (let* ((tconfigreg (or tconfigreg-in
+ (tests:get-all)))
+ (tconfig-fname (conc test-dir "/.testconfig"))
+ (tconfig-tmpfile (conc tconfig-fname ".tmp"))
+ (tconfig (tests:get-testconfig test-name item-path tconfigreg #t force-create: #t)) ;; 'return-procs)))
+ (scripts (configf:get-section tconfig "scripts"))
+ (logpros (configf:get-section tconfig "logpro")))
+ ;; create .testconfig file
+ (configf:write-alist tconfig tconfig-tmpfile)
+ (file-move tconfig-tmpfile tconfig-fname #t)
+ (delete-file* ".final-status")
+
+ ;; extract scripts from testconfig and write them to files in test run dir
+ (for-each
+ (lambda (scriptdat)
+ (match scriptdat
+ ((name content)
+ (debug:print-info 2 *default-log-port* "Creating script "(current-directory)"/"name)
+ (with-output-to-file name
+ (lambda ()
+ (print content)))
+ (change-file-mode name (bitwise-ior perm/irwxg perm/irwxu)))
+ (else
+ (debug:print-info 0 "Invalid script definiton found in [scripts] section of testconfig. \"" scriptdat "\""))))
+ scripts)
+
+ ;; extract logpro from testconfig and write them to files in test run dir
+ (for-each
+ (lambda (logprodat)
+ (match logprodat
+ ((name content)
+ (debug:print-info 2 *default-log-port* "Creating logpro file "(current-directory)"/"name".logpro")
+ (with-output-to-file (conc name".logpro")
+ (lambda ()
+ (print content)
+ ;; (change-file-mode name (bitwise-ior perm/irwxg perm/irwxu))
+ )))
+ (else
+ (debug:print-info 0 "Invalid logpro definiton found in [logpro] section of testconfig. \"" logprodat "\""))))
+ logpros)))
(define (launch:execute encoded-cmd)
(let* ((cmdinfo (common:read-encoded-string encoded-cmd))
(tconfigreg #f))
(setenv "MT_CMDINFO" encoded-cmd)
@@ -616,12 +659,11 @@
(if mt-bindir-path (setenv "PATH" (conc tmppath":"mt-bindir-path))))
;;(bb-check-path msg: "launch:execute post block 4")
;; (change-directory top-path)
;; Can setup as client for server mode now
;; (client:setup)
-
-
+
;; environment overrides are done *before* the remaining critical envars.
(alist->env-vars env-ovrd)
;;(bb-check-path msg: "launch:execute post block 41")
(runs:set-megatest-env-vars run-id inkeys: keys inkeyvals: keyvals)
;;(bb-check-path msg: "launch:execute post block 42")
@@ -647,37 +689,39 @@
(set! fullrunscript "xterm")
(if (and fullrunscript
(common:file-exists? fullrunscript)
(not (file-execute-access? fullrunscript)))
(system (conc "chmod ug+x " fullrunscript))))
-
- ;; We are about to actually kick off the test
- ;; so this is a good place to remove the records for
- ;; any previous runs
- ;; (db:test-remove-steps db run-id testname itemdat)
- ;; now is also a good time to write the .testconfig file
- (let* ((tconfig-fname (conc work-area "/.testconfig"))
- (tconfig-tmpfile (conc tconfig-fname ".tmp"))
- (tconfig (tests:get-testconfig test-name item-path tconfigreg #t force-create: #t)) ;; 'return-procs)))
- (scripts (configf:get-section tconfig "scripts")))
- ;; create .testconfig file
- (configf:write-alist tconfig tconfig-tmpfile)
- (file-move tconfig-tmpfile tconfig-fname #t)
- (delete-file* ".final-status")
-
- ;; extract scripts from testconfig and write them to files in test run dir
- (for-each
- (lambda (scriptdat)
- (match scriptdat
- ((name content)
- (with-output-to-file name
- (lambda ()
- (print content)
- (change-file-mode name (bitwise-ior perm/irwxg perm/irwxu)))))
- (else
- (debug:print-info 0 "Invalid script definiton found in [scripts] section of testconfig. \"" scriptdat "\""))))
- scripts))
+ (launch:extract-scripts-logpro work-area test-name item-path tconfigreg)
+
+;;;;; ;; We are about to actually kick off the test
+;;;;; ;; so this is a good place to remove the records for
+;;;;; ;; any previous runs
+;;;;; ;; (db:test-remove-steps db run-id testname itemdat)
+;;;;; ;; now is also a good time to write the .testconfig file
+;;;;; (let* ((tconfig-fname (conc work-area "/.testconfig"))
+;;;;; (tconfig-tmpfile (conc tconfig-fname ".tmp"))
+;;;;; (tconfig (tests:get-testconfig test-name item-path tconfigreg #t force-create: #t)) ;; 'return-procs)))
+;;;;; (scripts (configf:get-section tconfig "scripts"))
+;;;;; (precmd (configf:lookup tconfig )
+;;;;; ;; create .testconfig file
+;;;;; (configf:write-alist tconfig tconfig-tmpfile)
+;;;;; (file-move tconfig-tmpfile tconfig-fname #t)
+;;;;; (delete-file* ".final-status")
+;;;;;
+;;;;; ;; extract scripts from testconfig and write them to files in test run dir
+;;;;; (for-each
+;;;;; (lambda (scriptdat)
+;;;;; (match scriptdat
+;;;;; ((name content)
+;;;;; (with-output-to-file name
+;;;;; (lambda ()
+;;;;; (print content)
+;;;;; (change-file-mode name (bitwise-ior perm/irwxg perm/irwxu)))))
+;;;;; (else
+;;;;; (debug:print-info 0 "Invalid script definiton found in [scripts] section of testconfig. \"" scriptdat "\""))))
+;;;;; scripts))
;;
(let* ((m (make-mutex))
(kill-job? #f)
(exit-info (make-launch:einf pid: #t exit-status: #t exit-code: #t rollup-status: 0)) ;; pid exit-status exit-code (i.e. process was successfully run) rollup-status
@@ -694,11 +738,15 @@
(th2 (make-thread runit "run job"))
(tconfig (tests:get-testconfig test-name item-path tconfigreg #t))
(propagate-exit-code (configf:lookup *configdat* "setup" "propagate-exit-code"))
(propagate-status-list '("FAIL" "KILLED" "ABORT" "DEAD" "CHECK" "SKIP" "WAIVED"))
(test-status "not set")
- )
+ (precmd (configf:lookup tconfig "setup" "precmd"))
+ (postcmd (configf:lookup tconfig "setup" "postcmd")))
+ ;; first, if set, run the precmd
+ (if precmd ;; (file-exists? precmd)(file-execute-access? precmd))
+ (system precmd)) ;; up to test author to put nbfake if desired.
(set! job-thread th2)
(thread-start! th1)
(thread-start! th2)
(thread-join! th2)
(debug:print-info 0 *default-log-port* "Megatest execute of test " test-name ", item path " item-path " complete. Notifying the db ...")
@@ -762,10 +810,13 @@
(set! test-status (db:test-get-status (rmt:get-testinfo-state-status run-id test-id)))
;; If the propagate-exit-code option has been set in the megatest config, and the test status matches the list, set the exit code to 1.
+ (if postcmd
+ (system postcmd))
+
(if (and propagate-exit-code (string=? propagate-exit-code "yes") (member test-status propagate-status-list))
(begin
(debug:print 1 *default-log-port* "Setting exit status to 1 because of test status of " test-status)
(set! *globalexitstatus* 1)
)
Index: megatest-version.scm
==================================================================
--- megatest-version.scm
+++ megatest-version.scm
@@ -18,6 +18,6 @@
;; Always use two or four digit decimal
;; 1.01, 1.02...1.10,1.11,1.1101 ... 1.99,2.00..
;; (declare (unit megatest-version))
-(define megatest-version 1.8017)
+(define megatest-version 1.8028)
Index: megatest.scm
==================================================================
--- megatest.scm
+++ megatest.scm
@@ -29,10 +29,14 @@
(declare (uses mtargs.import))
(declare (uses debugprint))
(declare (uses debugprint.import))
(declare (uses commonmod))
(declare (uses commonmod.import))
+(declare (uses processmod))
+(declare (uses processmod.import))
+(declare (uses configfmod))
+(declare (uses configfmod.import))
(declare (uses runs))
(declare (uses launch))
(declare (uses server))
(declare (uses tests))
@@ -55,10 +59,12 @@
(declare (uses dbmod.import))
(declare (uses portlogger))
(declare (uses portlogger.import))
(declare (uses tcp-transportmod))
(declare (uses tcp-transportmod.import))
+(declare (uses apimod))
+(declare (uses apimod.import))
(declare (uses rmtmod))
(declare (uses rmtmod.import))
;; (declare (uses debugprint))
;; (declare (uses debugprint.import))
@@ -68,14 +74,17 @@
(import (prefix mtargs args:)
debugprint
dbmod
commonmod
+ processmod
+ configfmod
dbfile
portlogger
tcp-transportmod
rmtmod
+ apimod
)
(define *db* #f) ;; this is only for the repl, do not use in general!!!!
(include "common_records.scm")
@@ -257,11 +266,13 @@
-debug N|N,M,O... : enable debug 0-N or N and M and O ...
-debug-noprop N|M,M,O...: enable debug but do not propagate to subprocesses via MT_DEBUG
-config fname : override the megatest.config file with fname
-append-config fname : append fname to the megatest.config file
-import-sexpr fname : import a sexpr file (use -list-runs % -dumpmode sexpr to create)
-
+ -remove-dbs all : remove Megatest DBs before importing sexpr. (Use only with -import-sexpr)
+ -regen-testfiles : regenerate scripts and logpro files from testconfig, run in test context
+
Utilities
-env2file fname : write the environment to fname.csh and fname.sh
-envcap a : save current variables labeled as context 'a' in file envdat.db
-envdelta a-b : output enviroment delta from context a to context b to -o fname
set the output mode with -dumpmode csh, bash or ini
@@ -378,10 +389,11 @@
"-envcap"
"-envdelta"
"-setvars"
"-set-state-status"
"-import-sexpr"
+ "-remove-dbs" ;; to be used only with -import-sexpr to remove megatest dbs first.
"-period" ;; sync period in seconds
"-timeout" ;; exit sync if timeout in seconds exceeded since last change
;; move runs stuff here
"-remove-keep"
@@ -466,10 +478,11 @@
"-local" ;; run some commands using local db access
"-generate-html"
"-generate-html-structure"
"-list-run-time"
"-list-test-time"
+ "-regen-testfiles"
;; misc queries
"-list-disks"
"-list-targets"
"-list-db-targets"
@@ -968,12 +981,14 @@
(tl (launch:setup))
(keys (keys:config-get-fields *configdat*)))
(case (rmt:transport-mode)
((tcp)
(let* ((timeout (server:expiration-timeout)))
- (debug:print 0 *default-log-port* "INFO: Running using tcp method with server timeout of "timeout)
+ (debug:print 0 *default-log-port* "INFO: megatest -server starting on " (get-host-name) " for " dbfname " using tcp method with timeout of "timeout)
(tt-server-timeout-param timeout)
+ (api:queue-processor)
+ (thread-start! (make-thread api:print-db-stats "print-db-stats"))
(if dbfname
(tt:start-server tl #f dbfname api:tcp-dispatch-request-make-handler keys)
(begin
(debug:print 0 *default-log-port* "ERROR: transport mode is tcp - -db is required.")
(exit 1)))))
@@ -1044,16 +1059,16 @@
(if (args:get-arg "-kill-servers")
-
+
(let* ((tl (launch:setup)) ;; need this to initialize *toppath*
(servdir (tt:get-servinfo-dir *toppath*))
(servfiles (glob (conc servdir "/*:*.db")))
(fmtstr "~10a~22a~10a~25a~25a~8a\n")
- (dbfiles (append (glob (conc *toppath* "/.mtdb/main.db")) (glob (conc *toppath* "/.mtdb/?.db"))(glob (conc *toppath* "/.mtdb/??.db"))))
+ (dbfiles (if (file-exists? (conc *toppath* "/.mtdb/main.db")) (append (glob (conc *toppath* "/.mtdb/main.db")) (glob (conc *toppath* "/.mtdb/?.db"))(glob (conc *toppath* "/.mtdb/??.db"))) '()))
(ttdat (make-tt areapath: *toppath*))
)
(format #t fmtstr "DB" "host:port" "PID" "age" "last mod" "state")
(for-each
(lambda (dbfile)
@@ -1091,10 +1106,14 @@
sfiles
)
)
)
dbfiles
+ )
+ ;; remove this db, because otherwise metadata contains records for old servers, and this causes a problem with db:no-sync-get-lock-with-id.
+ (if (file-exists? (conc *toppath* "/.mtdb/no-sync.db"))
+ (delete-file (conc *toppath* "/.mtdb/no-sync.db"))
)
(set! *didsomething* #t)
(exit)
)
)
@@ -2115,10 +2134,25 @@
(paths (tests:test-get-paths-matching keys target (args:get-arg "-test-files"))))
(for-each (lambda (path)
(print path))
paths))))))
+;;======================================================================
+;; Utils for test areas
+;;======================================================================
+
+(if (args:get-arg "-regen-testfiles")
+ (if (getenv "MT_TEST_RUN_DIR")
+ (begin
+ (launch:setup)
+ (change-directory (getenv "MT_TEST_RUN_DIR"))
+ (let* ((testname (getenv "MT_TEST_NAME"))
+ (itempath (getenv "MT_ITEMPATH")))
+ (launch:extract-scripts-logpro (getenv "MT_TEST_RUN_DIR") testname itempath #f))
+ (set! *didsomething* #t))
+ (debug:print 0 *default-log-port* "ERROR: Must run -regen-testfiles in a test environment (i.e. test xterm from dashboard)")))
+
;;======================================================================
;; Archive tests
;;======================================================================
;; Archive tests matching target, runname, and testpatt
(if (equal? (args:get-arg "-archive") "replicate-db")
@@ -2132,13 +2166,13 @@
(exit 1)))
(if (common:file-exists? (conc *toppath* "/megatest.db"))
(begin
(debug:print-info 1 *default-log-port* "File " (conc *toppath* "/megatest.db") " already exists. Please remove it before trying to replicate db")
(exit 1)))
- (if (and (common:get-db-tmp-area) (> (length (directory (common:get-db-tmp-area) #f)) 0))
+ (if (and (common:make-tmpdir-name *toppath* "") (> (length (directory (common:make-tmpdir-name *toppath* "") #f)) 0))
(begin
- (debug:print-info 1 *default-log-port* (common:get-db-tmp-area) " not empty. Please remove it before trying to replicate db")
+ (debug:print-info 1 *default-log-port* (common:make-tmpdir-name *toppath* "") " not empty. Please remove it before trying to replicate db")
(exit 1)))
;; check if timestamp
(let* ((source (args:get-arg "-source"))
(src (if (not (equal? (substring source 0 1) "/"))
(conc (current-directory) "/" source)
@@ -2429,11 +2463,11 @@
(begin
(debug:print 0 *default-log-port* "Failed to setup, exiting")
(exit 1)))
;; keep this one local
;; (open-run-close patch-db #f)
- (let ((dbstructs (db:setup #f)))
+ (let ((dbstructs (db:setup)))
(common:cleanup-db dbstructs full: #t))
(set! *didsomething* #t)))
(if (args:get-arg "-cleanup-db")
(begin
@@ -2445,11 +2479,11 @@
;; (if (not (server:choose-server *toppath* 'home?))
;; (begin
;; (debug:print 0 *default-log-port* "Servers are not running on this host or no servers alive. Cannot run cleanup-db")
;; (exit 1)))
- (let ((dbstructs (db:setup #f)))
+ (let ((dbstructs (db:setup)))
(common:cleanup-db dbstructs))
(set! *didsomething* #t)))
(if (args:get-arg "-mark-incompletes")
(begin
@@ -2506,11 +2540,11 @@
(let* ((toppath (launch:setup))
(dbstructs (if (and toppath
;; NOTE: server:choose-server is starting a server
;; either add equivalent for tcp mode or ????
#;(server:choose-server toppath 'home?))
- (db:setup #t)
+ (db:setup)
#f))) ;; make-dbr:dbstruct path: toppath local: (args:get-arg "-local")) #f)))
(if *toppath*
(cond
((getenv "MT_RUNSCRIPT")
;; How to run megatest scripts
@@ -2597,27 +2631,44 @@
(if (args:get-arg "-import-megatest.db")
(begin
(launch:setup)
(db:multi-db-sync
- (db:setup #f)
+ (db:setup)
'killservers
'dejunk
'adj-testids
'old2new
)
(set! *didsomething* #t)))
(if (args:get-arg "-import-sexpr")
- (begin
- (launch:setup)
- (rmt:import-sexpr (args:get-arg "-import-sexpr"))
- (set! *didsomething* #t)))
+ (let*(
+ (toppath (launch:setup))
+ (tmppath (common:make-tmpdir-name toppath "")))
+ (if (file-exists? (conc toppath "/.mtdb"))
+ (if (args:get-arg "-remove-dbs")
+ (let* ((dbfiles (conc toppath "/.mtdb/* " tmppath "/*")))
+ (debug:print 0 *default-log-port* "Removing db files: " dbfiles)
+ (system (conc "rm -rvf " dbfiles))
+ )
+ (begin
+ (debug:print 0 *default-log-port* "ERROR: Cannot import sexpr with an existing DB present.")
+ (debug:print 0 *default-log-port* "Add '-remove-dbs all' to remove the current Megatest DBs.")
+ (set! *didsomething* #t)
+ (exit)
+ )
+ )
+ (debug:print 0 *default-log-port* "Did not find " (conc toppath "/.mtdb"))
+ )
+ (db:setup)
+ (rmt:import-sexpr (args:get-arg "-import-sexpr"))
+ (set! *didsomething* #t)))
(if (args:get-arg "-sync-to-megatest.db")
(let* ((duh (launch:setup))
- (dbstruct (db:setup #t))
+ (dbstruct (db:setup))
(tmpdbpth (dbr:dbstruct-tmppath dbstruct))
(lockfile (conc tmpdbpth ".lock"))
(locked (common:simple-file-lock lockfile))
(res (if locked
(db:multi-db-sync
@@ -2633,10 +2684,11 @@
(if (args:get-arg "-sync-to")
(let ((toppath (launch:setup)))
(tasks:sync-to-postgres *configdat* (args:get-arg "-sync-to"))
(set! *didsomething* #t)))
+
;; use with -from and -to
;;
(if (args:get-arg "-db2db")
(let* ((duh (launch:setup))
@@ -2650,18 +2702,19 @@
(sync-timeout (if sync-timeout-in (string->number sync-timeout-in) #f))
(lockfile (conc dest-db".sync-lock"))
(keys (db:get-keys #f))
(thesync (lambda (last-update)
(debug:print-info 0 *default-log-port* "Attempting to sync data from "src-db" to "dest-db"...")
+ (debug:print-info 0 *default-log-port* "PID = " (current-process-id))
(if (not (file-exists? dest-db))
(begin
(debug:print 0 *default-log-port* "Using copy to create "dest-db" from "src-db)
(file-copy src-db dest-db)
1)
(let ((res (dbmod:db-to-db-sync src-db dest-db last-update (dbfile:db-init-proc) keys)))
(if res
- (debug:print-info 0 *default-log-port* "Synced " res " records from "src-db" to "dest-db)
+ (debug:print-info 2 *default-log-port* "Synced " res " records from "src-db" to "dest-db)
(debug:print-info 0 *default-log-port* "No sync due to permissions or other issue."))
res))))
(start-time (current-seconds))
(synclock-mod-time (if (file-exists? lockfile)
(handle-exceptions
@@ -2673,11 +2726,17 @@
)
(if (and src-db dest-db)
(if (file-exists? src-db)
(if (and (file-exists? lockfile) (< age 20))
(debug:print 0 *default-log-port* "Lock "lockfile" exists, skipping sync...")
- (begin
+ (begin
+ (if (file-exists? lockfile)
+ (begin
+ (debug:print 0 *default-log-port* "Deleting old lock file " lockfile)
+ (delete-file lockfile)
+ )
+ )
(dbfile:with-simple-file-lock
lockfile
(lambda ()
(let loop ((last-changed (current-seconds))
(last-update 0))
@@ -2694,11 +2753,11 @@
(> sync-timeout (- now-time last-changed)))
(begin
(if sync-period (thread-sleep! sync-period))
(loop (if (> changes 0) now-time last-changed) now-time))))))))
(debug:print 0 *default-log-port* "Releasing lock file " lockfile)
- )
+ )
)
(debug:print 0 *default-log-port* "No sync due to unreadble or non-existant source file"src-db))
(debug:print 0 *default-log-port* "Usage for -db2db; -to and -from must be specified"))
(set! *didsomething* #t)))
Index: mt.scm
==================================================================
--- mt.scm
+++ mt.scm
@@ -15,26 +15,32 @@
;; You should have received a copy of the GNU General Public License
;; along with Megatest. If not, see .
;;
-(use sqlite3 srfi-1 posix regex regex-case srfi-69 dot-locking (srfi 18) posix-extras directory-utils call-with-environment-variables)
+(use sqlite3 srfi-1 posix regex regex-case srfi-69 dot-locking (srfi 18) posix-extras directory-utils
+ call-with-environment-variables)
+
(import (prefix sqlite3 sqlite3:))
(declare (unit mt))
(declare (uses debugprint))
(declare (uses db))
(declare (uses common))
+(declare (uses commonmod))
+(declare (uses configfmod))
(declare (uses items))
(declare (uses runconfig))
(declare (uses tests))
(declare (uses server))
(declare (uses runs))
(declare (uses rmt))
(declare (uses rmtmod))
(import debugprint
+ commonmod
+ configfmod
rmtmod)
(include "common_records.scm")
(include "key_records.scm")
(include "db_records.scm")
Index: mtexec.scm
==================================================================
--- mtexec.scm
+++ mtexec.scm
@@ -30,11 +30,14 @@
;; (declare (uses common))
(declare (uses mtargs))
(declare (uses configf))
;; (declare (uses rmt))
(declare (uses commonmod))
+(declare (uses configfmod))
+
(import commonmod
+ configfmod
(prefix mtargs args:))
;; (use ducttape-lib)
(include "megatest-version.scm")
(include "megatest-fossil-hash.scm")
Index: mtut.scm
==================================================================
--- mtut.scm
+++ mtut.scm
@@ -19,17 +19,17 @@
(declare (uses common))
(declare (uses mtargs))
(declare (uses mtargs.import))
(declare (uses debugprint))
(declare (uses debugprint.import))
+(declare (uses configfmod))
+(declare (uses configfmod.import))
(declare (uses configf))
;; (declare (uses rmt))
(declare (uses commonmod))
(declare (uses commonmod.import))
-(import debugprint)
- ; (include "common.scm")
(include "megatest-version.scm")
;; fake out readline usage of toplevel-command
(define (toplevel-command . a) #f)
@@ -37,11 +37,13 @@
srfi-19 srfi-18 extras format pkts regex regex-case
(prefix dbi dbi:)
(prefix sqlite3 sqlite3:)
nanomsg)
-(import commonmod
+(import debugprint
+ commonmod
+ configfmod
(prefix mtargs args:))
(use ducttape-lib)
(include "megatest-fossil-hash.scm")
Index: portlogger.scm
==================================================================
--- portlogger.scm
+++ portlogger.scm
@@ -23,15 +23,47 @@
(declare (uses dbmod))
(module portlogger
*
-(import scheme chicken data-structures)
-(import srfi-1 posix srfi-69 hostinfo dot-locking z3
- (srfi 18) extras s11n)
+(import scheme)
+
+(cond-expand
+ (chicken-4
+ (import chicken data-structures)
+ (import posix
+ ;; hostinfo
+ ;; dot-locking
+ extras
+ )
+
+ (import (prefix sqlite3 sqlite3:))
+ (import debugprint dbmod)
+ )
+ (chicken-5
+ (import chicken.base
+ chicken.condition
+ chicken.file
+ chicken.pathname
+ chicken.process-context.posix
+ chicken.process
+ chicken.sort
+ chicken.string
+ chicken.time
+ chicken.random
+
+ system-information
+ )
+ (define file-write-access? file-writable?)
+ (define random pseudo-random-integer)
+ ))
+
+(import srfi-1 srfi-69 z3
+ (srfi 18) s11n)
(import (prefix sqlite3 sqlite3:))
(import debugprint dbmod)
+
;; lsof -i
(define (portlogger:open-db fname)
(let* ((avail (tasks:wait-on-journal fname 5 remove: #t)) ;; wait up to about 10 seconds for the journal to go away
(exists (file-exists? fname))
Index: process.scm
==================================================================
--- process.scm
+++ process.scm
@@ -23,216 +23,10 @@
;;======================================================================
(use regex directory-utils)
(declare (unit process))
(declare (uses debugprint))
-
-(import debugprint)
-
-(define (process:conservative-read port)
- (let loop ((res ""))
- (if (not (eof-object? (peek-char port)))
- (loop (conc res (read-char port)))
- res)))
-
-(define (process:cmd-run-with-stderr->list cmd . params)
- ;; (print "Called with cmd=" cmd ", proc=" proc ", params=" params)
-;; (handle-exceptions
-;; exn
-;; (begin
-;; (print "ERROR: Failed to run command: " cmd " " (string-intersperse params " "))
-;; (print " " ((condition-property-accessor 'exn 'message) exn))
-;; #f)
- (let-values (((fh fho pid fhe) (if (null? params)
- (process* cmd)
- (process* cmd params))))
- (let loop ((curr (read-line fh))
- (result '()))
- (let ((errstr (process:conservative-read fhe)))
- (if (not (string=? errstr ""))
- (set! result (append result (list errstr)))))
- (if (not (eof-object? curr))
- (loop (read-line fh)
- (append result (list curr)))
- (begin
- (close-input-port fh)
- (close-input-port fhe)
- (close-output-port fho)
- result))))) ;; )
-
-(define (process:cmd-run-with-stderr-and-exitcode->list cmd . params)
- ;; (print "Called with cmd=" cmd ", proc=" proc ", params=" params)
-;; (handle-exceptions
-;; exn
-;; (begin
-;; (print "ERROR: Failed to run command: " cmd " " (string-intersperse params " "))
-;; (print " " ((condition-property-accessor 'exn 'message) exn))
-;; #f)
- (let-values (((fh fho pid fhe) (if (null? params)
- (process* cmd)
- (process* cmd params))))
- (let loop ((curr (read-line fh))
- (result '()))
- (let ((errstr (process:conservative-read fhe)))
- (if (not (string=? errstr ""))
- (set! result (append result (list errstr)))))
- (if (not (eof-object? curr))
- (loop (read-line fh)
- (append result (list curr)))
- (begin
- (let-values (((anotherpid normalexit? exitstatus) (process-wait pid)))
- (close-input-port fh)
- (close-input-port fhe)
- (close-output-port fho)
- (list result (if normalexit? exitstatus -1))))))))
-
-(define (process:cmd-run-proc-each-line cmd proc . params)
- ;; (print "Called with cmd=" cmd ", proc=" proc ", params=" params)
- (handle-exceptions
- exn
- (begin
- (debug:print 0 *default-log-port* "ERROR: Failed to run command: " cmd " " (string-intersperse params " "))
- (debug:print 0 *default-log-port* " message: " ((condition-property-accessor 'exn 'message) exn))
- (debug:print 5 *default-log-port* "exn=" (condition->list exn))
- #f)
- (let-values (((fh fho pid) (if (null? params)
- (process cmd)
- (process cmd params))))
- (let loop ((curr (read-line fh))
- (result '()))
- (if (not (eof-object? curr))
- (loop (read-line fh)
- (append result (list (proc curr))))
- (begin
- (close-input-port fh)
- ;;(close-input-port fhe)
- (close-output-port fho)
- result))))))
-
-(define (process:cmd-run-proc-each-line-alt cmd proc)
- (let* ((fh (open-input-pipe cmd))
- (res (port-proc->list fh proc))
- (status (close-input-pipe fh)))
- (if (eq? status 0) res #f)))
-
-(define (process:cmd-run->list cmd #!key (delta-env-alist-or-hash-table '()))
- (common:with-env-vars
- delta-env-alist-or-hash-table
- (lambda ()
- (let* ((fh (open-input-pipe cmd))
- (res (port->list fh))
- (status (close-input-pipe fh)))
- (list res status)))))
-
-(define (port->list fh)
- (if (eof-object? fh) #f
- (let loop ((curr (read-line fh))
- (result '()))
- (if (not (eof-object? curr))
- (loop (read-line fh)
- (append result (list curr)))
- result))))
-
-(define (port-proc->list fh proc)
- (if (eof-object? fh) #f
- (let loop ((curr (proc (read-line fh)))
- (result '()))
- (if (not (eof-object? curr))
- (loop (let ((l (read-line fh)))
- (if (eof-object? l) l (proc l)))
- (append result (list curr)))
- result))))
-
-;; here is an example line where the shell is sh or bash
-;; "find / -print 2&>1 > findall.log"
-(define (run-n-wait cmdline #!key (params #f)(print-cmd #f)(run-dir #f))
- (if print-cmd
- (debug:print 0 *default-log-port*
- (if (string? print-cmd)
- print-cmd
- "")
- (if run-dir (conc "Run in " run-dir ";") "")
- cmdline
- (if params
- (conc " " (string-intersperse params " "))
- "")))
- (if (and run-dir
- (directory-exists? run-dir))
- (push-directory run-dir))
- (let ((pid (if params
- (process-run cmdline params)
- (process-run cmdline))))
- (let loop ((i 0))
- (let-values (((pid-val exit-status exit-code) (process-wait pid #t)))
- (if (eq? pid-val 0)
- (begin
- (thread-sleep! 2)
- (loop (+ i 1)))
- (begin
- (if (and run-dir
- (directory-exists? run-dir))
- (pop-directory))
- (values pid-val exit-status exit-code)))))))
-
-;;======================================================================
-;; MISC PROCESS RELATED STUFF
-;;======================================================================
-
-(define (process:children proc)
- (with-input-from-pipe
- (conc "ps h --ppid " (current-process-id) " -o pid")
- (lambda ()
- (let loop ((inl (read-line))
- (res '()))
- (if (eof-object? inl)
- (reverse res)
- (let ((pid (string->number inl)))
- (if proc (proc pid))
- (loop (read-line) (cons pid res))))))))
-
-(define (process:alive? pid)
- (handle-exceptions
- exn
- ;; possibly pid is a process not a child, look in /proc to see if it is running still
- (common:file-exists? (conc "/proc/" pid))
- (let-values (((rpid exit-type exit-signal)(process-wait pid #t)))
- (and (number? rpid)
- (equal? rpid pid)))))
-
-(define (process:alive-on-host? host pid)
- (let ((cmd (conc "ssh " host " ps -o pid= -p " pid)))
- (common:generic-ssh
- cmd
- ;;
- ;; handle-exceptions
- ;; exn
- ;; (begin
- ;; (debug:print 0 *default-log-port* "failed to identify if process " pid ", on host " host " is alive. exn=" exn)
- ;; #f) ;; anything goes wrong - assume the process in NOT running.
- ;; (with-input-from-pipe
- ;; cmd
- (lambda ()
- (let loop ((inl (read-line)))
- (if (eof-object? inl)
- #f
- (let* ((clean-str (string-substitute "^[^\\d]*([0-9]+)[^\\d]*$" "\\1" inl))
- (innum (string->number clean-str)))
- (and innum
- (eq? pid innum))))))
- #f
- (lambda ()
- (debug:print 0 *default-log-port* "failed to identify if process "
- pid", on host "host" is alive. exn="exn)))))
-
-
-(define (process:get-sub-pids pid)
- (with-input-from-pipe
- (conc "pstree -A -p " pid) ;; | tr 'a-z\\-+`()\\.' ' ' " pid)
- (lambda ()
- (let loop ((inl (read-line))
- (res '()))
- (if (eof-object? inl)
- (reverse res)
- (let ((nums (map string->number
- (string-split-fields "\\d+" inl))))
- (loop (read-line)
- (append res nums))))))))
+(declare (uses processmod))
+
+(import debugprint
+ processmod)
+
ADDED processmod.scm
Index: processmod.scm
==================================================================
--- /dev/null
+++ processmod.scm
@@ -0,0 +1,307 @@
+;;======================================================================
+;; Copyright 2017, Matthew Welland.
+;;
+;; This file is part of Megatest.
+;;
+;; Megatest is free software: you can redistribute it and/or modify
+;; it under the terms of the GNU General Public License as published by
+;; the Free Software Foundation, either version 3 of the License, or
+;; (at your option) any later version.
+;;
+;; Megatest is distributed in the hope that it will be useful,
+;; but WITHOUT ANY WARRANTY; without even the implied warranty of
+;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
+;; GNU General Public License for more details.
+;;
+;; You should have received a copy of the GNU General Public License
+;; along with Megatest. If not, see .
+
+;;======================================================================
+
+(declare (unit processmod))
+(declare (uses debugprint))
+(declare (uses commonmod))
+
+(use srfi-69)
+
+(module processmod
+ *
+
+(import scheme)
+(cond-expand
+ (chicken-4
+
+ (import chicken
+ ports
+
+ (prefix sqlite3 sqlite3:)
+ data-structures
+ directory-utils
+ extras
+ files
+ matchable
+ md5
+ message-digest
+ pathname-expand
+ posix
+ posix-extras
+ regex
+ regex-case
+ srfi-1
+ srfi-18
+ srfi-69
+ typed-records
+
+ debugprint
+ commonmod
+ )
+ (use srfi-69))
+ (chicken-5
+ (import (prefix sqlite3 sqlite3:)
+ ;; data-structures
+ ;; extras
+ ;; files
+ ;; posix
+ ;; posix-extras
+ chicken.base
+ chicken.condition
+ chicken.file
+ chicken.file.posix
+ chicken.io
+ chicken.pathname
+ chicken.port
+ chicken.process
+ chicken.process-context
+ chicken.process-context.posix
+ chicken.sort
+ chicken.string
+ chicken.time
+ chicken.time.posix
+
+ matchable
+ md5
+ message-digest
+ pathname-expand
+ regex
+ regex-case
+ srfi-1
+ srfi-18
+ srfi-69
+ typed-records
+ system-information
+
+ debugprint
+ commonmod
+ )))
+
+(define (process:conservative-read port)
+ (let loop ((res ""))
+ (if (not (eof-object? (peek-char port)))
+ (loop (conc res (read-char port)))
+ res)))
+
+(define (process:cmd-run-with-stderr->list cmd . params)
+ ;; (print "Called with cmd=" cmd ", proc=" proc ", params=" params)
+;; (handle-exceptions
+;; exn
+;; (begin
+;; (print "ERROR: Failed to run command: " cmd " " (string-intersperse params " "))
+;; (print " " ((condition-property-accessor 'exn 'message) exn))
+;; #f)
+ (let-values (((fh fho pid fhe) (if (null? params)
+ (process* cmd)
+ (process* cmd params))))
+ (let loop ((curr (read-line fh))
+ (result '()))
+ (let ((errstr (process:conservative-read fhe)))
+ (if (not (string=? errstr ""))
+ (set! result (append result (list errstr)))))
+ (if (not (eof-object? curr))
+ (loop (read-line fh)
+ (append result (list curr)))
+ (begin
+ (close-input-port fh)
+ (close-input-port fhe)
+ (close-output-port fho)
+ result))))) ;; )
+
+(define (process:cmd-run-with-stderr-and-exitcode->list cmd . params)
+ ;; (print "Called with cmd=" cmd ", proc=" proc ", params=" params)
+;; (handle-exceptions
+;; exn
+;; (begin
+;; (print "ERROR: Failed to run command: " cmd " " (string-intersperse params " "))
+;; (print " " ((condition-property-accessor 'exn 'message) exn))
+;; #f)
+ (let-values (((fh fho pid fhe) (if (null? params)
+ (process* cmd)
+ (process* cmd params))))
+ (let loop ((curr (read-line fh))
+ (result '()))
+ (let ((errstr (process:conservative-read fhe)))
+ (if (not (string=? errstr ""))
+ (set! result (append result (list errstr)))))
+ (if (not (eof-object? curr))
+ (loop (read-line fh)
+ (append result (list curr)))
+ (begin
+ (let-values (((anotherpid normalexit? exitstatus) (process-wait pid)))
+ (close-input-port fh)
+ (close-input-port fhe)
+ (close-output-port fho)
+ (list result (if normalexit? exitstatus -1))))))))
+
+(define (process:cmd-run-proc-each-line cmd proc . params)
+ ;; (print "Called with cmd=" cmd ", proc=" proc ", params=" params)
+ (handle-exceptions
+ exn
+ (begin
+ (debug:print 0 *default-log-port* "ERROR: Failed to run command: " cmd " " (string-intersperse params " "))
+ (debug:print 0 *default-log-port* " message: " ((condition-property-accessor 'exn 'message) exn))
+ (debug:print 5 *default-log-port* "exn=" (condition->list exn))
+ #f)
+ (let-values (((fh fho pid) (if (null? params)
+ (process cmd)
+ (process cmd params))))
+ (let loop ((curr (read-line fh))
+ (result '()))
+ (if (not (eof-object? curr))
+ (loop (read-line fh)
+ (append result (list (proc curr))))
+ (begin
+ (close-input-port fh)
+ ;;(close-input-port fhe)
+ (close-output-port fho)
+ result))))))
+
+(define (process:cmd-run-proc-each-line-alt cmd proc)
+ (let* ((fh (open-input-pipe cmd))
+ (res (port-proc->list fh proc))
+ (status (close-input-pipe fh)))
+ (if (eq? status 0) res #f)))
+
+(define (process:cmd-run->list cmd #!key (delta-env-alist-or-hash-table '()))
+ (common:with-env-vars
+ delta-env-alist-or-hash-table
+ (lambda ()
+ (let* ((fh (open-input-pipe cmd))
+ (res (port->list fh))
+ (status (close-input-pipe fh)))
+ (list res status)))))
+
+(define (port->list fh)
+ (if (eof-object? fh) #f
+ (let loop ((curr (read-line fh))
+ (result '()))
+ (if (not (eof-object? curr))
+ (loop (read-line fh)
+ (append result (list curr)))
+ result))))
+
+(define (port-proc->list fh proc)
+ (if (eof-object? fh) #f
+ (let loop ((curr (proc (read-line fh)))
+ (result '()))
+ (if (not (eof-object? curr))
+ (loop (let ((l (read-line fh)))
+ (if (eof-object? l) l (proc l)))
+ (append result (list curr)))
+ result))))
+
+;; here is an example line where the shell is sh or bash
+;; "find / -print 2&>1 > findall.log"
+(define (run-n-wait cmdline #!key (params #f)(print-cmd #f)(run-dir #f))
+ (if print-cmd
+ (debug:print 0 *default-log-port*
+ (if (string? print-cmd)
+ print-cmd
+ "")
+ (if run-dir (conc "Run in " run-dir ";") "")
+ cmdline
+ (if params
+ (conc " " (string-intersperse params " "))
+ "")))
+ (if (and run-dir
+ (directory-exists? run-dir))
+ (push-directory run-dir))
+ (let ((pid (if params
+ (process-run cmdline params)
+ (process-run cmdline))))
+ (let loop ((i 0))
+ (let-values (((pid-val exit-status exit-code) (process-wait pid #t)))
+ (if (eq? pid-val 0)
+ (begin
+ (thread-sleep! 2)
+ (loop (+ i 1)))
+ (begin
+ (if (and run-dir
+ (directory-exists? run-dir))
+ (pop-directory))
+ (values pid-val exit-status exit-code)))))))
+
+;;======================================================================
+;; MISC PROCESS RELATED STUFF
+;;======================================================================
+
+(define (process:children proc)
+ (with-input-from-pipe
+ (conc "ps h --ppid " (current-process-id) " -o pid")
+ (lambda ()
+ (let loop ((inl (read-line))
+ (res '()))
+ (if (eof-object? inl)
+ (reverse res)
+ (let ((pid (string->number inl)))
+ (if proc (proc pid))
+ (loop (read-line) (cons pid res))))))))
+
+(define (process:alive? pid)
+ (handle-exceptions
+ exn
+ ;; possibly pid is a process not a child, look in /proc to see if it is running still
+ (common:file-exists? (conc "/proc/" pid))
+ (let-values (((rpid exit-type exit-signal)(process-wait pid #t)))
+ (and (number? rpid)
+ (equal? rpid pid)))))
+
+(define (process:alive-on-host? host pid)
+ (let ((cmd (conc "ssh " host " ps -o pid= -p " pid)))
+ (common:generic-ssh
+ cmd
+ ;;
+ ;; handle-exceptions
+ ;; exn
+ ;; (begin
+ ;; (debug:print 0 *default-log-port* "failed to identify if process " pid ", on host " host " is alive. exn=" exn)
+ ;; #f) ;; anything goes wrong - assume the process in NOT running.
+ ;; (with-input-from-pipe
+ ;; cmd
+ (lambda ()
+ (let loop ((inl (read-line)))
+ (if (eof-object? inl)
+ #f
+ (let* ((clean-str (string-substitute "^[^\\d]*([0-9]+)[^\\d]*$" "\\1" inl))
+ (innum (string->number clean-str)))
+ (and innum
+ (eq? pid innum))))))
+ #f
+ (lambda ()
+ (debug:print 0 *default-log-port* "failed to identify if process "
+ pid", on host "host" is alive.")))))
+
+
+(define (process:get-sub-pids pid)
+ (with-input-from-pipe
+ (conc "pstree -A -p " pid) ;; | tr 'a-z\\-+`()\\.' ' ' " pid)
+ (lambda ()
+ (let loop ((inl (read-line))
+ (res '()))
+ (if (eof-object? inl)
+ (reverse res)
+ (let ((nums (map string->number
+ (string-split-fields "\\d+" inl))))
+ (loop (read-line)
+ (append res nums))))))))
+
+
+)
Index: rmt.scm
==================================================================
--- rmt.scm
+++ rmt.scm
@@ -21,11 +21,13 @@
(use format typed-records) ;; RADT => purpose of json format??
(declare (unit rmt))
(declare (uses debugprint))
(declare (uses api))
+(declare (uses common))
(declare (uses commonmod))
+(declare (uses configfmod))
(declare (uses dbfile))
(declare (uses dbmod))
(declare (uses tcp-transportmod))
(include "common_records.scm")
(declare (uses rmtmod))
@@ -32,10 +34,11 @@
;; used by http-transport
(import dbfile
rmtmod
commonmod
+ configfmod
debugprint
;; dbmemmod
dbfile
dbmod
tcp-transportmod)
@@ -67,83 +70,73 @@
(else #f)))
;;======================================================================
(define *send-receive-mutex* (make-mutex)) ;; should have separate mutex per run-id
-
-;; 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
- (assert *toppath* "FATAL: rmt:send-receive called with *toppath* not set.")
-
- (if (not (eq? (rmt:transport-mode) 'nfs))
- (begin
- (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)))
-
- ;; I'm turning this off, it may make sense to move it
- ;; into http-transport-handler
- (if (and (> attemptnum 5) (= 0 (modulo attemptnum 15)))
- (begin
- (debug:print 0 *default-log-port* "ERROR: can't connect to server, trying to start a server.")
- (case (rmt:transport-mode)
- ((http)
- (server:run *toppath*)
- (thread-sleep! 3))
- (else
- (thread-sleep! 1) ;; for tcp the server is started by routines in tcp-transportmod. For nfs there is no server
- ))))))
-
- ;; 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*))
- (testsuite (common:get-testsuite-name))
- (mtexe (common:find-local-megatest)))
-
- (case (rmt:transport-mode)
- ((http)(http-transport-handler runremote cmd rid params attemptnum area-dat areapath readonly-mode))
- ((tcp) (tcp-transport-handler runremote cmd rid params attemptnum area-dat areapath readonly-mode testsuite mtexe))
- ((nfs) (nfs-transport-handler runremote cmd rid params attemptnum area-dat areapath readonly-mode testsuite mtexe))
- )))
-
-(define (nfs-transport-handler runremote cmd run-id params attemptnum area-dat areapath readonly-mode testsuite mtexe)
- (let* ((keys (common:get-fields *configdat*))
- (dbstruct (dbmod:nfs-get-dbstruct run-id keys (dbfile:db-init-proc) areapath tmpadj: "/dashboard")))
- (api:dispatch-request dbstruct cmd run-id params)))
-
-(define (tcp-transport-handler runremote cmd run-id params attemptnum area-dat areapath readonly-mode testsuite mtexe)
- (if (not runremote)
- (let* ((newremote (make-and-init-remote areapath)))
- (set! *runremote* newremote)
- (set! runremote newremote)))
- (let* ((dbfname (conc (dbfile:run-id->dbnum run-id)".db"))) ;;(dbfile:run-id->path areapath run-id)))
- (tt:handler runremote cmd run-id params attemptnum area-dat areapath readonly-mode dbfname testsuite mtexe)))
-
-(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 *ttdat* #f)
+;; how to make area-dat
+(define (rmt:set-ttdat areapath ttdat)
+ (if ttdat
+ ttdat
+ (if *ttdat*
+ *ttdat*
+ (begin
+ (debug:print-info 2 *default-log-port* "rmt:set-ttdat: Initialize new ttdat")
+ (let* ((newremote (make-and-init-remote areapath)))
+ (set! *ttdat* newremote)
+ newremote
+ )
+ )
+ )
+ )
+)
+
+;; NB// area-dat replaced by ttdat
+;;
+(define (rmt:send-receive cmd run-id params #!key (attemptnum 1)(ttdat #f))
+ (assert (or (not run-id) (number? run-id)) "FATAL: run-id is required to be a number or #f")
+ (assert *toppath* "FATAL: rmt:send-receive called with *toppath* not set.")
+ (let* ((areapath *toppath*) ;; TODO - resolve from dbstruct to be compatible with multiple areas
+ (readonly-mode (rmtmod:calc-ro-mode ttdat *toppath*))
+ (testsuite (common:get-testsuite-name)))
+ (case (rmt:transport-mode)
+ ((tcp)
+ (let* ((start-time (current-seconds)) ;; snapshot time so all use cases get same value
+ (attemptnum (+ 1 attemptnum))
+ (mtexe (common:find-local-megatest))
+ (dbfname (conc (dbfile:run-id->dbnum run-id)".db"))
+ (ttdat (rmt:set-ttdat areapath ttdat))
+ (conn (tt:get-conn ttdat dbfname))
+ (is-main (equal? dbfname "main.db")) ;; why not (not run-id) ?
+ (server-start-proc (if is-main
+ #f
+ (lambda ()
+ ;; (debug:print-info 0 *default-log-port* "starting server for dbfname: "dbfname)
+ (rmt:start-server ;; tt:server-process-run
+ areapath
+ testsuite ;; (dbfile:testsuite-name)
+ mtexe
+ run-id)))))
+ ;; here we look at ttdat, if dbfname is NOT main.db we check that a conn exists for it
+ ;; and if there is no conn we first send a request to the main.db server to start a
+ ;; server for the dbfname.
+ #;(if (and (not is-main)(not conn)) ;; no existing connection to non-main server, call in a start up request
+ (begin
+ (server-start-proc)
+ (thread-sleep! 1)))
+ (tt:handler ttdat cmd run-id params attemptnum readonly-mode dbfname testsuite mtexe server-start-proc)))
+ ((nfs)
+ (nfs-transport-handler cmd run-id params attemptnum areapath readonly-mode testsuite))
+ (else
+ (debug:print-info 0 *default-log-port* "rmt:transport-mode is "(rmt:transport-mode))
+ (assert #f "FATAL: rmt:transport-mode set to invalid value.")))))
+
+(define (nfs-transport-handler cmd run-id params attemptnum areapath readonly-mode testsuite)
+ (let* ((keys (common:get-fields *configdat*))
+ (dbstruct (dbmod:nfs-get-dbstruct run-id keys (dbfile:db-init-proc) areapath)))
+ (api:dispatch-request dbstruct cmd run-id params)))
+
(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))
@@ -167,12 +160,12 @@
(mutex-unlock! *db-stats-mutex*)
res))
(define (rmt:open-qry-close-locally cmd run-id params #!key (remretries 5))
(let* ((qry-is-write (not (member cmd api:read-only-queries)))
- (db-file-path (db:dbfile-path)) ;; 0))
- (dbstructs-local (db:setup #t))
+ (db-file-path (common:make-tmpdir-name *toppath* "")) ;; 0))
+ (dbstructs-local (db:setup))
(read-only (not (file-write-access? db-file-path)))
(start (current-milliseconds))
(resdat (if (not (and read-only qry-is-write))
(let ((v (api:execute-requests dbstructs-local (vector (symbol->string cmd) params))))
;; (handle-exceptions ;; there has been a long history of receiving strange errors from values returned by the client when things go wrong..
@@ -204,11 +197,11 @@
;; (rmt:update-db-stats run-id cmd params duration)
;; mark this run as dirty if this was a write, the watchdog is responsible for syncing it
(if qry-is-write
(let ((start-time (current-seconds)))
(mutex-lock! *db-multi-sync-mutex*)
-/ (set! *db-last-access* start-time) ;; THIS IS PROBABLY USELESS? (we are on a client)
+ (set! *db-last-access* start-time) ;; THIS IS PROBABLY USELESS? (we are on a client)
(mutex-unlock! *db-multi-sync-mutex*)))))
res))
;;======================================================================
;;
@@ -221,12 +214,12 @@
;;======================================================================
(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)))
+(define (rmt:start-server areapath testsuite mtexe run-id) ;; run on main.db server
+ (rmt:send-receive 'start-server #f (list areapath testsuite mtexe run-id)))
;;======================================================================
;; M I S C
;;======================================================================
@@ -235,16 +228,16 @@
;; 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 runremote)
-;; (rmt:send-receive-no-auto-client-setup runremote 'login 0 (list *toppath* megatest-version (client:get-signature))))
+;; (rmt:send-receive-no-auto-client-setup runremote 'login #f (list *toppath* megatest-version (client:get-signature))))
;; 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)))
+ (rmt:send-receive 'get-latest-host-load #f (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)))
@@ -502,12 +495,12 @@
(rmt:send-receive 'delete-run #f (list run-id)))
(define (rmt:update-run-stats run-id stats)
(rmt:send-receive 'update-run-stats #f (list run-id stats)))
-(define (rmt:delete-old-deleted-test-records)
- (rmt:send-receive 'delete-old-deleted-test-records #f '()))
+(define (rmt:delete-old-deleted-test-records run-id)
+ (rmt:send-receive 'delete-old-deleted-test-records run-id (list run-id)))
(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)
Index: rmtmod.scm
==================================================================
--- rmtmod.scm
+++ rmtmod.scm
@@ -86,33 +86,41 @@
(define (rmt:import-run target run-dat)
(let* ((runname (car run-dat))
(all-dat (cdr run-dat))
(tests-data (alist-ref "data" all-dat equal?))
(run-meta (alist-ref "meta" all-dat equal?))
- (run-id (rmt:insert-run target runname run-meta)))
+ (run-id (string->number (alist-ref "id" run-meta equal?))))
+
+ (rmt:insert-run run-id target runname run-meta)
(for-each
(lambda (test-dat)
(let* ((test-id (car test-dat))
(test-rec (cdr test-dat)))
(rmt:insert-test run-id test-rec)))
tests-data)))
;; insert run if not there, return id either way
-(define (rmt:insert-run target runname run-meta)
+(define (rmt:insert-run run-id target runname run-meta)
;; look for id, return if found
(debug:print 0 *default-log-port* "Insert run: "target"/"runname)
(let* ((runs (rmtmod:send-receive 'simple-get-runs #f
;; runpatt count offset target last-update)
(list runname #f #f target #f))))
(if (null? runs)
- (rmtmod:send-receive 'insert-run #f (list target runname run-meta))
- (simple-run-id (car runs)))))
+ (begin
+ (debug:print 0 *default-log-port* "inserting run for runname " runname " target " target)
+ (rmtmod:send-receive 'insert-run #f (list run-id target runname run-meta))
+ )
+ (begin
+ (debug:print 0 *default-log-port* "Found run-id " (simple-run-id (car runs)) " for runname " runname " target " target)
+ (simple-run-id (car runs)
+ )
+ ))))
(define (rmt:insert-test run-id test-rec)
(let* ((testname (alist-ref "testname" test-rec equal?))
(item-path (alist-ref "item_path" test-rec equal?)))
- (debug:print 0 *default-log-port* " Insert test in run "run-id": "testname"/"item-path)
(rmtmod:send-receive 'insert-test run-id test-rec)))
;;======================================================================
;; T E S T S
;;======================================================================
@@ -192,21 +200,28 @@
(define (rmt:get-toplevels-and-incompletes run-id running-deadtime remotehoststart-deadtime)
(rmtmod:send-receive 'get-toplevels-and-incompletes run-id (list run-id running-deadtime remotehoststart-deadtime)))
+;; .final-status file is two lines:
+;; "state"
+;; "status"
+;;
(define (rmt:get-status-from-final-status-file run-dir)
(let ((infile (conc run-dir "/.final-status")))
- ;; first verify we are able to write the output file
+ ;; first verify we are able to read the output file
(if (not (file-read-access? infile))
(begin
(debug:print 2 *default-log-port* "ERROR: cannot read " infile)
(debug:print 2 *default-log-port* "ERROR: run-dir is " run-dir)
#f
)
- (with-input-from-file infile read-lines)
- )))
+ (let ((res (with-input-from-file infile read-lines)))
+ (if (null? res)
+ #f
+ res))))) ;; (string-split (car res))))))) <== I would have preferred a single line STATE STATUS without "'s
+ ;; (string-split (car res))))))) ;; DUNNO WHICH IS CORRECT
;; select end_time-now from
;; (select testname,item_path,event_time+run_duration as
;; end_time,strftime('%s','now') as now from tests where state in
;; ('RUNNING','REMOTEHOSTSTART','LAUNCHED'));
Index: runs.scm
==================================================================
--- runs.scm
+++ runs.scm
@@ -20,10 +20,12 @@
(declare (unit runs))
(declare (uses db))
(declare (uses common))
(declare (uses debugprint))
(declare (uses commonmod))
+(declare (uses processmod))
+(declare (uses configfmod))
(declare (uses items))
(declare (uses runconfig))
(declare (uses tests))
(declare (uses server))
(declare (uses mt))
@@ -45,10 +47,12 @@
(include "test_records.scm")
;; (include "debugger.scm")
(import commonmod
+ processmod
+ configfmod
debugprint
rmtmod
dbfile
(prefix mtargs args:))
@@ -346,11 +350,11 @@
(args:get-arg "-one-pass"))
(exit 0))
(if (runs:dat-load-mgmt-function runsdat)((runs:dat-load-mgmt-function runsdat)))
- (let* ((num-running (rmt:get-count-tests-running run-id))
+ (let* ((num-running (rmt:get-count-tests-running-for-run-id run-id))
(num-running-in-jobgroup (rmt:get-count-tests-running-in-jobgroup run-id jobgroup))
(job-group-limit (let ((jobg-count (configf:lookup *configdat* "jobgroups" jobgroup)))
(if (string? jobg-count)
(string->number jobg-count)
jobg-count))))
@@ -2064,11 +2068,11 @@
;;
;; There is now a single call to runs:update-all-test_meta and this
;; per-test call is not needed. Given the delicacy of the move to
;; v1.55 this code is being left in place for the time being.
;;
- (if (not (hash-table-ref/default *test-meta-updated* test-name #f))
+ (if (not (hash-table-exists? *test-meta-updated* test-name))
(begin
(hash-table-set! *test-meta-updated* test-name #t)
(runs:update-test_meta test-name test-conf)))
;; itemdat => ((ripeness "overripe") (temperature "cool") (season "summer"))
@@ -2434,10 +2438,12 @@
((kill-runs)
(tasks:kill-runner target run-name "%")
(debug:print 1 *default-log-port* "Killing tests for run: " runkey " " (db:get-value-by-header run header "runname"))
)
((remove-runs)
+ ;; use this location to cleanup old DELETED records? No. See below for same call
+ ;; (rmt:delete-old-deleted-test-records run-id)
;; (if (tasks:need-server run-id)(tasks:start-and-wait-for-server tdbdat run-id 10))
;; seek and kill in flight -runtests with % as testpatt here
;; (if (equal? testpatt "%")
(tasks:kill-runner target run-name testpatt)
;; (debug:print 0 *default-log-port* "not attempting to kill any run launcher processes as testpatt is " testpatt))
@@ -2724,11 +2730,11 @@
(debug:print 1 *default-log-port* "Removing target " target "run: " run-name)
(if (not keep-records)
(begin
(debug:print 1 *default-log-port* "Removing DB records for the run.")
(rmt:delete-run run-id)
- (rmt:delete-old-deleted-test-records))
+ (rmt:delete-old-deleted-test-records run-id))
)
(if (not (equal? linkspath "/does/not/exist/I"))
(begin
(debug:print 1 *default-log-port* "Recursively removing links dir " linkspath)
(runs:recursive-delete-with-error-msg linkspath)))
@@ -2916,11 +2922,11 @@
(fld (car key))
(val (configf:lookup test-conf "test_meta" fld)))
;; (debug:print 5 *default-log-port* "idx: " idx " fld: " fld " val: " val)
(if (and val (not (equal? (vector-ref currrecord idx) val)))
(begin
- (debug:print 0 *default-log-port* "Updating " test-name " " fld " to " val)
+ (debug:print 2 *default-log-port* "Updating " test-name " " fld " to " val)
(rmt:testmeta-update-field test-name fld val)))))
'(("author" 2)("owner" 3)("description" 4)("reviewed" 5)("tags" 9)("jobgroup" 10)))))
;; find tests with matching tags, tagpatt is a string "tagpatt1,tagpatt2%, ..."
;;
Index: server.scm
==================================================================
--- server.scm
+++ server.scm
@@ -17,10 +17,11 @@
;;
(declare (unit server))
(declare (uses commonmod))
+(declare (uses configfmod))
(declare (uses debugprint))
(declare (uses common))
(declare (uses db))
(declare (uses tasks)) ;; tasks are where stuff is maintained about what is running.
;; (declare (uses synchash))
@@ -33,10 +34,11 @@
(use srfi-1 posix regex regex-case srfi-69 hostinfo md5 message-digest)
(use directory-utils posix-extras matchable utils)
(use spiffy uri-common intarweb http-client spiffy-request-vars)
(import commonmod
+ configfmod
debugprint
(prefix mtargs args:))
(include "common_records.scm")
(include "db_records.scm")
@@ -728,11 +730,11 @@
;; #t
;; #f)))
;; timeout is hms string: 1h 5m 3s, default is 1 minute
;; This is currently broken. Just use the number of hours with no unit.
-;; Default is 60 seconds.
+;; Default is 600 seconds.
;;
(define (server:expiration-timeout)
(let* ((tmo (configf:lookup *configdat* "server" "timeout")))
(if (string? tmo)
(let* ((num (string->number tmo)))
Index: subrun.scm
==================================================================
--- subrun.scm
+++ subrun.scm
@@ -21,17 +21,19 @@
(declare (unit subrun))
(declare (uses debugprint))
(declare (uses db))
(declare (uses common))
(declare (uses commonmod))
+(declare (uses configfmod))
(declare (uses mt))
(use (prefix sqlite3 sqlite3:) srfi-1 posix regex regex-case srfi-69 (srfi 18)
posix-extras directory-utils pathname-expand typed-records format
call-with-environment-variables)
(import commonmod
+ configfmod
debugprint)
;(include "common_records.scm")
;;(include "key_records.scm")
(include "db_records.scm") ;; provides db:test-get-id
Index: tasks.scm
==================================================================
--- tasks.scm
+++ tasks.scm
@@ -26,16 +26,20 @@
(declare (uses rmt))
(declare (uses rmtmod))
(declare (uses common))
(declare (uses pgdb))
(declare (uses commonmod))
+(declare (uses configfmod))
+(declare (uses processmod))
(declare (uses mtargs))
(use sqlite3 srfi-1 posix regex regex-case srfi-69 dot-locking format)
(import (prefix sqlite3 sqlite3:))
(import commonmod
+ configfmod
+ processmod
debugprint
dbmod
rmtmod
(prefix mtargs args:))
@@ -84,11 +88,11 @@
(tasks:open-db numretries (- numretries 1)))
(begin
(print-call-chain (current-error-port))
(debug:print 0 *default-log-port* " message: " ((condition-property-accessor 'exn 'message) exn))
(debug:print 5 *default-log-port* " exn=" (condition->list exn))))
- (let* ((dbpath (db:dbfile-path )) ;; (tasks:get-task-db-path))
+ (let* ((dbpath (common:make-tmpdir-name *toppath* "")) ;; (tasks:get-task-db-path))
(dbfile (conc dbpath "/monitor.db"))
(avail (tasks:wait-on-journal dbpath 10)) ;; wait up to about 10 seconds for the journal to go away
(exists (common:file-exists? dbpath))
(write-access (file-write-access? dbpath))
(mdb (cond ;; what the hek is *toppath* doing here?
Index: tcp-transportmod.scm
==================================================================
--- tcp-transportmod.scm
+++ tcp-transportmod.scm
@@ -28,25 +28,52 @@
(use address-info tcp)
(module tcp-transportmod
*
- (import scheme
- (prefix sqlite3 sqlite3:)
- chicken
- data-structures
+(import scheme)
- address-info
- directory-utils
+(cond-expand
+ (chicken-4
+ (import (prefix sqlite3 sqlite3:)
+ chicken
extras
- files
hostinfo
+
+ ports
+ posix
+ files
+ data-structures
+ tcp
+ ))
+ (chicken-5
+ (import chicken.base
+ chicken.condition
+ chicken.file
+ chicken.pathname
+ chicken.process-context.posix
+ chicken.process
+ chicken.sort
+ chicken.string
+ chicken.time
+ chicken.tcp
+ chicken.random
+ chicken.file.posix
+ chicken.pretty-print
+ chicken.io
+ chicken.port
+ chicken.process-context
+
+ system-information)
+ (define unsetenv unset-environment-variable!)
+ ))
+
+ (import address-info
+ directory-utils
matchable
md5
message-digest
- ports
- posix
regex
regex-case
s11n
srfi-1
srfi-18
@@ -53,11 +80,10 @@
srfi-4
srfi-69
stack
typed-records
tcp-server
- tcp
debugprint
commonmod
dbfile
dbmod
@@ -110,11 +136,12 @@
;; parameters
;;
(define tt-server-timeout-param (make-parameter 600))
;; make ttdat visible
-(define *server-info* #f)
+;; (define *server-info* #f) ;; get this from commonmod
+(define *server-run* #t)
(define (tt:make-remote areapath)
(make-tt areapath: areapath))
;; 1 ... or #f
@@ -125,33 +152,46 @@
(and (or (number? run-id)
(not run-id))
(equal? (dbfile:run-id->dbfname run-id) dbfname)))
(tcp-buffer-size 2048)
-;; (max-connections 4096)
+;; (max-connections 4096)
+
+(define (tt:get-conn ttdat dbfname)
+ (hash-table-ref/default (tt-conns ttdat) dbfname #f))
;; do all the busy work of finding and setting up conn for
;; connecting to a server
;;
-(define (tt:client-connect-to-server ttdat dbfname run-id testsuite)
+(define (tt:client-connect-to-server ttdat dbfname run-id testsuite server-start-proc)
(assert (tt:valid-run-id run-id dbfname) "FATAL: invalid run-id "run-id)
- (let* ((conn (hash-table-ref/default (tt-conns ttdat) dbfname #f))
- (server-start-proc (lambda ()
- (tt:server-process-run
- (tt-areapath ttdat)
- testsuite ;; (dbfile:testsuite-name)
- (common:find-local-megatest)
- run-id))))
+ (debug:print-info 2 *default-log-port* "tt:client-connect-to-server " dbfname " " run-id)
+ (let* ((conn (tt:get-conn ttdat dbfname))
+ (server-start-proc (or server-start-proc
+ (lambda ()
+ (assert (equal? dbfname "main.db") ;; only main.db is started here
+ "FATAL: called server-start-proc for db other than main.db")
+ (tt:server-process-run
+ (tt-areapath ttdat)
+ testsuite ;; (dbfile:testsuite-name)
+ (common:find-local-megatest)
+ run-id)))))
(if conn
(begin
- ; (debug:print-info 0 *default-log-port* "already connected to the server")
+ (debug:print-info 2 *default-log-port* "already connected to a server")
conn) ;; we are already connected to the server
- (let* ((sdat (tt:get-current-server-info ttdat dbfname)))
- (match sdat
+
+ ;; no conn
+ (let* ((sdats (tt:get-server-info-sorted ttdat dbfname))
+ (sdat (if (null? sdats)
+ #f
+ (car sdats))))
+ (debug:print-info 2 *default-log-port* "found sdat " sdat)
+ (match sdat
((host port start-time server-id pid dbfname2 servinffile)
(assert (equal? dbfname dbfname2) "FATAL: read server info from wrong file.")
- ;(debug:print-info 0 *default-log-port* "in match servinffile:" servinffile)
+ (debug:print-info 2 *default-log-port* "no conn - in match servinffile:" servinffile)
(let* ((host-port (conc host":"port))
(conn (make-tt-conn
host: host
port: port
host-port: host-port
@@ -162,36 +202,52 @@
pid: pid)))
;; verify we can talk to this server
(let* ((result (tt:timed-ping host port server-id))
(ping-res (car result))
(ping (cdr result)))
- (debug:print-info 0 *default-log-port* "ping time: " ping)
+ (debug:print-info 2 *default-log-port* "host " host " port " port " ping time: " ping " result " ping-res)
(case ping-res
((running)
+ (debug:print-info 2 *default-log-port* "Setting conn = " conn " in hash table")
(hash-table-set! (tt-conns ttdat) dbfname conn) ;;; is this ok to save before validating that the connection is good?
conn)
((starting)
(thread-sleep! 0.5)
- (tt:client-connect-to-server ttdat dbfname run-id testsuite))
+ (debug:print-info 0 *default-log-port* "server for " dbfname " is in starting state, retrying connect")
+ (tt:client-connect-to-server ttdat dbfname run-id testsuite server-start-proc))
(else
(let* ((curr-secs (current-seconds)))
;; rm the (last server) would go here
(if (> (- curr-secs (tt-last-serv-start ttdat)) 10)
(begin
+ (debug:print-info 0 *default-log-port* "Unreachable server at "
+ host":"port" with servinfo file "servinffile", removing it")
+ (if (file-exists? servinffile)
+ (handle-exceptions
+ exn
+ #f
+ (delete-file servinffile)))
(tt-last-serv-start-set! ttdat curr-secs)
- (server-start-proc))) ;; start server if 30 sec since last attempt
+ (debug:print-info 0 *default-log-port* "Starting a new server on " (get-host-name))
+ (server-start-proc))) ;; start server if 10 sec since last attempt
(thread-sleep! 1)
- (tt:client-connect-to-server ttdat dbfname run-id testsuite)))))))
+ (debug:print-info 0 *default-log-port* "Retrying connect")
+ (tt:client-connect-to-server ttdat dbfname run-id testsuite server-start-proc)))))))
+
(else ;; no good server found, if haven't started server in > 5 secs, start another
- (if (> (- (current-seconds) (tt-last-serv-start ttdat)) 5) ;; BUG - grow this number really do not want to swamp the machine with servers
+ (if (> (- (current-seconds) (tt-last-serv-start ttdat)) 3) ;; BUG - grow this number really do not want to swamp the machine with servers
(begin
- (debug:print-info 0 *default-log-port* "No server found. Starting one for run-id "run-id" in dbfile "dbfname)
+ (debug:print-info 0 *default-log-port* "Starting server for "dbfname " on " (get-host-name))
(server-start-proc)
- (tt-last-serv-start-set! ttdat (current-seconds))))
+ (tt-last-serv-start-set! ttdat (current-seconds))
+ (thread-sleep! 6)
+ ))
(thread-sleep! 1)
- (tt:client-connect-to-server ttdat dbfname run-id testsuite)))))))
+ (debug:print-info 0 *default-log-port* "Connect to server from " (get-host-name) " for " dbfname)
+ (tt:client-connect-to-server ttdat dbfname run-id testsuite server-start-proc)))))))
+;; returns ( result . ping_time )
(define (tt:timed-ping host port server-id)
(let* ((start-time (current-milliseconds))
(result (tt:ping host port server-id)))
(cons result (- (current-milliseconds) start-time))))
@@ -222,18 +278,18 @@
;; client side handler
;;
;;(tt:handler # get-keys #f () 2 #f "/home/matt/data/megatest/ext-tests" #f "main.db" "ext-tests" "/home/matt/data/megatest/bin/.22.04/../megatest")
;;
-(define (tt:handler ttdat cmd run-id params attemptnum area-dat areapath readonly-mode dbfname testsuite mtexe)
- ;; NOTE: areapath is passed in and in tt struct. We'll use passed in value for now.
- (let* ((conn (tt:client-connect-to-server ttdat dbfname run-id testsuite))) ;; (hash-table-ref/default (tt-conns ttdat) dbfname #f)))
+(define (tt:handler ttdat cmd run-id params attemptnum readonly-mode dbfname testsuite mtexe server-start-proc)
+ ;; connect-to-server will start a server if needed.
+ (let* ((areapath (tt-areapath ttdat))
+ (conn (tt:client-connect-to-server ttdat dbfname run-id testsuite server-start-proc))) ;; looks up conn keyed by dbfname
(if conn
;; have connection, call the server
(let* ((res (tt:send-receive ttdat conn cmd run-id params)))
;; res is (status errmsg result meta)
- ; (debug:print 0 *default-log-port* "conn:" conn " res: " res)
(match res
((status errmsg result meta)
(if (list? meta)
(let* ((delay-wait (alist-ref 'delay-wait meta)))
(if (and (number? delay-wait)
@@ -241,35 +297,36 @@
(begin
(debug:print 0 *default-log-port* "Server is loaded, delaying "delay-wait" seconds")
(thread-sleep! delay-wait)))))
(case status
((busy) ;; result will be how long the server wants you to delay
- (let* ((dly (if (number? result) result 0.1)))
- (debug:print 0 *default-log-port* "WARNING: server for "dbfname" is busy, will try again in "dly" seconds.")
+ (let* ((raw-dly (if (number? result) result 0.1))
+ (dly (+ raw-dly (/ attemptnum 10)))) ;; (* raw-dly (/ attemptnum 2))))
+ (debug:print 0 *default-log-port* "WARNING: server for "dbfname" is busy, cmd is "cmd", will try again in "dly" seconds. This is attempt "(- attemptnum 1))
(thread-sleep! dly)
- (tt:handler ttdat cmd run-id params (+ attemptnum 1) area-dat areapath readonly-mode dbfname testsuite mtexe)))
+ (tt:handler ttdat cmd run-id params (+ attemptnum 1) readonly-mode dbfname testsuite mtexe server-start-proc)))
((loaded)
(debug:print 0 *default-log-port* "WARNING: server for "dbfname" is loaded, slowing queries.")
(tt:backoff-incr (tt-conn-host conn)(tt-conn-port conn))
- result) ;; (tt:handler ttdat cmd run-id params (+ attemptnum 1) area-dat areapath readonly-mode dbfname testsuite mtexe))
+ result) ;; (tt:handler ttdat cmd run-id params (+ attemptnum 1) readonly-mode dbfname testsuite mtexe))
(else
result)))
(else ;; did not receive properly formated result
- (if (not res) ;; tt:handler is telling us that communication failed
+ (if (not res) ;; tt:send-receive telling us that communication failed
(let* ((host (tt-conn-host conn))
(port (tt-conn-port conn))
;; (dbfname (tt-conn-port conn)) ;; 192.168.0.127:4242-726924:4.db
(pid (tt-conn-pid conn))
;;(servinf (tt-conn-servinf-file conn)))
(servinf (tt-servinf-file ttdat))) ;; (conc areapath"/.servinfo/"host":"port"-"pid":"dbfname))) ;; TODO, use (server:get-servinfo-dir areapath)
- (hash-table-set! (tt-conns ttdat) dbfname #f)
+ (hash-table-set! (tt-conns ttdat) dbfname #f) ;; clear out the conn for this dbfname to force finding new server
(if (and servinf (file-exists? servinf))
(begin
(if (< attemptnum 10)
(begin
(thread-sleep! 0.5)
- (tt:handler ttdat cmd run-id params (+ attemptnum 1) area-dat areapath readonly-mode dbfname testsuite mtexe))
+ (tt:handler ttdat cmd run-id params (+ attemptnum 1) readonly-mode dbfname testsuite mtexe server-start-proc))
(begin
(debug:print 0 *default-log-port* "INFO: no response from server "host":"port" for "dbfname)
(if (and (file-exists? servinf)
(> (- (current-seconds)(file-modification-time servinf)) 60))
(begin
@@ -276,33 +333,30 @@
(debug:print 0 *default-log-port* "INFO: "servinf" file seems old and no ping response, removing it.")
(handle-exceptions
exn
#f
(delete-file* servinf))
- (tt:handler ttdat cmd run-id params (+ attemptnum 1) area-dat areapath readonly-mode dbfname testsuite mtexe))
+ (tt:handler ttdat cmd run-id params (+ attemptnum 1) readonly-mode dbfname testsuite mtexe server-start-proc))
(begin
;; start server - addressed in client-connect-to-server
;; delay - addressed in client-connect-to-server
;; try again
(thread-sleep! 0.25) ;; dunno, I think this needs to be here
- (tt:handler ttdat cmd run-id params (+ attemptnum 1) area-dat areapath readonly-mode dbfname testsuite mtexe))
+ (tt:handler ttdat cmd run-id params (+ attemptnum 1) readonly-mode dbfname testsuite mtexe server-start-proc))
))))
(begin ;; no server file, delay and try again
- (debug:print 0 *default-log-port* "INFO: connection to server "host":"port" broken for "dbfname", but do not see servinf file "servinf)
+ (debug:print 2 *default-log-port* "INFO: connection to server "host":"port" broken for "dbfname", no servinf file. Server exited? ")
(thread-sleep! 0.5)
- (tt:handler ttdat cmd run-id params (+ attemptnum 1) area-dat areapath readonly-mode dbfname testsuite mtexe))))
+ (tt:handler ttdat cmd run-id params (+ attemptnum 1) readonly-mode dbfname testsuite mtexe server-start-proc))))
(begin ;; this case is where res is malformed. Probably should abort
(assert #f "FATAL: tt:handler received bad data "res)
;; (debug:print 0 *default-log-port* "INFO: got corrupt data from server "host":"port", "res", for "dbfname", will try again.")
- ;; (tt:handler ttdat cmd run-id params (+ attemptnum 1) area-dat areapath readonly-mode dbfname testsuite mtexe)
+ ;; (tt:handler ttdat cmd run-id params (+ attemptnum 1) readonly-mode dbfname testsuite mtexe)
)))))
(begin
(thread-sleep! 1) ;; no conn yet set up, give it a rest and try again
- (tt:handler ttdat cmd run-id params attemptnum area-dat areapath readonly-mode dbfname testsuite mtexe)))))
-
-(define (tt:bid-for-servership run-id)
- #f)
+ (tt:handler ttdat cmd run-id params attemptnum readonly-mode dbfname testsuite mtexe server-start-proc)))))
;; gets server info and appends path to server file
;; sorts by age, oldest first
;;
;; returns list of (host port startseconds server-id servinfofile)
@@ -325,24 +379,10 @@
(debug:print 2 *default-log-port* "SERVER #"count": "(string-intersperse (map conc sorted) ", ")))
(set! count (+ count 1)))
sorted)
sorted))
-(define (tt:get-current-server-info ttdat dbfname)
- (assert (tt-areapath ttdat) "FATAL: areapath not set in ttdat.")
- ;;
- ;; TODO - replace most of below with tt;get-server-info-sorted
- ;;
- (let* ((areapath (tt-areapath ttdat))
- (sfiles (tt:find-server areapath dbfname))
- (sdats (filter car (map tt:server-get-info sfiles))) ;; first element is #f if the file disappeared while being read
- (sorted (sort sdats (lambda (a b)
- (< (list-ref a 2)(list-ref b 2))))))
- (if (null? sorted)
- #f ;; we'll want to wait until extra servers have exited
- (car sorted))))
-
(define (tt:send-receive ttdat conn cmd run-id params)
(let* ((host-port (tt-conn-host-port conn)) ;; (conc (tt-conn-host conn)":"(tt-conn-port conn)))
(host (tt-conn-host conn))
(port (tt-conn-port conn))
(dat (list cmd run-id params #f))) ;; no meta data yet
@@ -379,18 +419,18 @@
(- wait-delay adj))
0)))
(if (> new-wait 0)
(begin
(if (common:low-noise-print 10 "delay wait message")
- (debug:print-info 0 *default-log-port* "Server loaded, DelayWait: "new-wait))
+ (debug:print-info 0 *default-log-port* "Server on host " host " loaded, DelayWait: "new-wait))
(tt:backoff-wait-delay-set! bkoff new-wait)
(tt:backoff-last-adj-t-set! bkoff (current-seconds))
(thread-sleep! new-wait))
(hash-table-delete! *tt:backoff-smoothing* host-port))))))
(define (tt:send-receive-direct host port dat #!key (ping-mode #f)(tries-remaining 25))
- (assert (number? port) "FATAL: tt:send-receive-direct called with port not a number "port)
+ (assert (number? port) "FATAL: tt:send-receive-direct called with a port that is not a number "port)
(tt:backoff-decr-and-wait host port)
(let* ((retry (lambda ()
(tt:send-receive-direct host port dat tries-remaining: (- tries-remaining 1))))
(full-err-print (lambda (exn msg)
(if (condition? exn)
@@ -457,244 +497,211 @@
;; start the listener and start responding to requests
;;
;; NOTE: organise by dbfname, not run-id so we don't need
;; to pull in more modules
;;
-;; This is the routine called in megatest.scm to start a server
+;; This is the routine called in megatest.scm to start a server. NOTE: sequence is different for main.db vs. X.db
;;
;; Server viability is checked in keep-running. Blindly start and run here.
;;
(define (tt:start-server areapath run-id dbfname-in handler keys)
(assert areapath "FATAL: areapath not provided for tt:start-server")
- ;; is there already a server for this dbfile? Then exit.
(let* ((ttdat (make-tt areapath: areapath))
- (dbfname (or dbfname-in (dbmod:run-id->dbfname run-id)))
- (servers (tt:find-server areapath dbfname))) ;; should use tt:get-current-server-info instead
- (if (> (length servers) 4)
- (begin
- (debug:print 0 *default-log-port* "INFO: found server(s) already running for db "dbfname", "(string-intersperse servers ",")" Exiting.")
- (exit))
- (let* ((dbstruct (dbmod:open-dbmoddb areapath run-id dbfname (dbfile:db-init-proc) keys)))
- (tt-handler-set! ttdat (handler dbstruct))
- (let* ((tcp-thread (make-thread
- (lambda ()
- (tt:start-tcp-server ttdat)) ;; start the tcp-server which applies handler to incoming data
- "tcp-server-thread"))
- (run-thread (make-thread
- (lambda ()
- (tt:keep-running ttdat dbfname dbstruct)))))
- (thread-start! tcp-thread)
- (thread-start! run-thread)
-
- (let* ((areapath (tt-areapath ttdat))
- (nosyncdbpath (conc areapath"/.mtdb")))
- ;; this didn't seem to work, is port not available yet?
- (let loop ((count 0))
- (if (tt-port ttdat)
- (begin
- (procinf-port-set! *procinf* (tt-port ttdat))
- (procinf-dbname-set! *procinf* dbfname)
- (dbfile:with-no-sync-db
- nosyncdbpath
- (lambda (nsdb)
- (dbfile:insert-or-update-process nsdb *procinf*))))
- (if (< count 5)
- (begin
- (thread-sleep! 0.5)
- (loop (+ count 1)))
- (debug:print 0 *default-log-port* "ERROR: (tt-port ttdat) no port set!"))))
-
- (thread-join! run-thread) ;; run thread will exit on timeout or other conditions
- ;; replace with call to (dbfile:set-process-done nsdb host pid reason)
- (procinf-status-set! *procinf* "done")
- (procinf-end-set! *procinf* (current-seconds))
- (dbfile:with-no-sync-db
- nosyncdbpath
- (lambda (nsdb)
- (dbfile:insert-or-update-process nsdb *procinf*)))
- (debug:print 0 *default-log-port* "Exiting now.")
- (exit)))))))
+ (dbfname (or dbfname-in (dbmod:run-id->dbfname run-id))))
+ (set! *server-info* ttdat)
+ (let* ((dbstruct (dbmod:open-dbmoddb areapath run-id dbfname (dbfile:db-init-proc) keys)))
+ (tt-handler-set! ttdat (handler dbstruct))
+ (let* ((servinf-created #f)
+ (tcp-thread (make-thread
+ (lambda ()
+ ;; NOTE: tt-port and tt-host are set in connect-listener which is called under tt:start-tcp-server
+ (tt:start-tcp-server ttdat)) ;; start the tcp-server which applies handler to incoming data
+ "tcp-server-thread"))
+ (run-thread (make-thread
+ (lambda ()
+ (tt:keep-running ttdat dbfname dbstruct)))))
+ (thread-start! tcp-thread)
+
+ (let* ((areapath (tt-areapath ttdat))
+ (nosyncdbpath (conc areapath"/.mtdb"))
+ (servers ;; (tt:find-server areapath dbfname)))
+ (tt:get-server-info-sorted ttdat dbfname)) ;; (host port startseconds server-id servinfofile)
+ (good-srvrs
+ ;; contact servers via ping, if no response remove the .servinfo file
+ (let loop ((servrs servers)
+ (prime-host #f)
+ (result '()))
+ (if (null? servrs)
+ (reverse result)
+ (let* ((servdat (car servrs)))
+ (match servdat
+ ((host port startseconds server-id servinfofile)
+ (let* ((ping-res (tt:timed-ping host port server-id))
+ (good-ping (match ping-res
+ ((result . ping-time)
+ (not result)) ;; we couldn't reach the server or it was not a megatest server
+ (else #f))) ;; the ping failed completely?
+ (same-host (or (not prime-host) ;; i.e. this is the first host
+ (equal? prime-host host)))
+ (keep-srv (and good-ping same-host)))
+ (if keep-srv
+ (loop (cdr servrs)
+ host
+ (cons servdat result))
+ (begin
+ (handle-exceptions
+ exn
+ (debug:print-info 0 *default-log-port* "Error removing server info file: "servinfofile", "
+ (condition->list exn))
+ (delete-file* servinfofile))
+ (loop (cdr servrs) prime-host result)))))
+ (else
+ ;; can't delete it as we don't have a filename. NOTE: Should really never get here.
+ (debug:print-info 0 *default-log-port* "ERROR: bad servinfo record \""servdat"\"")
+ (loop (cdr servrs) prime-host result)) ;; drop
+ )))))
+ (home-host (if (null? good-srvrs)
+ #f
+ (caar good-srvrs))))
+ ;; by here we have a trustworthy list of servers and we have removed the .servinfo file for any unresponsive servers
+ ;; and the list is in good-srvrs
+ (cond
+ ((not home-host) ;; no servers yet, go ahead and start
+ (debug:print-info 0 *default-log-port* "No servers yet, starting on "(get-host-name)))
+ ((> (length good-srvrs) 2) ;; don't need more, just exit
+ (debug:print-info 0 *default-log-port* "Have "(length good-srvrs)", no need for more, exiting.")
+ (exit))
+ ((not (equal? home-host (get-host-name))) ;; there is a home-host and we are not on it
+ (debug:print-info 0 *default-log-port* "Prime main server is on host "home-host", but we are on host "(get-host-name)", exiting.")
+ (exit))
+ (else
+ (debug:print-info 0 *default-log-port* "Starting on host "(get-host-name)", along with "(length good-srvrs)" other servers.")))
+
+ ;; this didn't seem to work, is port not available yet?
+ (let loop ((count 0))
+ (if (tt-port ttdat)
+ (begin
+ (procinf-port-set! *procinf* (tt-port ttdat))
+ (procinf-dbname-set! *procinf* dbfname)
+ (dbfile:with-no-sync-db
+ nosyncdbpath
+ (lambda (nsdb)
+ (dbfile:insert-or-update-process nsdb *procinf*))))
+ (if (< count 10)
+ (begin
+ (thread-sleep! 0.25)
+ (loop (+ count 1)))
+ (begin
+ (debug:print 0 *default-log-port* "ERROR: (tt-port ttdat) no port set! Exiting.")
+ (exit)))))
+
+ ;; create a servinfo file start keep-running
+ (debug:print 0 *default-log-port* "Creating servinfo file for " dbfname)
+ (tt:create-server-registration-file ttdat dbfname)
+ (procinf-status-set! *procinf* "running")
+ (tt-state-set! ttdat 'running)
+ (dbfile:with-no-sync-db
+ nosyncdbpath
+ (lambda (nsdb)
+ (dbfile:insert-or-update-process nsdb *procinf*)))
+ (thread-start! run-thread)
+
+ (thread-join! run-thread) ;; run thread will exit on timeout or other conditions
+
+ ;; (tcp-close (tt-socket ttdat)) ;; close up ports here
+
+ ;; replace with call to (dbfile:set-process-done nsdb host pid reason)
+ (procinf-status-set! *procinf* "done")
+ (procinf-end-set! *procinf* (current-seconds))
+ ;; either convert this to use set-process-done or get rid of set-process-done
+ (dbfile:with-no-sync-db
+ nosyncdbpath
+ (lambda (nsdb)
+ (dbfile:insert-or-update-process nsdb *procinf*)))
+ (debug:print 0 *default-log-port* "Exiting now.")
+ (exit))))))
(define (tt:keep-running ttdat dbfname dbstruct)
- ;; verfiy conn for ready
- ;; listener socket has been started by this stage
- ;; wait for a port before creating the registration file
- ;;
- (let* ((db-locked-in #f)
- (areapath (tt-areapath ttdat))
- (nosyncdbpath (conc areapath"/.mtdb"))
- (cleanup (lambda ()
- (if (tt-cleanup-proc ttdat)
- ((tt-cleanup-proc ttdat)))
- (dbfile:with-no-sync-db nosyncdbpath
- (lambda (db)
- (let* ((dbtmpname (dbr:dbstruct-dbtmpname dbstruct)))
- (debug:print-info 0 *default-log-port* "Running clean up, including removing db file "dbtmpname)
- (db:no-sync-del! db dbfname)
- #;(if dbtmpname
- (delete-file dbtmpname))))))))
- (set! *server-info* ttdat)
- (let loop ((count 0))
- (if (> count 240)
- (begin
- (debug:print 0 *default-log-port* "FATAL: Could not start a tcp server, giving up.")
- (exit 1))
- (if (not (tt-port ttdat)) ;; no connection yet
- (begin
- (thread-sleep! 0.25)
- (loop (+ count 1))))))
-
- (tt:create-server-registration-file ttdat dbfname)
- ;; now start watching the last-access, if it hasn't been touched
- ;; in over ten seconds we exit
- (thread-sleep! 0.05) ;; any real need for delay here?
+
+ ;; at this point the server is running and responding to calls, we just monitor
+ ;; for db calls and exit if there are none.
+
+ ;; if I am not in the first 3 servers, exit
+ (let* ((start-time (current-seconds)))
(let loop ()
- (let* ((servers (tt:get-server-info-sorted ttdat dbfname))
- (ok (cond
- ((null? servers) #f) ;; not ok
- ((equal? (list-ref (car servers) 6) ;; compare the servinfofile
- (tt-servinf-file ttdat))
- (let* ((res (if db-locked-in
- #t
- (let* ((lock-result ;; this is the primary lock - need to double verify that got it
- (dbfile:with-no-sync-db
- nosyncdbpath
- (lambda (db)
- (db:no-sync-lock-and-check db dbfname
- (tt-servinf-file ttdat)
- ;; (dbr:dbstruct-dbtmpname dbstruct)
- ))))
- (success (car lock-result)))
- (if success
- (begin
- (tt-state-set! ttdat 'running)
- (debug:print 0 *default-log-port* "Got server lock for " dbfname)
- (set! db-locked-in #t)
- #t)
- (begin
- (debug:print 0 *default-log-port* "Failed to get server lock for "dbfname)
- #f))))))
- (if (and res (common:low-noise-print 120 "top server message"))
- (debug:print-info 0 *default-log-port* "Keep running, I'm the top server for "
- dbfname" on "(tt-host ttdat)":"(tt-port ttdat)))
- res))
- (else
- (debug:print-info 0 *default-log-port* "I'm not the lead server: "servers)
- (let* ((leadsrv (car servers)))
- (match leadsrv
- ((host port startseconds server-id pid dbfname servinfofile)
- (let* ((result (tt:timed-ping host port server-id))
- (res (car result))
- (ping (cdr result)))
- (debug:print-info 0 *default-log-port* "Ping to "host":"port", with server-id "server-id
- ", and file "servinfofile" returned "res)
- (if res
- #f ;; not the server, but all good, want to exit
- (if (and (file-exists? servinfofile)
- (> (- (current-seconds)(file-modification-time servinfofile)) 30))
- (begin
- ;; can't ping and file has been on disk 15 seconds, go ahead and try to remove it
- (debug:print-info 0 *default-log-port* "Removing apparently dead server info file: "servinfofile)
- (handle-exceptions
- exn
- (debug:print-info 0 *default-log-port* "Error removing server info file: "servinfofile)
- (delete-file* servinfofile)
- )
- #t) ;; not the server but the server is not reachable
- (begin
- (debug:print 0 *default-log-port* "I'm not the server but could not ping "host":"port", will try again.")
- (thread-sleep! 1) ;; just because
- #t)))))
- (else ;; should never get here
- (debug:print 0 *default-log-port* "BAD SERVER RECORD: "leadsrv)
- (assert #f "Bad server record "leadsrv))))))))
+ (let* ((servers (tt:get-server-info-sorted ttdat dbfname))
+ (home-host (if (null? servers)
+ #f
+ (caar servers)))
+ (my-index (list-index (lambda (x)
+ (equal? (list-ref x 6)
+ (tt-servinf-file ttdat)))
+ servers))
+ (ok (cond
+ ((not (number? my-index))
+ (debug:print 0 *default-log-port* "ERROR: bad server data in "servers", might be due to host misconfiguration such as bad IP address in /etc/hosts.")
+ #f)
+ ((not *server-run*)
+ (debug:print 0 *default-log-port* "WARNING: received a stop server from client by remote request.")
+ #f)
+ ((null? servers)
+ (debug:print 0 *default-log-port* "WARNING: no servinfo files found, this cannot be.")
+ #f) ;; not ok
+ ((> my-index 2)
+ (debug:print 0 *default-log-port* "WARNING: there are more than two servers ahead of me, I'm not needed, exiting.")
+ #f) ;; not ok to not be in first three
+ ((eq? (tt-state ttdat) 'running) #t) ;; we are good to keep going
+ ((> (- (current-seconds) start-time) 30)
+ (debug:print 0 *default-log-port* "WARNING: over 30 seconds and not yet in runnning mode. Exiting.")
+ #f)
+ (else #t))))
(if ok
(tt-last-access-set! ttdat *db-last-access*) ;; bit silly, just use db-last-access
(begin
(debug:print 0 *default-log-port* "Exiting immediately")
- (cleanup)
+ (tt:shutdown-server ttdat)
(exit)))
(let* ((last-update (dbr:dbstruct-last-update dbstruct))
(curr-secs (current-seconds)))
(if (and (eq? (tt-state ttdat) 'running)
- (> (- curr-secs last-update) 3)) ;; every 3-4 seconds update the db?
- (begin
- (set! (file-modification-time (tt-servinf-file ttdat)) (current-seconds))
+ (> (- curr-secs last-update) 5)) ;; every 5 seconds update the db?
+ (let* ((sinfo-file (tt-servinf-file ttdat)))
+ ;; (debug:print 0 *default-log-port* "INFO: touching "sinfo-file)
+ (set! (file-modification-time sinfo-file) (current-seconds))
((dbr:dbstruct-sync-proc dbstruct) last-update)
(dbr:dbstruct-last-update-set! dbstruct curr-secs))))
-
+
(if (< (- (current-seconds) (tt-last-access ttdat)) (tt-server-timeout-param))
(begin
(thread-sleep! 5)
(loop)))))
- (cleanup)
+ (tt:shutdown-server ttdat)
(debug:print 0 *default-log-port* "INFO: Server timed out, exiting from tt:keep-running.")))
-
-;; ;; given an already set up uconn start the cmd-loop
-;; ;;
-;; (define (tt:cmd-loop ttdat)
-;; (let* ((serv-listener (-socket uconn))
-;; (listener (lambda ()
-;; (let loop ((state 'start))
-;; (let-values (((inp oup)(tcp-accept serv-listener)))
-;; ;; (mutex-lock! *send-mutex*) ;; DOESN'T SEEM TO HELP
-;; (let* ((rdat (deserialize inp)) ;; '(my-host-port qrykey cmd params)
-;; (resp (ulex-handler uconn rdat)))
-;; (serialize resp oup)
-;; (close-input-port inp)
-;; (close-output-port oup)
-;; ;; (mutex-unlock! *send-mutex*) ;; DOESN'T SEEM TO HELP
-;; )
-;; (loop state))))))
-;; ;; start N of them
-;; (let loop ((thnum 0)
-;; (threads '()))
-;; (if (< thnum 100)
-;; (let* ((th (make-thread listener (conc "listener" thnum))))
-;; (thread-start! th)
-;; (loop (+ thnum 1)
-;; (cons th threads)))
-;; (map thread-join! threads)))))
-;;
-;;
-;;
-;; (define (wait-and-close uconn)
-;; (thread-join! (udat-cmd-thread uconn))
-;; (tcp-close (udat-socket uconn)))
-;;
-;;
(define (tt:shutdown-server ttdat)
- (let* ((cleanproc (tt-cleanup-proc ttdat))
- (port (tt-port ttdat)))
+ (let* ((host (tt-host ttdat))
+ (port (tt-port ttdat))
+ (sinf (tt-servinf-file ttdat)))
(tt-state-set! ttdat 'shutdown)
(portlogger:open-run-close portlogger:set-port port "released")
- (if cleanproc (cleanproc))
- (tcp-close (tt-socket ttdat)) ;; close up ports here
+ (if (file-exists? sinf)
+ (delete-file* sinf))
))
-;; (define (wait-and-close uconn)
-;; (thread-join! (tt-cmd-thread uconn))
-;; (tcp-close (tt-socket uconn)))
-
;; return servid
;; side-effects:
;; ttdat-cleanup-proc is populated with function to remove the serverinfo file
(define (tt:create-server-registration-file ttdat dbfname)
(let* ((areapath (tt-areapath ttdat))
(servdir (tt:get-servinfo-dir areapath))
(host (tt-host ttdat))
(port (tt-port ttdat))
(servinf (conc servdir"/"host":"port"-"(current-process-id)":"dbfname))
- (serv-id (tt:mk-signature areapath))
- (clean-proc (lambda ()
- (delete-file* servinf)
- )))
+ (serv-id (tt:mk-signature areapath)))
(assert (and host port) "FATAL: tt:create-server-registration-file called with no conn, dbfname="dbfname)
- (tt-cleanup-proc-set! ttdat clean-proc)
(tt-servinf-file-set! ttdat servinf)
(with-output-to-file servinf
(lambda ()
(print "SERVER STARTED: "host":"port" AT "(current-seconds)" server-id: "serv-id" pid: "(current-process-id)" dbfname: "dbfname)))
serv-id))
@@ -704,12 +711,28 @@
;; if more than one, wait one second and look again
;; future: ping oldest, if alive remove other : files
;;
(define (tt:find-server areapath dbfname)
(let* ((servdir (tt:get-servinfo-dir areapath))
- (sfiles (glob (conc servdir"/*:"dbfname))))
- sfiles))
+ (sfiles (glob (conc servdir"/*:"dbfname)))
+ (goodfiles '()))
+
+ ;; filter the files here by looking in processes table (if we are not main.db)
+ ;; and or look at the time stamp on the servinfo file, a running server will
+ ;; touch the file every minute (again, this will only apply for main.db)
+ (for-each (lambda (fname)
+ (let* ((age (- (current-seconds)(file-modification-time fname))))
+ (if (> age 200) ;; can't trust it if over 200 seconds old
+ (begin
+ (debug:print 0 *default-log-port* "WARNING: removing stale servinfo file "fname", it is "age" seconds old")
+ (handle-exceptions
+ exn
+ (debug:print 0 *default-log-port* "WARNING: error attempting to remove stale servinfo file "fname)
+ (delete-file fname))) ;;
+ (set! goodfiles (cons fname goodfiles)))))
+ sfiles)
+ goodfiles))
;; given a path to a server info file return: host port startseconds server-id pid dbfname logf
;; example of what it's looking for in the log file:
;; SERVER STARTED: 10.38.175.67:50216 AT 1616502350.0 server-id: 4907e90fc55c7a09694e3f658c639cf4
;;
@@ -719,12 +742,13 @@
(dbprep-found 0)
(bad-dat (list #f #f #f #f #f #f logf)))
(let ((fdat (handle-exceptions
exn
(begin
- ;; WARNING: this is potentially dangerous to blanket ignore the errors
- (debug:print-info 0 *default-log-port* "Unable to get server info from "logf", exn="(condition->list exn))
+ ;; BUG, TODO: add err checking, for now blanket ignore the errors?
+ (debug:print-info 0 *default-log-port* "Unable to get server info from "logf
+ ", exn="(condition->list exn))
'()) ;; no idea what went wrong, call it a bad server, return empty list
(with-input-from-file logf read-lines))))
(if (null? fdat) ;; bad data, return bad-dat
bad-dat
(let loop ((inl (car fdat))
@@ -750,10 +774,17 @@
logf))
(else
(debug:print 0 *default-log-port* "ERROR: did not recognise SERVER line info "mlst)
bad-dat)))))))))
+(define *last-server-start* (make-hash-table))
+
+(define (tt:too-recent-server-start dbfname)
+ (let* ((last-run-time (hash-table-ref/default *last-server-start* dbfname #f)))
+ (and last-run-time
+ (< (- (current-seconds) last-run-time) 5))))
+
;; Given an area path, start a server process ### NOTE ### > file 2>&1
;; if the target-host is set
;; try running on that host
;; incidental: rotate logs in logs/ dir.
;;
@@ -760,51 +791,63 @@
(define (tt:server-process-run areapath testsuite mtexe run-id #!key (profile-mode "")) ;; areapath is *toppath* for a given testsuite area
(assert areapath "FATAL: tt:server-process-run called without areapath defined.")
(assert testsuite "FATAL: tt:server-process-run called without testsuite defined.")
(assert mtexe "FATAL: tt:server-process-run called without mtexe defined.")
;; mtest -server - -m testsuite:ext-tests -db 6.db
- (let* ((dbfname (dbmod:run-id->dbfname run-id))
- (load (get-normalized-cpu-load))
- (trying (length (tt:find-server areapath dbfname)))
- (nrun (number-of-processes-running (conc "mtest.*server.*"testsuite".*"dbfname))))
- (cond
- ((> load 2.0)
- (debug:print 0 *default-log-port* "Normalized load "load" on " (get-host-name) " is over the limit of 2.0. Not starting a server.")
- (thread-sleep! 1))
- ((> nrun 100)
- (debug:print 0 *default-log-port* nrun" servers running on " (get-host-name) ", not starting another.")
- (thread-sleep! 1))
- ((> trying 4)
- (debug:print 0 *default-log-port* trying" servers registered in .servinfo dir. not starting another.")
- (thread-sleep! 1))
- (else
- (if (not (file-exists? (conc areapath"/logs")))
- (create-directory (conc areapath"/logs") #t))
- (let* ((logfile (conc areapath "/logs/server-"dbfname"-"(current-process-id)".log")) ;; -" curr-pid "-" target-host ".log"))
- (cmdln (conc
- mtexe
- " -startdir "areapath
- " -server - ";; (or target-host "-")
- " -m testsuite:"testsuite
- " -db "dbfname ;; (dbmod:run-id->dbfname run-id)
- " " profile-mode
- (conc " >> " logfile " 2>&1 &"))))
- ;; we want the remote server to start in *toppath* so push there
- ;; (push-directory areapath) ;; use cd in the command line instead
- (debug:print 0 *default-log-port* "INFO: Trying to start server in tcp mode (" cmdln ") at "(common:human-time)" for "areapath)
- ;; (debug:print 0 *default-log-port* "INFO: starting server at " (common:human-time))
-
- (system cmdln)
- ;; ;; use below to go back to nbfake - nbfake does cause trouble ...
- ;; (setenv "NBFAKE_QUIET" "yes") ;; BUG: change to with-environment-variable ...
- ;; (setenv "NBFAKE_LOG" logfile)
- ;; (system (conc "cd "areapath" ; nbfake " cmdln))
- ;; (unsetenv "NBFAKE_QUIET")
- ;; (unsetenv "NBFAKE_LOG")
-
- ;;(pop-directory)
- )))))
+ (let* ((dbfname (dbmod:run-id->dbfname run-id)))
+ (if (tt:too-recent-server-start dbfname)
+ #f
+ (let* ((load (get-normalized-cpu-load))
+ (srvrs (tt:find-server areapath dbfname))
+ (trying (length srvrs))
+ (nrun (number-of-processes-running (conc "mtest.*server.*"testsuite".*"dbfname))))
+ (cond
+ ((> load 2.0)
+ (debug:print 0 *default-log-port* "Normalized load "load" on " (get-host-name) " is over the limit of 2.0. Not starting a server. Please reduce the load on "(get-host-name)" by killing some processes")
+ (thread-sleep! 1)
+ #f)
+ ((> nrun 100)
+ (debug:print 0 *default-log-port* nrun" servers running on " (get-host-name) ", not starting another.")
+ (thread-sleep! 1)
+ #f)
+ ((> trying 2)
+ (debug:print 0 *default-log-port* trying" servers registered in .servinfo dir. not starting another.")
+ (thread-sleep! 1)
+ #f)
+ (else
+ (if (not (file-exists? (conc areapath"/logs")))
+ (create-directory (conc areapath"/logs") #t))
+ (let* ((logfile (conc areapath "/logs/server-"dbfname"-"(current-process-id)".log")) ;; -" curr-pid "-" target-host ".log"))
+ (cmdln (conc
+ mtexe
+ " -startdir "areapath
+ " -server - ";; (or target-host "-")
+ " -m testsuite:"testsuite
+ " -db "dbfname ;; (dbmod:run-id->dbfname run-id)
+ " " profile-mode
+ #;(conc " >> " logfile " 2>&1 &"))))
+ ;; we want the remote server to start in *toppath* so push there
+ ;; (push-directory areapath) ;; use cd in the command line instead
+ (debug:print 2 *default-log-port* "INFO: Trying to start server in tcp mode (" cmdln ") at "(common:human-time)" for "areapath)
+ ;; (debug:print 0 *default-log-port* "INFO: starting server at " (common:human-time))
+
+ (setenv "NBFAKE_QUIET" "yes") ;; BUG: change to with-environment-variable ...
+ (setenv "NBFAKE_LOG" logfile)
+ (system (conc "cd "areapath" ; nbfake " cmdln))
+ (unsetenv "NBFAKE_QUIET")
+ (unsetenv "NBFAKE_LOG")
+ ;; (system cmdln)
+ (hash-table-set! *last-server-start* dbfname (current-seconds))
+ ;; ;; use below to go back to nbfake - nbfake does cause trouble ...
+ ;; (setenv "NBFAKE_QUIET" "yes") ;; BUG: change to with-environment-variable ...
+ ;; (setenv "NBFAKE_LOG" logfile)
+ ;; (system (conc "cd "areapath" ; nbfake " cmdln))
+ ;; (unsetenv "NBFAKE_QUIET")
+ ;; (unsetenv "NBFAKE_LOG")
+
+ ;;(pop-directory)
+ #t)))))))
;;======================================================================
;; tcp connection stuff
;;======================================================================
@@ -868,18 +911,23 @@
;; (connect-listener uconn port)))
(define (setup-listener-portlogger uconn)
(let ((port (portlogger:open-run-close portlogger:find-port)))
(assert (tt? uconn) "FATAL: setup-listener called with wrong struct "uconn)
+ (debug:print 2 *default-log-port* "setup-listener-portlogger got port " port)
(handle-exceptions
exn
(if (< port 65535)
(begin
(portlogger:open-run-close portlogger:set-failed port)
(thread-sleep! 0.25)
(setup-listener-portlogger uconn))
- #f)
+ (begin
+ (debug:print 0 *default-log-port* "setup-listener-portlogger: could not get a port")
+ #f
+ )
+ )
(connect-listener uconn port))))
(define (connect-listener uconn port)
;; (tcp-listener-socket LISTENER)(socket-name so)
;; sockaddr-address, sockaddr-port, sockaddr->string
Index: tests.scm
==================================================================
--- tests.scm
+++ tests.scm
@@ -26,19 +26,25 @@
(declare (uses db))
(declare (uses tdb))
(declare (uses debugprint))
(declare (uses common))
(declare (uses commonmod))
+(declare (uses configf))
+(declare (uses configfmod))
(declare (uses items))
(declare (uses runconfig))
(declare (uses server))
(declare (uses mtargs))
(declare (uses rmtmod))
(use sqlite3 srfi-1 posix regex regex-case srfi-69 dot-locking directory-utils)
(import (prefix sqlite3 sqlite3:))
-(import commonmod (prefix mtargs args:) debugprint rmtmod)
+(import commonmod
+ configfmod
+ (prefix mtargs args:)
+ debugprint
+ rmtmod)
(require-library stml)
(include "common_records.scm")
(include "key_records.scm")
(include "db_records.scm")
@@ -1435,19 +1441,19 @@
(out-dir (db:test-get-rundir test-dat))
(status-file (conc out-dir "/.final-status"))
)
;; first verify we are able to write the output file
(if (not (file-write-access? out-dir))
- (debug:print 0 *default-log-port* "ERROR: cannot write .final-status to " out-dir)
- (let*
- ((outp (open-output-file status-file))
+ (debug:print 0 *default-log-port* "ERROR: cannot write .final-status to " out-dir)
+ (let* ((outp (open-output-file status-file))
(status (db:test-get-status test-dat))
- (state (db:test-get-state test-dat)))
- (fprintf outp "~S\n" state)
- (fprintf outp "~S\n" status)
- (close-output-port outp)))))
-
+ (state (db:test-get-state test-dat)))
+ (with-output-to-port outp
+ (lambda ()
+ (print state) ;; printf was putting in ", not sure why but that was a hassle in other contexts
+ (print status)))
+ (close-output-port outp)))))
;; summarize test in to a file test-summary.html in the test directory
;;
(define (tests:summarize-test run-id test-id)
(let* ((test-dat (rmt:get-test-info-by-id run-id test-id))
@@ -1964,11 +1970,12 @@
;; test steps
;;======================================================================
;; teststep-set-status! used to be here
-(define (test-get-kill-request run-id test-id) ;; run-id test-name itemdat)
+;; NOT NEEDED
+#;(define (test-get-kill-request run-id test-id) ;; run-id test-name itemdat)
(let* ((testdat (rmt:get-test-state-status-by-id run-id test-id)))
(and testdat
(equal? (car testdat) "KILLREQ"))))
(define (test:tdb-get-rundat-count tdb)
@@ -1993,11 +2000,11 @@
;; This one is for running with no db access (i.e. via rmt: internally)
(define (tests:set-full-meta-info db test-id run-id minutes work-area remtries)
;; (define (tests:set-full-meta-info test-id run-id minutes work-area)
;; (let ((remtries 10))
- (let* ((cpuload (get-cpu-load))
+ (let* ((cpuload (commonmod:get-cpu-load))
(diskfree (get-df (current-directory)))
(uname (get-uname "-srvpio"))
(hostname (get-host-name)))
(tests:update-central-meta-info run-id test-id cpuload diskfree minutes uname hostname)))
ADDED transport-mode.scm
Index: transport-mode.scm
==================================================================
--- /dev/null
+++ transport-mode.scm
@@ -0,0 +1,22 @@
+;;======================================================================
+;; set up transport, db cache and sync methods
+;;
+;; sync-method: 'original, 'attach or 'none
+;; cache-method: 'tmp 'none
+;; rmt:transport-mode: 'http, 'tcp, 'nfs
+;;
+;; NOTE: NOT ALL COMBINATIONS WORK
+;;
+;;======================================================================
+
+;; uncomment this block to test without tcp
+;; (dbfile:sync-method 'none)
+;; (dbfile:cache-method 'none)
+;; (rmt:transport-mode 'nfs)
+
+;; uncomment this block to test with tcp
+(dbfile:sync-method 'attach) ;; attach) ;; original
+(dbfile:cache-method 'tmp)
+(rmt:transport-mode 'tcp)
+
+
Index: utils/mt_xterm
==================================================================
--- utils/mt_xterm
+++ utils/mt_xterm
@@ -20,18 +20,16 @@
MT_TMPDISPLAY=$DISPLAY
MT_TMPUSER=$USER
MT_HOME=$HOME
tmpfile=`mktemp`
-
-grep -v "export USER=" megatest.sh | grep -v "export HOME=" > $tmpfile
-source $tmpfile
-rm $tmpfile
-
-# if [ -e megatest.sh ];then
-#source megatest.sh
-#fi
+if [[ -e megatest.sh ]]; then
+ grep -v "export USER=" megatest.sh | grep -v "export HOME=" > $tmpfile
+ source $tmpfile
+ rm $tmpfile
+fi
+
export DISPLAY=$MT_TMPDISPLAY
export USER=$USER
export HOME=$MT_HOME
if [ x"$MT_XTERM_CMD" == "x" ];then