Index: api.scm ================================================================== --- api.scm +++ api.scm @@ -403,10 +403,16 @@ ;; NO SYNC DB ((no-sync-set) (apply db:no-sync-set *no-sync-db* params)) ((no-sync-get/default) (apply db:no-sync-get/default *no-sync-db* params)) ((no-sync-del!) (apply db:no-sync-del! *no-sync-db* params)) ((no-sync-get-lock) (apply db:no-sync-get-lock *no-sync-db* params)) + + ;; NO SYNC DB PROCESSES + ((register-process) (apply dbfile:register-process *no-sync-db* params)) + ((set-process-done) (apply dbfile:set-process-done *no-sync-db* params)) + ((set-process-status) (apply dbfile:set-process-status *no-sync-db* params)) + ((get-process-options) (apply dbfile:get-process-options *no-sync-db* params)) ;; ARCHIVES ;; ((archive-get-allocations) ((archive-register-disk) (apply db:archive-register-disk dbstruct params)) ((archive-register-block-name)(apply db:archive-register-block-name dbstruct params)) Index: dbfile.scm ================================================================== --- dbfile.scm +++ dbfile.scm @@ -16,11 +16,11 @@ ;; You should have received a copy of the GNU General Public License ;; along with Megatest. If not, see . ;;====================================================================== -(use srfi-18) +(use srfi-18 posix hostinfo) (declare (unit dbfile)) (declare (uses debugprint)) (declare (uses commonmod)) @@ -32,18 +32,19 @@ data-structures extras matchable (prefix sqlite3 sqlite3:) - posix typed-records + posix posix-extras typed-records srfi-18 srfi-1 srfi-69 stack files ports + hostinfo commonmod debugprint ) @@ -121,10 +122,29 @@ (define-record simple-run target id runname state status owner event_time) (define-record-printer (simple-run x out) (fprintf out "#,(simple-run ~S ~S ~S ~S)" (simple-run-target x) (simple-run-id x) (simple-run-runname x) (time->string (seconds->local-time (simple-run-event_time x) )))) +;; megatest process tracking + +(defstruct pinf + (start (current-seconds)) + (host (get-host-name)) ;; why is this not being recognised? + (pid (current-process-id)) + (port #f) + (cwd (current-directory)) + (load #f) + (purpose #f) ;; get-purpose needed + (dbname #f) + (mtbin (car (argv))) + (mtversion #f) + (status "running") + + + ) + +(define *pinf* (make-pinf)) (define *dbstruct-dbs* #f) (define *db-open-mutex* (make-mutex)) (define *db-access-mutex* (make-mutex)) ;; used in common.scm (define *no-sync-db* #f) (define *db-sync-in-progress* #f) @@ -465,11 +485,25 @@ val TEXT, CONSTRAINT no_sync_metadat_constraint UNIQUE (var));" "CREATE TABLE IF NOT EXISTS no_sync_locks (key TEXT, val TEXT, - CONSTRAINT no_sync_metadat_constraint UNIQUE (key));")))))) + CONSTRAINT no_sync_metadat_constraint UNIQUE (key));" + "CREATE TABLE IF NOT EXISTS processes + (id INTEGER PRIMARY KEY, + host TEXT, + port INTEGER, + pid INTEGER, + starttime INTEGER, + endtime INTEGER, + status TEXT, + purpose TEXT, + dbname TEXT, + mtversion TEXT, + 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") (dbfile:cautious-open-database dbname init-proc 0 #f) ;; (sqlite3:open-database dbname) @@ -477,10 +511,85 @@ (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)))) db)) + +;; mtest processes registry calls + +(define (dbfile:insert-or-update-process nsdb dat) + (let* ((host (pinf-host dat)) + (pid (pinf-pid dat)) + (curr-info (dbfile:get-process-info nsdb host pid))) + (if curr-info ;; record exists, do update + (match curr-info + ((host port pid starttime status purpose dbname mtversion) + (sqlite3:execute + nsdb + "UPDATE processes SET port=?,starttime=?,status=?, + purpose=?,dbname=?,mtversion=? + WHERE host=? AND pid=?;" + (or (pinf-port dat) port) + (or (pinf-start dat) starttime) + (or (pinf-status dat) status) + (or (pinf-purpose dat) purpose) + (or (pinf-dbname dat) dbname) + (or (pinf-mtversion dat) mtversion) + host pid)) + (else + #f ;; what to do? + )) + (dbfile:register-process + nsdb + (pinf-host dat) + (pinf-port dat) + (pinf-pid dat) + (pinf-start dat) + (pinf-status dat) + (pinf-purpose dat) + (pinf-dbname dat) + (pinf-mtversion dat))))) + + +(define (dbfile:register-process nsdb host port pid starttime status purpose dbname mtversion) + (sqlite3:execute nsdb "INSERT INTO processes (host,port,pid,starttime,status,purpose,dbname,mtversion) VALUES (?,?,?,?,?,?,?,?);" + host port pid starttime 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)) + +(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,status,mtversion FROM processes WHERE purpose=? AND dbname LIKE ? AND status='alive';" + purpose dbname)) + +(define (dbfile:get-process-info nsdb host pid) + (let ((res (sqlite3:fold-row + ;; host port pid starttime status mtversion + (lambda (res . row) + (cons row res)) + '() + nsdb + "SELECT (host,port,pid,starttime,status,purpose,dbname,mtversionn FROM processes WHERE host=? AND pid=?;" + host pid))) + (if (null? res) + #f + (car res)))) + +(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) + (dbfile:cleanup-old-entries nsdb)) + +(define (dbfile:cleanup-old-entries nsdb) + (sqlite3:execute nsdb "DELETE FROM process WHERE status='ended' AND endtime