Index: common.scm ================================================================== --- common.scm +++ common.scm @@ -527,11 +527,11 @@ (args:get-arg ":runname") (getenv "MT_RUNNAME")))) ;; (if res (set-environment-variable "MT_RUNNAME" res)) ;; not sure if this is a good idea. side effect and all ... res)) -(define (common:args-get-target #!key (split #f)) +(define (common:args-get-target #!key (split #f)(run-dat #f)) (let* ((keys (if (hash-table? *configdat*) (keys:config-get-fields *configdat*) '())) (numkeys (length keys)) (target (or (args:get-arg "-reqtarg") (args:get-arg "-target") (getenv "MT_TARGET"))) Index: db.scm ================================================================== --- db.scm +++ db.scm @@ -12,11 +12,11 @@ ;;====================================================================== ;; Database access ;;====================================================================== (require-extension (srfi 18) extras tcp) -(use sqlite3 srfi-1 posix regex regex-case srfi-69 csv-xml s11n md5 message-digest base64 format dot-locking z3) +(use sqlite3 srfi-1 posix regex regex-case srfi-69 csv-xml s11n md5 message-digest base64 format dot-locking z3 typed-records) (import (prefix sqlite3 sqlite3:)) (import (prefix base64 base64:)) (declare (unit db)) (declare (uses common)) @@ -75,18 +75,20 @@ (db:open-main dbstruct) (db:open-rundb dbstruct run-id) ))) dbdat)))) +(defstruct db:dbdat db path writeable) + (define (db:dbdat-get-db dbdat) - (if (pair? dbdat) - (car dbdat) + (if (db:dbdat? dbdat) + (db:dbdat-db dbdat) dbdat)) (define (db:dbdat-get-path dbdat) - (if (pair? dbdat) - (cdr dbdat) + (if (db:dbdat? dbdat) + (db:dbdat-path dbdat) #f)) ;; mod-read: ;; 'mod modified data ;; 'read read data @@ -169,11 +171,11 @@ (let ((syncprag (configf:lookup *configdat* "setup" "sychronous"))) (sqlite3:execute db (conc "PRAGMA synchronous = " (or syncprag 1) ";")))) ;; open an sql database inside a file lock ;; -;; returns: db existed-prior-to-opening +;; returns: db:dbdat record keyval keys target)) (linktree (or (getenv "MT_LINKTREE") (if *configdat* (configf:lookup *configdat* "setup" "linktree") #f))) @@ -797,35 +798,40 @@ (debug:print-error 0 *default-log-port* "No " mtconfig " file found. Giving up.") (exit 2)))))) ;; additional house keeping (let* ((linktree (or (getenv "MT_LINKTREE") (if *configdat* (configf:lookup *configdat* "setup" "linktree") #f)))) - (if linktree + (if (string? linktree) (begin - (if (not (file-exists? linktree)) + (if (and (not (file-exists? linktree)) + (file-write-access? (pathname-directory linktree))) (begin (handle-exceptions exn (begin (debug:print-error 0 *default-log-port* "Something went wrong when trying to create linktree dir at " linktree) (debug:print 0 *default-log-port* " message: " ((condition-property-accessor 'exn 'message) exn)) (exit 1)) (create-directory linktree #t)))) + ;; now create the lt link in MT_RUN_AREA_HOME (handle-exceptions exn (begin (debug:print-error 0 *default-log-port* "Something went wrong when trying to create link to linktree at " *toppath*) (debug:print 0 *default-log-port* " message: " ((condition-property-accessor 'exn 'message) exn))) (let ((tlink (conc *toppath* "/lt"))) (if (not (file-exists? tlink)) - (create-symbolic-link linktree tlink))))) + (if (file-write-access? *toppath*) + (create-symbolic-link linktree tlink)))))) (begin (debug:print-error 0 *default-log-port* "linktree not defined in [setup] section of megatest.config") ))) (if (and *toppath* (directory-exists? *toppath*)) - (setenv "MT_RUN_AREA_HOME" *toppath*) + (begin + (setenv "MT_RUN_AREA_HOME" *toppath*) + (setenv "MT_TESTSUITENAME" (common:get-testsuite-name))) (begin (debug:print-error 0 *default-log-port* "failed to find the top path to your Megatest area."))) *toppath*)) (define launch:setup launch:setup-new) Index: mt.scm ================================================================== --- mt.scm +++ mt.scm @@ -129,11 +129,13 @@ ;;====================================================================== ;; T R I G G E R S ;;====================================================================== (define (mt:process-triggers run-id test-id newstate newstatus) - (let* ((test-dat (rmt:get-test-info-by-id run-id test-id))) + (let* ((test-dat (rmt:get-test-info-by-id run-id test-id)) + (target (rmt:get-target run-id)) + (run-name (rmt:get-run-name-from-id run-id))) (if test-dat (let* ((test-rundir ;; (rmt:sdb-qry 'getstr ;; (filedb:get-path *fdb* (db:test-get-rundir test-dat)) ;; ) ;; ) (test-name (db:test-get-testname test-dat)) (tconfig #f) @@ -143,10 +145,12 @@ test-rundir ;; #f means no dir set yet (file-exists? test-rundir) (directory? test-rundir)) (call-with-environment-variables (list (cons "MT_TEST_NAME" test-name) + (cons "MT_RUNNAME" run-name) + (cons "MT_TARGET" target) (cons "MT_TEST_RUN_DIR" test-rundir) (cons "MT_ITEMPATH" (db:test-get-item-path test-dat))) (lambda () (push-directory test-rundir) (set! tconfig (mt:lazy-read-test-config test-name)) Index: runs.scm ================================================================== --- runs.scm +++ runs.scm @@ -86,10 +86,11 @@ (let ((runname (if inrunname inrunname (rmt:get-run-name-from-id run-id)))) (if runname (setenv "MT_RUNNAME" runname) (debug:print-error 0 *default-log-port* "no value for runname for id " run-id))) (setenv "MT_RUN_AREA_HOME" *toppath*) + (setenv "MT_TESTSUITENAME" (common:get-testsuite-name)) ;; if a testname and itempath are available set the remaining appropriate variables (if testname (setenv "MT_TEST_NAME" testname)) (if itempath (setenv "MT_ITEMPATH" itempath)) (if (and testname link-tree) (setenv "MT_TEST_RUN_DIR" (conc (getenv "MT_LINKTREE") "/" Index: tasks.scm ================================================================== --- tasks.scm +++ tasks.scm @@ -76,39 +76,44 @@ ;; ==> open in-mem version ;; (define (tasks:open-db #!key (numretries 4)) (if *task-db* *task-db* - (handle-exceptions - exn - (if (> numretries 0) - (begin - (print-call-chain (current-error-port)) - (debug:print 0 *default-log-port* " message: " ((condition-property-accessor 'exn 'message) exn)) - (debug:print 0 *default-log-port* " exn=" (condition->list exn)) - (thread-sleep! 1) - (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 0 *default-log-port* " exn=" (condition->list exn)))) - (let* ((dbpath (tasks:get-task-db-path)) - (dbfile (conc dbpath "/monitor.db")) + (let* ((dbpath (tasks:get-task-db-path)) + (dbfile (conc dbpath "/monitor.db"))) + (handle-exceptions + exn + ;; (if (> numretries 0) + (begin + (print-call-chain (current-error-port)) + (debug:print 0 *default-log-port* " message: " ((condition-property-accessor 'exn 'message) exn)) + (debug:print 0 *default-log-port* " exn=" (condition->list exn)) + (debug:print 0 *default-log-port* "ERROR: fatal problem accessing file: " dbfile) + (exit 1)) +;; (thread-sleep! 1) +;; (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 0 *default-log-port* " exn=" (condition->list exn)))) + (let* ( (avail (tasks:wait-on-journal dbpath 10)) ;; wait up to about 10 seconds for the journal to go away - (exists (file-exists? dbpath)) + (exists (file-exists? dbfile)) (write-access (file-write-access? dbpath)) - (mdb (cond ;; what the hek is *toppath* doing here? - ((and (string? *toppath*)(file-write-access? *toppath*)) - (sqlite3:open-database dbfile)) - ((file-read-access? dbpath) (sqlite3:open-database dbfile)) - (else (sqlite3:open-database ":memory:")))) ;; (never-give-up-open-db dbpath)) + (mdb (db:lock-create-open dbfile #f)) + (db (db:dbdat-db mdb)) + ;; (cond + ;; ;; if db exists and readable or directory writeable, open the real db + ;; ((or (and dbpath write-access)(and dbpath exists)) + ;; (sqlite3:open-database dbfile)) + ;; (else (sqlite3:open-database ":memory:")))) ;; (never-give-up-open-db dbpath)) (handler (make-busy-timeout 36000))) (if (and exists (not write-access)) (set! *db-write-access* write-access)) ;; only unset so other db's also can use this control - (sqlite3:set-busy-handler! mdb handler) - (db:set-sync mdb) ;; (sqlite3:execute mdb (conc "PRAGMA synchronous = 0;")) + (sqlite3:set-busy-handler! db handler) + (db:set-sync db) ;; (sqlite3:execute mdb (conc "PRAGMA synchronous = 0;")) ;; (if (or (and (not exists) ;; (file-write-access? *toppath*)) ;; (not (file-read-access? dbpath))) ;; (begin ;; @@ -123,18 +128,18 @@ ;; testpatt TEXT DEFAULT '', ;; keylock TEXT, ;; params TEXT, ;; creation_time TIMESTAMP, ;; execution_time TIMESTAMP);") - (sqlite3:execute mdb "CREATE TABLE IF NOT EXISTS monitors (id INTEGER PRIMARY KEY, + (sqlite3:execute db "CREATE TABLE IF NOT EXISTS monitors (id INTEGER PRIMARY KEY, pid INTEGER, start_time TIMESTAMP, last_update TIMESTAMP, hostname TEXT, username TEXT, CONSTRAINT monitors_constraint UNIQUE (pid,hostname));") - (sqlite3:execute mdb "CREATE TABLE IF NOT EXISTS servers (id INTEGER PRIMARY KEY, + (sqlite3:execute db "CREATE TABLE IF NOT EXISTS servers (id INTEGER PRIMARY KEY, pid INTEGER, interface TEXT, hostname TEXT, port INTEGER, pubport INTEGER, @@ -144,22 +149,22 @@ mt_version TEXT, heartbeat TIMESTAMP, transport TEXT, run_id INTEGER);") ;; CONSTRAINT servers_constraint UNIQUE (pid,hostname,port));") - (sqlite3:execute mdb "CREATE TABLE IF NOT EXISTS clients (id INTEGER PRIMARY KEY, + (sqlite3:execute db "CREATE TABLE IF NOT EXISTS clients (id INTEGER PRIMARY KEY, server_id INTEGER, pid INTEGER, hostname TEXT, cmdline TEXT, login_time TIMESTAMP, logout_time TIMESTAMP DEFAULT -1, CONSTRAINT clients_constraint UNIQUE (pid,hostname));") ;)) - (set! *task-db* (cons mdb dbpath)) - *task-db*)))) + (set! *task-db* mdb) ;; (db:dbdat(cons mdb dbpath)) + *task-db*))))) ;;====================================================================== ;; Server and client management ;;====================================================================== @@ -339,11 +344,11 @@ (tasks:get-server mdb run-id retries: (- retries 0))) (debug:print 0 *default-log-port* "10 tries of tasks:get-server all crashed and burned. Giving up and returning \"no server found\""))) (sqlite3:for-each-row (lambda (id interface port pubport transport pid hostname) (set! res (vector id interface port pubport transport pid hostname))) - mdb + (db:dbdat-db mdb) ;; removed: ;; strftime('%s','now')-heartbeat < 10 AND mt_version = ? "SELECT id,interface,port,pubport,transport,pid,hostname FROM servers WHERE run_id=? AND state='running' ORDER BY start_time DESC LIMIT 1;" run-id) ;; (common:version-signature) run-id) @@ -352,20 +357,20 @@ (define (tasks:server-running-or-starting? mdb run-id) (let ((res #f)) (sqlite3:for-each-row (lambda (id) (set! res id)) - mdb ;; NEEDS dbprep ADDED + (db:dbdat-db mdb) ;; NEEDS dbprep ADDED "SELECT id FROM servers WHERE run_id=? AND (state = 'running' OR (state = 'dbprep' AND (strftime('%s','now') - start_time) < 60));" run-id) res)) (define (tasks:server-running? mdb run-id) (let ((res #f)) (sqlite3:for-each-row (lambda (id) (set! res id)) - mdb ;; NEEDS dbprep ADDED + (db:dbdat-db mdb) ;; NEEDS dbprep ADDED "SELECT id FROM servers WHERE run_id=? AND state = 'running';" run-id) res)) (define (tasks:need-server run-id) (equal? (configf:lookup *configdat* "server" "required") "yes")) @@ -404,11 +409,11 @@ (let ((res '())) (sqlite3:for-each-row (lambda (id pid hostname interface port pubport start-time priority state mt-version last-update transport run-id) ;; 0 1 2 3 4 5 6 7 8 9 10 11 12 (set! res (cons (vector id pid hostname interface port pubport start-time priority state mt-version last-update transport run-id) res))) - mdb + (db:dbdat-db mdb) "SELECT id,pid,hostname,interface,port,pubport,start_time,priority,state,mt_version,strftime('%s','now')-heartbeat AS last_update,transport,run_id FROM servers WHERE state NOT LIKE 'defunct%' ORDER BY start_time DESC;") res)) (define (tasks:get-server-records mdb run-id) @@ -415,11 +420,11 @@ (let ((res '())) (sqlite3:for-each-row (lambda (id pid hostname interface port pubport start-time priority state mt-version last-update transport run-id) ;; 0 1 2 3 4 5 6 7 8 9 10 11 12 (set! res (cons (vector id pid hostname interface port pubport start-time priority state mt-version last-update transport run-id) res))) - mdb + (db:dbdat-db mdb) "SELECT id,pid,hostname,interface,port,pubport,start_time,priority,state,mt_version,strftime('%s','now')-heartbeat AS last_update,transport,run_id FROM servers WHERE run_id=? AND state NOT LIKE 'defunct%' ORDER BY start_time DESC;" run-id) (reverse res))) @@ -453,20 +458,21 @@ ;;====================================================================== ;; M O N I T O R S ;;====================================================================== (define (tasks:remove-monitor-record mdb) - (sqlite3:execute mdb "DELETE FROM monitors WHERE pid=? AND hostname=?;" + (sqlite3:execute (db:dbdat-db mdb) + "DELETE FROM monitors WHERE pid=? AND hostname=?;" (current-process-id) (get-host-name))) (define (tasks:get-monitors mdb) (let ((res '())) (sqlite3:for-each-row (lambda (a . rem) (set! res (cons (apply vector a rem) res))) - mdb + (db:dbdat-db mdb) "SELECT id,pid,strftime('%m/%d/%Y %H:%M',datetime(start_time,'unixepoch'),'localtime'),strftime('%m/%d/%Y %H:%M:%S',datetime(last_update,'unixepoch'),'localtime'),hostname,username FROM monitors ORDER BY last_update ASC;") (reverse res) )) (define (tasks:monitors->text-table monitors) @@ -485,21 +491,21 @@ "\n")))) ;; update the last_update field with the current time and ;; if any monitors appear dead, remove them (define (tasks:monitors-update mdb) - (sqlite3:execute mdb "UPDATE monitors SET last_update=strftime('%s','now') WHERE pid=? AND hostname=?;" + (sqlite3:execute (db:dbdat-db mdb) "UPDATE monitors SET last_update=strftime('%s','now') WHERE pid=? AND hostname=?;" (current-process-id) (get-host-name)) (let ((deadlist '())) (sqlite3:for-each-row (lambda (id pid host last-update delta) (print "Going to delete stale record for monitor with pid " pid " on host " host " last updated " delta " seconds ago") (set! deadlist (cons id deadlist))) - mdb + (db:dbdat-db mdb) "SELECT id,pid,hostname,last_update,strftime('%s','now')-last_update AS delta FROM monitors WHERE delta > 700;") - (sqlite3:execute mdb (conc "DELETE FROM monitors WHERE id IN ('" (string-intersperse (map conc deadlist) "','") "');"))) + (sqlite3:execute (db:dbdat-db mdb) (conc "DELETE FROM monitors WHERE id IN ('" (string-intersperse (map conc deadlist) "','") "');"))) ) (define (tasks:register-monitor db port) (let* ((pid (current-process-id)) (hostname (get-host-name)) (userinfo (user-information (current-user-id))) @@ -511,11 +517,11 @@ (define (tasks:get-num-alive-monitors mdb) (let ((res 0)) (sqlite3:for-each-row (lambda (count) (set! res count)) - mdb + (db:dbdat-db mdb) "SELECT count(id) FROM monitors WHERE last_update < (strftime('%s','now') - 300) AND username=?;" (car (user-information (current-user-id)))) res)) ;;