Index: dbmod.scm ================================================================== --- dbmod.scm +++ dbmod.scm @@ -51,10 +51,11 @@ chicken.process-context.posix chicken.sort chicken.string chicken.time chicken.time.posix + system-information (prefix base64 base64:) csv-xml directory-utils matchable @@ -94,60 +95,62 @@ (dbdats (make-hash-table)) ;; id => dbdat (read-only #f) ;; the area is read-only (stmt-cache (make-hash-table))) (defstruct dbr:dbdat - (db #f) + (db #f) ;; should rename this to oddb for on disk db (inmem #f) (last-sync 0) (last-write (current-seconds)) (run-id #f) (fname #f)) ;; Returns the dbdat for a particular run-id from dbstruct ;; (define (dbr:dbstruct-get-dbdat v run-id) - (hash-table-ref/default (dbr:dbstruct-dbs v) run-id #f)) + (hash-table-ref/default (dbr:dbstruct-dbdats v) run-id #f)) (define (dbr:dbstruct-dbdat-put! v run-id db) - (hash-table-set! (dbr:dbstruct-dbs v) run-id db)) + (hash-table-set! (dbr:dbstruct-dbdats v) run-id db)) (define (db:run-id->first-num run-id) (let* ((s (number->string run-id)) (l (string-length s))) (substring s (- l 1) l))) +;; 1234 => 4/1234.db +;; #f => 0/main.db +;; (define (db:run-id->path run-id) - (let ((firstnum (db:run-id->first-num run-id))) - (conc *toppath* "/.dbs/"firstnum"/"run-id".db"))) + (let ((firstnum (if run-id + (db:run-id->first-num run-id) + "0"))) + (conc *toppath* "/.dbs/"firstnum"/"(or run-id "main")".db"))) ;; record for keeping state,status and count for doing roll-ups in ;; iterated tests ;; (defstruct dbr:counts (state #f) (status #f) (count 0)) -;; Retrieve a db handle for inmemory db given run-id, open and setup both inmemory and +;; Retrieve a dbdat given run-id, open and setup both inmemory and ;; db file if needed ;; ;; if run-id => get run specific db ;; if #f => get main.db ;; if db already open - return inmem ;; if db not open, open inmem, rundb and sync then return inmem ;; inuse gets set automatically for rundb's ;; (define (db:get-dbdat dbstruct run-id) - (let* ((dbfile (db:run-id->path run-id)) - (dbdat (dbr:dbstruct-get-dbdat dbstruct run-id)) - (newdbdat (if dbdat - #f - (db:open-dbdat run-id db:setup-schema)))) + (let ((dbdat (dbr:dbstruct-get-dbdat dbstruct run-id))) (if dbdat dbdat - (begin + (let* ((dbfile (db:run-id->path run-id)) + (newdbdat (db:open-dbdat run-id db:initialize-db))) (dbr:dbstruct-dbdat-put! dbstruct newdbdat) newdbdat)))) ;; get the inmem db for actual db operations ;; @@ -154,11 +157,11 @@ (define (db:get-inmem dbstruct run-id) (dbr:dbdat-inmem (db:get-dbdat dbstruct run-id))) ;; get the handle for the on-disk db ;; -(define (db:get-db dbstruct run-id) +(define (db:get-ddb dbstruct run-id) (dbr:dbdat-db (db:get-dbdat dbstruct run-id))) ;; open or create the disk db file ;; create and fill the inmemory db ;; assemble into dbr:dbdat struct and return @@ -165,43 +168,94 @@ ;; (define (db:open-dbdat run-id dbinit-proc) (let* ((dbfile (db:run-id->path run-id)) (db (db:open-run-db dbfile dbinit-proc)) (inmem (db:open-inmem-db dbinit-proc)) - (dbdat (dbr:dbdat-make + (dbdat (make-dbr:dbdat db: db inmem: inmem run-id: run-id fname: dbfile))) ;; now sync the disk file data into the inmemory db (db:sync-tables (db:sync-all-tables-list) #f db inmem) dbdat)) - + ;; open the disk database file ;; NOTE: May need to add locking to file create process here ;; returns an sqlite3 database handle ;; (define (db:open-run-db dbfile dbinit-proc) - (let* ((exists (file-exists? dbfile)) - (db (sqlite3:open-database dbfile)) - (handler (make-busy-timeout 3600))) - (sqlite3:set-busy-handler! db handler) - (db:set-sync db) - (if (not exists) - (dbinit-proc db)) - db)) + (let* ((parent-dir (pathname-directory dbfile))) + (if (not (directory-exists? parent-dir)) + (create-directory parent-dir #t)) + (let* ((exists (file-exists? dbfile)) + (db (sqlite3:open-database dbfile)) + (handler (sqlite3:make-busy-timeout 3600))) + (sqlite3:set-busy-handler! db handler) + (db:set-sync db) + (if (not exists) + (dbinit-proc db)) + db))) ;; open and initialize the inmem db ;; NOTE: Does NOT sync in the data from the disk db ;; -(define (db:open-inmem-db) +(define (db:open-inmem-db dbinit-proc) (let* ((db (sqlite3:open-database ":memory:")) - (handler (make-busy-timeout 3600))) + (handler (sqlite3:make-busy-timeout 3600))) (sqlite3:set-busy-handler! db handler) - (db:initialize-run-id-db db) + (dbinit-proc db) ;; NOTE: inmem must always be initialized (db:initialize-db db) db)) +;; get and initalize dbstruct for a given run-id +;; +;; - uses db:initialize-db to create the schema +;; +;; Make the dbstruct, call for main db at least once +;; sync disk db to inmem +;; +;; called in http-transport and replicated in rmt.scm for *local* access. +;; +(define (db:setup run-id) + (assert *toppath* "FATAL: db:setup called before toppath is available.") + (let* ((dbstruct (make-dbr:dbstruct))) + (db:get-dbdat dbstruct run-id) + (set! *dbstruct-db* dbstruct) + dbstruct)) + +;;====================================================================== +;; setting/getting a lock on the db for only one server per db +;; +;; NOTE: +;; These operate directly on the disk file, NOT on the inmemory db +;; The lockname is the filename (can have many to one, run-id to fname +;;====================================================================== + +(define (db:get-iam-server-lock dbstruct run-id) + (let* ((dbh (db:get-ddb dbstruct run-id)) + (dbfname (db:run-id->path run-id))) + (sqlite3:with-transaction + dbh + (lambda () + (let* ((locked (db:get-locker dbh dbfname))) + (if (not locked) + (db:take-lock dbh dbfname))))))) + +;; (exn sqlite3) +(define (db:get-locker dbh dbfname) + (condition-case + (sqlite3:first-row dbh "SELECT owner_id,owner_host,event_time FROM locks WHERE lockname=%;" dbfname) + (exn (sqlite3) #f))) + +(define (db:take-lock dbh dbfname) + (condition-case + (sqlite3:first-row dbh "INSERT INTO locks lockname,owner_id,owner_host VALUES (?,?,?);" dbfname (current-process-id) (get-host-name)) + (exn (sqlite3) #f))) + +(define (db:release-lock dbh dbfname) + (sqlite3:execute dbh "DELETE FROM locks WHERE lockname=?;" dbfname)) + ;;====================================================================== ;; SQLITE3 HELPERS ;;====================================================================== (define (db:general-sqlite-error-dump exn stmt . params) @@ -238,13 +292,13 @@ ;; (db:with-db dbstruct run-id sqlite3:exec "select blah fgrom blaz;") ;; r/w is a flag to indicate if the db is modified by this query #t = yes, #f = no ;; (define (db:with-db dbstruct run-id r/w proc . params) (assert (dbr:dbstruct? dbstruct) "FATAL: db:with-db called with bad dbstruct") - (let* ((dbdat (db:get-dbdat dbstruct)) + (let* ((dbdat (db:get-dbdat dbstruct run-id)) (db (dbr:dbdat-inmem dbdat)) - (fname (db:dbdat-fname dbdat)) + (fname (dbr:dbdat-fname dbdat)) (use-mutex (> *api-process-request-count* 25))) ;; was 25 (if (and use-mutex (common:low-noise-print 120 "over-50-parallel-api-requests")) (debug:print-info 0 *default-log-port* *api-process-request-count* " parallel api requests being processed in process " (current-process-id) ", throttling access")) (if (common:low-noise-print 600 (conc "parallel-api-requests" *max-api-process-requests*)) @@ -253,11 +307,10 @@ (begin (if use-mutex (mutex-lock! *db-with-db-mutex*)) (let ((res (apply proc db params))) (if use-mutex (mutex-unlock! *db-with-db-mutex*)) ;; (if (vector? dbstruct)(db:done-with dbstruct run-id r/w)) - (if dbdat (stack-push! (dbr:dbstruct-dbstack dbstruct) dbdat)) res)) (exn (io-error) (db:generic-error-printout exn "ERROR: i/o error with " fname ". Check permissions, disk space etc. and try again.")) (exn (corrupt) (db:generic-error-printout exn "ERROR: database " fname " is corrupt. Repair it to proceed.")) @@ -284,28 +337,30 @@ (set! last-update-time lup)) db "select max(lup) from ( select max(last_update) as lup from tests union select max(last_update) as lup from runs);") last-update-time)) -;; NOTE: opens the legacy megatest.db at the top of *toppath* +;; NOTE: opens the legacy megatest.db at the top of *toppath* ==> deprecate and use export +;; from previous version instead ;; ;; - NOT ready for use ;; -(define (db:open-legacy-megatest-db fname) - (let* ((dbexists (if (equal? fname ":inmem:") - #f - (common:file-exists? dbpath))) - (db (db:lock-create-open dbpath - (lambda (db) - (db:initialize-main-db db) - ;;(db:initialize-run-id-db db) - ))) - (write-access (file-writable? dbpath))) - (debug:print-info 13 *default-log-port* "db:open-megatest-db "dbpath) - (if (and dbexists (not write-access)) - (set! *db-write-access* #f)) - (cons db dbpath))) +;; ;; (define (db:open-legacy-megatest-db fname) +;; ;; (let* ((dbexists (if (equal? fname ":inmem:") +;; ;; #f +;; ;; (common:file-exists? dbpath))) +;; ;; ;; TODO, replace use of lock with a transaction around the db initalization +;; ;; (db (db:initialize-main-db db) #;(db:lock-create-open dbpath +;; ;; (lambda (db) +;; ;; (db:initialize-main-db db) +;; ;; ;;(db:initialize-run-id-db db) +;; ;; ))) +;; ;; (write-access (file-writable? dbpath))) +;; ;; (debug:print-info 13 *default-log-port* "db:open-megatest-db "dbpath) +;; ;; (if (and dbexists (not write-access)) +;; ;; (set! *db-write-access* #f)) +;; ;; (cons db dbpath))) ;; ;; ;; sync run to disk if touched ;; ;; ;; ;; ;; (define (db:sync-touched dbstruct run-id #!key (force-sync #f)) ;; ;; (let ((tmpdb (db:get-db dbstruct)) @@ -325,25 +380,26 @@ ;; NOTE: touched logic is disabled/not done ;; sync run to disk if touched ;; (define (db:sync-inmem->disk dbstruct run-id #!key (force-sync #f)) - (let ((dbdat (db:get-dbdat dbstruct run-id)) - (db (dbr:dbdat-db dbstruct)) - (inmem (dbr:dbdat-inmem dbstruct)) - (start-t (current-seconds))) + (let* ((dbdat (db:get-dbdat dbstruct run-id)) + (db (dbr:dbdat-db dbstruct)) + (inmem (dbr:dbdat-inmem dbstruct)) + (start-t (current-seconds)) + (last-update (dbr:dbdat-last-write dbdat)) + (last-sync (dbr:dbdat-last-sync dbdat))) (debug:print-info 4 *default-log-port* "Syncing for run-id: " run-id) (mutex-lock! *db-multi-sync-mutex*) - ;; (let* ((update_info (cons (if force-sync 0 *db-last-sync*) "last_update")) - ;; (need-sync (or force-sync (>= last_update (dbr:dbdat-last-write dbdat))))) - ;; (mutex-unlock! *db-multi-sync-mutex*) - (if #t ;; need-sync - (db:sync-tables (db:sync-all-tables-list) update_info inmem db) - (debug:print 0 *default-log-port* "Skipping sync as nothing touched.")) + (let* ((update_info (cons (if force-sync 0 last-update) "last_update")) + (need-sync (or force-sync (>= last-update last-sync)))) + (mutex-unlock! *db-multi-sync-mutex*) + (if need-sync + (db:sync-tables (db:sync-all-tables-list) update_info inmem db) + (debug:print 0 *default-log-port* "Skipping sync as nothing touched."))) (mutex-lock! *db-multi-sync-mutex*) (dbr:dbdat-last-sync-set! dbdat start-t) - (dbr:dbdat-last-write-set! dbdat start-t) (mutex-unlock! *db-multi-sync-mutex*))) (define (db:safely-close-sqlite3-db db stmt-cache #!key (try-num 3)) (if (<= try-num 0) @@ -369,11 +425,11 @@ exn (begin (debug:print 0 *default-log-port* "WARNING: Finalizing failed, " ((condition-property-accessor 'exn 'message) exn) ", note - exn=" exn) (print-call-chain *default-log-port*)) ;; (db:sync-touched dbstruct 0 force-sync: #t) ;; NO. Do not do this here. Instead we rely on a server to be started when there are writes, even if the server itself is not going to be used as a server. - (let ((tdbs (map db:dbdat-db + (let ((tdbs (map dbr:dbdat-db (hash-table-values (dbr:dbstruct-dbdats dbstruct)))) (stmt-cache (dbr:dbstruct-stmt-cache dbstruct))) (map (lambda (db) (db:safely-close-sqlite3-db db stmt-cache)) tdbs)))) @@ -479,11 +535,11 @@ db:sync-tests-only)) ;; use bunch of Unix commands to try to break the lock and recreate the db ;; (define (db:move-and-recreate-db dbdat) - (let* ((dbpath (db:dbdat-get-path dbdat)) + (let* ((dbpath (dbr:dbdat-fname dbdat)) (dbdir (pathname-directory dbpath)) (fname (pathname-strip-directory dbpath)) (fnamejnl (conc fname "-journal")) (tmpname (conc fname "." (current-process-id))) (tmpjnl (conc fnamejnl "." (current-process-id)))) @@ -500,11 +556,11 @@ ;; return #f to indicate the dbdat should be closed/reopened ;; else return dbdat ;; (define (db:repair-db dbdat #!key (numtries 1)) - (let* ((dbpath (db:dbdat-get-path dbdat)) + (let* ((dbpath (dbr:dbdat-fname dbdat)) (dbdir (pathname-directory dbpath)) (fname (pathname-strip-directory dbpath))) (debug:print-info 0 *default-log-port* "Checking db " dbpath " for errors.") (cond ((not (file-writable? dbdir)) @@ -554,11 +610,11 @@ (sqlite3:finalize! db) #t)))))) ;; tbls is ( ("tablename" ( "field1" [#f|proc1] ) ( "field2" [#f|proc2] ) .... ) ) -;; db's are sqlite3 handles +;; db's are dbdats ;; ;; if last-update specified ("field-name" . time-in-seconds) ;; then sync only records where field-name >= time-in-seconds ;; IFF field-name exists ;; @@ -569,13 +625,13 @@ (debug:print 0 *default-log-port* "EXCEPTION: database probably overloaded or unreadable in db:sync-tables.") (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)) (debug:print 0 *default-log-port* " status: " ((condition-property-accessor 'sqlite3 'status) exn)) - (debug:print 0 *default-log-port* " src db: " (db:dbdat-get-path fromdb)) + (debug:print 0 *default-log-port* " src db: " (dbr:dbdat-fname fromdb)) (for-each (lambda (dbdat) - (let ((dbpath (db:dbdat-get-path dbdat))) + (let ((dbpath (dbr:dbdat-fname dbdat))) (debug:print 0 *default-log-port* " dbpath: " dbpath) (if (not (db:repair-db dbdat)) (begin (debug:print-error 0 *default-log-port* "Failed to rebuild " dbpath ", exiting now.") (exit))))) @@ -587,23 +643,23 @@ -1) ((not todb) (debug:print 3 *default-log-port* "WARNING: db:sync-tables called with todb missing") -2) #;((or (not (file-exists? fromdb))(not (file-exists? todb))) (debug:print-info 0 *default-log-port* "db:sync-tables called but db files do not exist.") 0) - ((not (sqlite3:database? (db:dbdat-db fromdb))) + ((not (sqlite3:database? (dbr:dbdat-db fromdb))) (debug:print-error 0 *default-log-port* "db:sync-tables called with fromdb not a database " fromdb) -3) - ((not (sqlite3:database? (db:dbdat-db todb))) + ((not (sqlite3:database? (dbr:dbdat-db todb))) (debug:print-error 0 *default-log-port* "db:sync-tables called with todb not a database " todb) -4) - ((not (file-writable? (db:dbdat-get-path todb))) + ((not (file-writable? (dbr:dbdat-fname todb))) (debug:print-error 0 *default-log-port* "db:sync-tables called with todb not a read-only database " todb) -5) ((not (null? (let ((readonly-slave-dbs (filter (lambda (dbdat) - (not (file-writable? (db:dbdat-get-path todb)))) + (not (file-writable? (dbr:dbdat-fname todb)))) slave-dbs))) (for-each (lambda (bad-dbdat) (debug:print-error 0 *default-log-port* "db:sync-tables called with todb not a read-only database " bad-dbdat)) @@ -678,11 +734,11 @@ (if (> (length fromdat) batch-len) (begin (set! fromdats (cons fromdat fromdats)) (set! fromdat '()) (set! totrecords (+ totrecords 1))))) - (db:dbdat-get-db fromdb) + (dbr:dbdat-db fromdb) full-sel) ;; tack on remaining records in fromdat (if (not (null? fromdat)) (set! fromdats (cons fromdat fromdats))) @@ -692,11 +748,11 @@ ;; read the target table; BBHERE (sqlite3:for-each-row (lambda (a . b) (hash-table-set! todat a (apply vector a b))) - (db:dbdat-get-db todb) + (dbr:dbdat-db todb) full-sel) (when (and delay-handicap (> delay-handicap 0)) (debug:print-info 0 *default-log-port* "imposing synthetic sync delay of "delay-handicap" seconds since sync/delay-handicap is configured") (thread-sleep! delay-handicap) @@ -704,11 +760,11 @@ ) ;; first pass implementation, just insert all changed rows (for-each (lambda (targdb) - (let* ((db (db:dbdat-get-db targdb)) + (let* ((db (dbr:dbdat-db targdb)) (drp-trigger (if (member "last_update" field-names) (db:drop-trigger db tablename) #f)) (is-trigger-dropped (if (member "last_update" field-names) (db:is-trigger-dropped db tablename) @@ -1188,20 +1244,18 @@ (if (equal? (car key) trigger-name) (sqlite3:execute db (cadr key)))) db:trigger-list))) -(define (db:initialize-main-db dbdat) - (assert *configinfo* "ERROR: db:initialize-main-db called before configfiles loaded. This is fatal.") - #;(when (not *configinfo*) - (launch:setup)) ;; added because Elena was getting stack dump because *configinfo* below was #f. +(define (db:initialize-db dbdat) + (assert *configinfo* "ERROR: db:initialize-db called before configfiles loaded. This is fatal.") (let* ((configdat (car *configinfo*)) ;; tut tut, global warning... (keys (keys:config-get-fields configdat)) (havekeys (> (length keys) 0)) (keystr (keys->keystr keys)) (fieldstr (keys:make-key/field-string configdat)) - (db (db:dbdat-get-db dbdat))) + (db (dbr:dbdat-db dbdat))) (for-each (lambda (key) (let ((keyn key)) (if (member (string-downcase keyn) (list "runname" "state" "status" "owner" "event_time" "comment" "fail_count" "pass_count" "contour")) @@ -1210,21 +1264,30 @@ (exit 1))))) keys) (sqlite3:with-transaction db (lambda () - ;; handle-exceptions - ;; exn - ;; (begin - ;; (debug:print 0 "ERROR: Failed to create tables. Look at your [fields] section, should be: fieldname TEXT DEFAULT 'yourdefault'") - ;; (exit)) - (sqlite3:execute db "CREATE TABLE IF NOT EXISTS keys (id INTEGER PRIMARY KEY, fieldname TEXT, fieldtype TEXT, CONSTRAINT keyconstraint UNIQUE (fieldname));") - (for-each (lambda (key) - (sqlite3:execute db "INSERT OR REPLACE INTO keys (fieldname,fieldtype) VALUES (?,?);" key "TEXT")) - keys) - (sqlite3:execute db (conc - "CREATE TABLE IF NOT EXISTS runs (id INTEGER PRIMARY KEY, \n " + (sqlite3:execute db "CREATE TABLE IF NOT EXISTS locks + (id INTEGER PRIMARY KEY, + lockname TEXT, + owner_pid INTEGER, + owner_host TEXT, + event_time TIMESTAMP DEFAULT (strftime('%s','now')), + CONSTRAINT lock_constraint UNIQUE (lockname));") + + (sqlite3:execute db "CREATE TABLE IF NOT EXISTS keys + (id INTEGER PRIMARY KEY, + fieldname TEXT, + fieldtype TEXT, + CONSTRAINT keyconstraint UNIQUE (fieldname));") + + (for-each (lambda (key) + (sqlite3:execute db "INSERT OR REPLACE INTO keys (fieldname,fieldtype) VALUES (?,?);" key "TEXT")) + keys) + + (sqlite3:execute db (conc + "CREATE TABLE IF NOT EXISTS runs (id INTEGER PRIMARY KEY, \n " fieldstr (if havekeys "," "") " runname TEXT DEFAULT 'norun', contour TEXT DEFAULT '', state TEXT DEFAULT '', status TEXT DEFAULT '', @@ -1233,31 +1296,18 @@ comment TEXT DEFAULT '', fail_count INTEGER DEFAULT 0, pass_count INTEGER DEFAULT 0, last_update INTEGER DEFAULT (strftime('%s','now')), CONSTRAINT runsconstraint UNIQUE (runname" (if havekeys "," "") keystr "));")) - ;; All triggers created at once in end - ;;(sqlite3:execute db "CREATE TRIGGER IF NOT EXISTS update_runs_trigger AFTER UPDATE ON runs - ;; FOR EACH ROW - ;; BEGIN - ;; UPDATE runs SET last_update=(strftime('%s','now')) - ;; WHERE id=old.id; - ;; END;") + (sqlite3:execute db "CREATE TABLE IF NOT EXISTS run_stats ( id INTEGER PRIMARY KEY, run_id INTEGER, state TEXT, status TEXT, count INTEGER, last_update INTEGER DEFAULT (strftime('%s','now')))") - ;; All triggers created at once in end - ;; (sqlite3:execute db "CREATE TRIGGER IF NOT EXISTS update_run_stats_trigger AFTER UPDATE ON run_stats - ;; FOR EACH ROW - ;; BEGIN - ;; UPDATE run_stats SET last_update=(strftime('%s','now')) - ;; WHERE id=old.id; - ;; END;") (sqlite3:execute db "CREATE TABLE IF NOT EXISTS test_meta ( id INTEGER PRIMARY KEY, testname TEXT DEFAULT '', author TEXT DEFAULT '', owner TEXT DEFAULT '', @@ -1320,14 +1370,10 @@ ;;====================================================================== ;; R U N S P E C I F I C D B ;;====================================================================== - ;; (define (db:initialize-run-id-db db) - ;; (sqlite3:with-transaction - ;; db - ;; (lambda () (sqlite3:execute db "CREATE TABLE IF NOT EXISTS tests (id INTEGER PRIMARY KEY, run_id INTEGER DEFAULT -1, testname TEXT DEFAULT 'noname', host TEXT DEFAULT 'n/a', @@ -1353,18 +1399,10 @@ ;; deprecated -- (sqlite3:execute db "CREATE INDEX IF NOT EXISTS tests_index ON tests (run_id, testname, item_path, uname);") (sqlite3:execute db "CREATE INDEX IF NOT EXISTS tests_run_id_index ON tests (run_id);") ;; new (sqlite3:execute db "CREATE INDEX IF NOT EXISTS tests_testname_index ON tests (testname,item_path);") ;; new (sqlite3:execute db "CREATE INDEX IF NOT EXISTS tests_state_status_index ON tests (state, status); ") ;; new - - ;; All triggers created at once in end - ;;(sqlite3:execute db "CREATE TRIGGER IF NOT EXISTS update_tests_trigger AFTER UPDATE ON tests - ;; FOR EACH ROW - ;; BEGIN - ;; UPDATE tests SET last_update=(strftime('%s','now')) - ;; WHERE id=old.id; - ;; END;") (sqlite3:execute db "CREATE TABLE IF NOT EXISTS test_steps (id INTEGER PRIMARY KEY, test_id INTEGER, stepname TEXT, state TEXT DEFAULT 'NOT_STARTED', @@ -1373,17 +1411,10 @@ comment TEXT DEFAULT '', logfile TEXT DEFAULT '', last_update INTEGER DEFAULT (strftime('%s','now')), CONSTRAINT test_steps_constraint UNIQUE (test_id,stepname,state));") (sqlite3:execute db "CREATE INDEX IF NOT EXISTS teststeps_index ON tests (run_id, testname, item_path);") - ;; All triggers created at once in end - ;;(sqlite3:execute db "CREATE TRIGGER IF NOT EXISTS update_teststeps_trigger AFTER UPDATE ON test_steps - ;; FOR EACH ROW - ;; BEGIN - ;; UPDATE test_steps SET last_update=(strftime('%s','now')) - ;; WHERE id=old.id; - ;; END;") (sqlite3:execute db "CREATE TABLE IF NOT EXISTS test_data (id INTEGER PRIMARY KEY, test_id INTEGER, category TEXT DEFAULT '', variable TEXT, value REAL, @@ -1394,17 +1425,10 @@ status TEXT DEFAULT 'n/a', type TEXT DEFAULT '', last_update INTEGER DEFAULT (strftime('%s','now')), CONSTRAINT test_data_constraint UNIQUE (test_id,category,variable));") (sqlite3:execute db "CREATE INDEX IF NOT EXISTS test_data_index ON test_data (test_id);") - ;; All triggers created at once in end - ;;(sqlite3:execute db "CREATE TRIGGER IF NOT EXISTS update_test_data_trigger AFTER UPDATE ON test_data - ;; FOR EACH ROW - ;; BEGIN - ;; UPDATE test_data SET last_update=(strftime('%s','now')) - ;; WHERE id=old.id; - ;; END;") (sqlite3:execute db "CREATE TABLE IF NOT EXISTS test_rundat ( id INTEGER PRIMARY KEY, test_id INTEGER, update_time TIMESTAMP, cpuload INTEGER DEFAULT -1, @@ -1430,12 +1454,11 @@ ;; dneeded is minimum space needed, scan for existing archives that ;; are on disks with adequate space and already have this test/itempath ;; archived ;; (define (db:archive-get-allocations dbstruct testname itempath dneeded) - (let* ((dbdat (db:get-db dbstruct)) ;; archive tables are in main.db - (db (db:dbdat-get-db dbdat)) + (let* ((db (db:get-inmem dbstruct #f)) ;; archive tables are in main.db (res '()) (blocks '())) ;; a block is an archive chunck that can be added too if there is space (sqlite3:for-each-row (lambda (id archive-disk-id disk-path last-du last-du-time) (set! res (cons (vector id archive-disk-id disk-path last-du last-du-time) res))) @@ -1455,19 +1478,19 @@ "SELECT d.id,d.archive_area_name,disk_path,last_df,last_df_time FROM archive_disks AS d INNER JOIN archive_blocks AS b ON d.id=b.archive_disk_id WHERE b.id IN (" (string-intersperse (map conc res) ",") ") AND last_df > ?;") dneeded)) - (stack-push! (dbr:dbstruct-dbstack dbstruct) dbdat) blocks)) ;; returns id of the record, register a disk allocated to archiving and record it's last known ;; available space +;; +;; NEEDS WORK! THIS WILL LIKELY NOT WORK AS IS! ;; (define (db:archive-register-disk dbstruct bdisk-name bdisk-path df) - (let* ((dbdat (db:get-db dbstruct)) ;; archive tables are in main.db - (db (db:dbdat-get-db dbdat)) + (let* ((db (db:get-inmem dbstruct #f)) ;; archive tables are in main.db (res #f)) (sqlite3:for-each-row (lambda (id) (set! res id)) db @@ -1476,28 +1499,25 @@ (if res ;; record exists, update df and return id (begin (sqlite3:execute db "UPDATE archive_disks SET last_df=?,last_df_time=(strftime('%s','now')) WHERE archive_area_name=? AND disk_path=?;" df bdisk-name bdisk-path) - (stack-push! (dbr:dbstruct-dbstack dbstruct) dbdat) res) (begin (sqlite3:execute db "INSERT OR REPLACE INTO archive_disks (archive_area_name,disk_path,last_df) VALUES (?,?,?);" bdisk-name bdisk-path df) - (stack-push! (dbr:dbstruct-dbstack dbstruct) dbdat) (db:archive-register-disk dbstruct bdisk-name bdisk-path df))))) ;; record an archive path created on a given archive disk (identified by it's bdisk-id) ;; if path starts with / then it is full, otherwise it is relative to the archive disk ;; preference is to store the relative path. ;; (define (db:archive-register-block-name dbstruct bdisk-id archive-path #!key (du #f)) - (let* ((dbdat (db:get-db dbstruct)) ;; archive tables are in main.db - (db (db:dbdat-get-db dbdat)) + (let* ((db (db:get-inmem dbstruct #f)) ;; archive tables are in main.db (res #f)) ;; first look to see if this path is already registered (sqlite3:for-each-row (lambda (id) (set! res id)) @@ -1511,11 +1531,10 @@ (begin (sqlite3:execute db "INSERT OR REPLACE INTO archive_blocks (archive_disk_id,disk_path,last_du) VALUES (?,?,?);" bdisk-id archive-path (or du 0)) (set! res (db:archive-register-block-name dbstruct bdisk-id archive-path du: du)))) - (stack-push! (dbr:dbstruct-dbstack dbstruct) dbdat) res)) ;; The "archived" field in tests is overloaded; 0 = not archived, > 0 archived in block with given id ;; @@ -1545,11 +1564,11 @@ "SELECT id,archive_disk_id,disk_path,last_du,last_du_time,creation_time FROM archive_blocks WHERE id=?;" archive-block-id) res)))) ;; (define (db:archive-allocate-testsuite/area-to-block block-id testsuite-name areakey) -;; (let* ((dbdat (db:get-db dbstruct #f)) ;; archive tables are in main.db +;; (let* ((dbdat (db:get-inmem dbstruct #f)) ;; archive tables are in main.db ;; (db (db:dbdat-get-db dbdat)) ;; (res '()) ;; (blocks '())) ;; a block is an archive chunck that can be added too if there is space ;; (sqlite3:for-each-row #f) @@ -1820,14 +1839,14 @@ ;; 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 dbdat) +(define (db:clean-up 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* ((keep-record-age ( - (current-seconds) (common:hms-string->seconds (or (configf:lookup *configdat* "setup" "delete-record-age") "30d")))) - (db (db:dbdat-get-db dbdat)) + (db (db:get-inmem dbdat run-id)) (count-stmt (sqlite3:prepare db "SELECT (SELECT count(id) FROM tests)+(SELECT count(id) FROM runs);")) (statements (map (lambda (stmt) (sqlite3:prepare db stmt)) (list @@ -1876,13 +1895,13 @@ ;; 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 (db:dbdat-get-db dbdat)) + (let* ((db (db:get-inmem dbdat run-id)) (count-stmt (sqlite3:prepare db "SELECT (SELECT count(id) FROM tests);")) (statements (map (lambda (stmt) (sqlite3:prepare db stmt)) (list @@ -1906,57 +1925,57 @@ (sqlite3:finalize! count-stmt) ;; (db:find-and-mark-incomplete db) ;; (db:delay-if-busy dbdat) (sqlite3:execute db "VACUUM;"))) -;; Clean out old junk and vacuum the database -;; -;; Ultimately do something like this: -;; -;; 1. Look at test records either deleted or part of deleted run: -;; a. If test dir exists, set the the test to state='UNKNOWN', Set the run to 'unknown' -;; 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-maindb dbdat) - ;; (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 (db:dbdat-get-db dbdat)) - (count-stmt (sqlite3:prepare db "SELECT (SELECT count(id) FROM runs);")) - (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 runs WHERE state='deleted';" - ))) - (dead-runs '())) - (sqlite3:for-each-row - (lambda (run-id) - (set! dead-runs (cons run-id dead-runs))) - db - "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) - (map sqlite3:execute statements) - (sqlite3:for-each-row (lambda (tot) - (debug:print-info 0 *default-log-port* "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) - (sqlite3:execute db "VACUUM;") - dead-runs)) +;; ;; Clean out old junk and vacuum the database +;; ;; +;; ;; Ultimately do something like this: +;; ;; +;; ;; 1. Look at test records either deleted or part of deleted run: +;; ;; a. If test dir exists, set the the test to state='UNKNOWN', Set the run to 'unknown' +;; ;; 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-maindb dbdat) +;; ;; (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 (db:dbdat-get-db dbdat)) +;; (count-stmt (sqlite3:prepare db "SELECT (SELECT count(id) FROM runs);")) +;; (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 runs WHERE state='deleted';" +;; ))) +;; (dead-runs '())) +;; (sqlite3:for-each-row +;; (lambda (run-id) +;; (set! dead-runs (cons run-id dead-runs))) +;; db +;; "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) +;; (map sqlite3:execute statements) +;; (sqlite3:for-each-row (lambda (tot) +;; (debug:print-info 0 *default-log-port* "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) +;; (sqlite3:execute db "VACUUM;") +;; dead-runs)) ;;====================================================================== ;; M E T A G E T A N D S E T V A R S ;;====================================================================== @@ -3296,58 +3315,58 @@ ;; (debug:print 0 *default-log-port* "INFO: Inserting values: " (string-intersperse (map conc (vector->list rec)) ",") "\n") (apply sqlite3:execute qry (append (vector->list rec)(list run-id)))) testrecs))) (sqlite3:finalize! qry))))) -;; map a test-id into the proper range -;; -(define (db:adj-test-id mtdb min-test-id test-id) - (if (>= test-id min-test-id) - test-id - (let loop ((new-id min-test-id)) - (let ((test-id-found #f)) - (sqlite3:for-each-row - (lambda (id) - (set! test-id-found id)) - (db:dbdat-get-db mtdb) - "SELECT id FROM tests WHERE id=?;" - new-id) - ;; if test-id-found then need to try again - (if test-id-found - (loop (+ new-id 1)) - (begin - (debug:print-info 0 *default-log-port* "New test id " new-id " selected for test with id " test-id) - (sqlite3:execute mtdb "UPDATE tests SET id=? WHERE id=?;" new-id test-id))))))) - -;; move test ids into the 30k * run_id range -;; -(define (db:prep-megatest.db-adj-test-ids mtdb run-id testrecs) - (debug:print-info 0 *default-log-port* "Adjusting test ids in megatest.db for run " run-id) - (let ((min-test-id (* run-id 30000))) - (for-each - (lambda (testrec) - (let* ((test-id (vector-ref testrec (db:field->number "id" db:test-record-fields)))) - (db:adj-test-id (db:dbdat-get-db mtdb) min-test-id test-id))) - testrecs))) - -;; 1. move test ids into the 30k * run_id range -;; 2. move step ids into the 30k * run_id range -;; -(define (db:prep-megatest.db-for-migration mtdb) - (let* ((run-ids (db:get-all-run-ids mtdb))) - (for-each - (lambda (run-id) - (let ((testrecs (db:get-all-tests-info-by-run-id mtdb run-id))) - (db:prep-megatest.db-adj-test-ids (db:dbdat-get-db mtdb) run-id testrecs))) - run-ids))) - -;; Get test data using test_id, run-id is not used +;; ;; ;; map a test-id into the proper range +;; ;; ;; +;; ;; (define (db:adj-test-id mtdb min-test-id test-id) +;; ;; (if (>= test-id min-test-id) +;; ;; test-id +;; ;; (let loop ((new-id min-test-id)) +;; ;; (let ((test-id-found #f)) +;; ;; (sqlite3:for-each-row +;; ;; (lambda (id) +;; ;; (set! test-id-found id)) +;; ;; (db:dbdat-get-db mtdb) +;; ;; "SELECT id FROM tests WHERE id=?;" +;; ;; new-id) +;; ;; ;; if test-id-found then need to try again +;; ;; (if test-id-found +;; ;; (loop (+ new-id 1)) +;; ;; (begin +;; ;; (debug:print-info 0 *default-log-port* "New test id " new-id " selected for test with id " test-id) +;; ;; (sqlite3:execute mtdb "UPDATE tests SET id=? WHERE id=?;" new-id test-id))))))) + +;; ;; ;; move test ids into the 30k * run_id range +;; ;; ;; +;; ;; (define (db:prep-megatest.db-adj-test-ids mtdb run-id testrecs) +;; ;; (debug:print-info 0 *default-log-port* "Adjusting test ids in megatest.db for run " run-id) +;; ;; (let ((min-test-id (* run-id 30000))) +;; ;; (for-each +;; ;; (lambda (testrec) +;; ;; (let* ((test-id (vector-ref testrec (db:field->number "id" db:test-record-fields)))) +;; ;; (db:adj-test-id (db:dbdat-get-db mtdb) min-test-id test-id))) +;; ;; testrecs))) + +;; ;; ;; 1. move test ids into the 30k * run_id range +;; ;; ;; 2. move step ids into the 30k * run_id range +;; ;; ;; +;; ;; (define (db:prep-megatest.db-for-migration mtdb) +;; ;; (let* ((run-ids (db:get-all-run-ids mtdb))) +;; ;; (for-each +;; ;; (lambda (run-id) +;; ;; (let ((testrecs (db:get-all-tests-info-by-run-id mtdb run-id))) +;; ;; (db:prep-megatest.db-adj-test-ids (db:dbdat-get-db mtdb) run-id testrecs))) +;; ;; run-ids))) + +;; Get test data using test_id ;; (define (db:get-test-info-by-id dbstruct run-id test-id) (db:with-db dbstruct - #f ;; run-id + run-id #f (lambda (db) (let ((res #f)) (sqlite3:for-each-row ;; attemptnum added to hold pid of top process (not Megatest) controlling a test (lambda (id run-id testname state status event-time host cpuload diskfree uname rundir-id item-path run_duration final-logf-id comment short-dir-id attemptnum archived last-update) @@ -3812,11 +3831,11 @@ (else msg))) ;; rpc ;; ; This is to be the big daddy call NOPE: Replaced by db:set-state-status-and-roll-up-items ;; ; ;; define (db:test-set-state-status dbstruct run-id test-id state status msg) -;; (let ((dbdat (db:get-db dbstruct run-id))) +;; (let ((dbdat (db:get-dbdat dbstruct run-id))) ;; (if (member state '("LAUNCHED" "REMOTEHOSTSTART")) ;; (db:general-call dbdat 'set-test-start-time (list test-id))) ;; ;; (if msg ;; ;; (db:general-call dbdat 'state-status-msg (list state status msg test-id)) ;; ;; (db:general-call dbdat 'state-status (list state status test-id))) @@ -4331,48 +4350,48 @@ (loop (car tal)(cdr tal)))))))))) ;; Function recursively checks if .journal exists; if yes means db busy; call itself after delayed interval ;; return the sqlite3 db handle if possible ;; -(define (db:delay-if-busy dbdat #!key (count 6)) - (if (not (configf:lookup *configdat* "server" "delay-on-busy")) - (and dbdat (db:dbdat-get-db dbdat)) - (if dbdat - (let* ((dbpath (db:dbdat-get-path dbdat)) - (db (db:dbdat-get-db dbdat)) ;; we'll return this so (db:delay--if-busy can be called inline - (dbfj (conc dbpath "-journal"))) - (if (handle-exceptions - exn - (begin - (debug:print-info 0 *default-log-port* "WARNING: failed to test for existance of " dbfj ", exn=" exn) - (thread-sleep! 1) - (db:delay-if-busy count (- count 1))) - (common:file-exists? dbfj)) - (case count - ((6) - (thread-sleep! 0.2) - (db:delay-if-busy count: 5)) - ((5) - (thread-sleep! 0.4) - (db:delay-if-busy count: 4)) - ((4) - (thread-sleep! 0.8) - (db:delay-if-busy count: 3)) - ((3) - (thread-sleep! 1.6) - (db:delay-if-busy count: 2)) - ((2) - (thread-sleep! 3.2) - (db:delay-if-busy count: 1)) - ((1) - (thread-sleep! 6.4) - (db:delay-if-busy count: 0)) - (else - (debug:print-info 0 *default-log-port* "delaying db access due to high database load.") - (thread-sleep! 12.8)))) - db) - "bogus result from db:delay-if-busy"))) +;; ;; (define (db:delay-if-busy dbdat #!key (count 6)) +;; ;; (if (not (configf:lookup *configdat* "server" "delay-on-busy")) +;; ;; (and dbdat (db:dbdat-get-db dbdat)) +;; ;; (if dbdat +;; ;; (let* ((dbpath (db:dbdat-get-path dbdat)) +;; ;; (db (db:dbdat-get-db dbdat)) ;; we'll return this so (db:delay--if-busy can be called inline +;; ;; (dbfj (conc dbpath "-journal"))) +;; ;; (if (handle-exceptions +;; ;; exn +;; ;; (begin +;; ;; (debug:print-info 0 *default-log-port* "WARNING: failed to test for existance of " dbfj ", exn=" exn) +;; ;; (thread-sleep! 1) +;; ;; (db:delay-if-busy count (- count 1))) +;; ;; (common:file-exists? dbfj)) +;; ;; (case count +;; ;; ((6) +;; ;; (thread-sleep! 0.2) +;; ;; (db:delay-if-busy count: 5)) +;; ;; ((5) +;; ;; (thread-sleep! 0.4) +;; ;; (db:delay-if-busy count: 4)) +;; ;; ((4) +;; ;; (thread-sleep! 0.8) +;; ;; (db:delay-if-busy count: 3)) +;; ;; ((3) +;; ;; (thread-sleep! 1.6) +;; ;; (db:delay-if-busy count: 2)) +;; ;; ((2) +;; ;; (thread-sleep! 3.2) +;; ;; (db:delay-if-busy count: 1)) +;; ;; ((1) +;; ;; (thread-sleep! 6.4) +;; ;; (db:delay-if-busy count: 0)) +;; ;; (else +;; ;; (debug:print-info 0 *default-log-port* "delaying db access due to high database load.") +;; ;; (thread-sleep! 12.8)))) +;; ;; db) +;; ;; "bogus result from db:delay-if-busy"))) (define (db:test-get-records-for-index-file dbstruct run-id test-name) (let ((res '())) (db:with-db dbstruct @@ -5420,35 +5439,10 @@ ;; ) ;; (debug:print 4 *default-log-port* " db, " (db:dbdat-get-path tmpdb) " already exists or fresh enough, not propogating data from\n " (db:dbdat-get-path mtdb) " mod time delta: " modtimedelta) ) ;; ;; (db:multi-db-sync dbstruct 'old2new)) ;; migrate data from megatest.db automatically ;; tmpdb)))) -;; 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 (db:setup do-sync #!key (areapath #f)) -;; ;; -;; (cond -;; (*dbstruct-db* *dbstruct-db*);; TODO: when multiple areas are supported, this optimization will be a hazard -;; (else ;;(common:on-homehost?) -;; (debug:print-info 13 *default-log-port* "db:setup entered (first time, not cached.)") -;; (let* ((dbstruct (make-dbr:dbstruct))) -;; (assert *toppath* "ERROR: db:setup called before launch:setup. This is fatal.") -;; #;(when (not *toppath*) -;; (debug:print-info 13 *default-log-port* "in db:setup, *toppath* not set; calling launch:setup") -;; (launch:setup areapath: areapath)) -;; (debug:print-info 13 *default-log-port* "Begin db:open-db") -;; (db:open-db dbstruct areapath: areapath do-sync: do-sync) -;; (debug:print-info 13 *default-log-port* "Done db:open-db") -;; (set! *dbstruct-db* dbstruct) -;; ;;(debug:print-info 13 *default-log-port* "new dbstruct = "(dbr:dbstruct->alist dbstruct)) -;; dbstruct)))) -;; ;; (else -;; ;; (debug:print 0 *default-log-port* "ERROR: attempt to open database when not on homehost. Exiting. Homehost: " (common:get-homehost)) -;; ;; (exit 1)))) - ;; Open the classic megatest.db file (defaults to open in toppath) ;; ;; NOTE: returns a dbdat not a dbstruct! ;; Index: http-transportmod.scm ================================================================== --- http-transportmod.scm +++ http-transportmod.scm @@ -469,16 +469,10 @@ ;; ya, fake it for now ;; (define (register-server-in-db db-file) #t) -;; load up the db into inmem -;; -(define (load-up-database db-file) - (let* ((db (db:open-db db-file))) - db)) - (define (get-pkts-dir) (assert *toppath* "ERROR: get-pkts-dir called without *toppath* set. Exiting.") (let* ((pdir (conc *toppath* "/.meta/srvpkts"))) (if (file-exists? pdir) pdir @@ -576,17 +570,20 @@ (define (http-transport:keep-running) ;; if none running or if > 20 seconds since ;; server last used then start shutdown ;; This thread waits for the server to come alive (debug:print-info 0 *default-log-port* "Starting the sync-back, keep alive thread in server") - (let* ((sdat #f) + (let* ((run-id (let ((rid (args:get-arg "-run-id"))) + (if rid + (string->number rid) + #f))) + (db-file (db:run-id->path run-id)) + (sdat #f) (tmp-area (common:get-db-tmp-area)) - (started-file (conc tmp-area "/.server-started")) (server-start-time (current-seconds)) (pkts-dir (get-pkts-dir)) (server-key (server:mk-signature)) - (db-file (conc *toppath* "/.db/" (or (args:get-arg "-db") "main.db"))) (server-info (let loop ((start-time (current-seconds)) (changed #t) (last-sdat "not this")) (begin ;; let ((sdat #f)) (thread-sleep! 0.01) @@ -598,22 +595,24 @@ (not changed) (> (- (current-seconds) start-time) 2)) (begin (debug:print-info 0 *default-log-port* "Received server alive signature, now attempting to lock in server") ;; create a server pkt in *toppath*/.meta/srvpkts - (register-server pkts-dir *srvpktspec* (get-host-name) (cadr sdat) server-key (car sdat) db-file) + (register-server pkts-dir *srvpktspec* (get-host-name) + (cadr sdat) server-key (car sdat) db-file) ;; now read pkts and see if we are a contender (let* ((all-pkts (get-all-server-pkts pkts-dir *srvpktspec*)) (viables (get-viable-servers all-pkts db-file)) (best-srv (get-best-candidate viables db-file)) (best-srv-key (if best-srv (alist-ref 'servkey best-srv) #f))) ;; am I the best-srv, compare server-keys to know (if (and (equal? best-srv-key server-key) (register-server-in-db db-file)) - (load-up-database db-file) ;; ready to go! - (bdat-time-to-exit-set! *bdat* #t)) ;; nope, we are not needed, exit when can do + (if (db:get-iam-server-lock *dbstruct-db* run-id) + (debug:print 0 *default-log-port* "I'm the server!") + (bdat-time-to-exit-set! *bdat* #t))) ;; nope, we are not needed, exit when can do sdat)) (begin (debug:print-info 0 *default-log-port* "Still waiting, last-sdat=" last-sdat) (sleep 4) (if (> (- (current-seconds) start-time) 120) ;; been waiting for two minutes @@ -632,28 +631,21 @@ sdat))))))) (iface (car server-info)) (port (cadr server-info)) (last-access 0) (server-timeout (server:expiration-timeout)) - (server-going #f) (server-log-file (args:get-arg "-log"))) ;; always set when we are a server - (handle-exceptions - exn - (debug:print 0 *default-log-port* "Failed to create " started-file ", exn=" exn) - (with-output-to-file started-file (lambda ()(print (current-process-id))))) - (let loop ((count 0) (server-state 'available) (bad-sync-count 0) (start-time (current-milliseconds))) ;; Use this opportunity to sync the tmp db to megatest.db - (if (not server-going) ;; *dbstruct-db* + (if (not *dbstruct-db* ) (let ((watchdog (bdat-watchdog *bdat*))) (debug:print 0 *default-log-port* "SERVER: dbprep") - (set! *dbstruct-db* (db:setup #t)) ;; run-id)) - (set! server-going #t) + (db:setup run-id) ;; sets *dbstruct-db* as side effect (debug:print 0 *default-log-port* "SERVER: running, megatest version: " (common:get-full-version)) ;; NOTE: the server is NOT yet marked as running in the log. We do that in the keep-running routine. (if watchdog (if (not (member (thread-state watchdog) '(ready running blocked sleeping dead))) (begin (debug:print-info 0 "Starting watchdog thread (in state "(thread-state watchdog)")") Index: tasksmod.scm ================================================================== --- tasksmod.scm +++ tasksmod.scm @@ -560,11 +560,11 @@ (define (tasks:find-task-queue-records dbstruct target run-name test-patt state-patt action-patt) ;; (handle-exceptions ;; exn ;; '() ;; (sqlite3:first-row - (let ((db (db:delay-if-busy (db:get-db dbstruct))) + (let ((db (db:get-inmem dbstruct #f)) ;; put tasks stuff in main.db (res '())) (sqlite3:for-each-row (lambda (a . b) (set! res (cons (cons a b) res))) db "SELECT id,action,owner,state,target,name,testpatt,keylock,params FROM tasks_queue