@@ -36,10 +36,299 @@ (use (prefix sqlite3 sqlite3:) (srfi 18) extras tcp stack srfi-1 posix regex regex-case srfi-69 csv-xml s11n md5 message-digest base64 format dot-locking z3 typed-records matchable (prefix base64 base64:)) + +;;====================================================================== +;; +;;====================================================================== + +(defstruct dbinfo + (mtrah #f) + (dbpath #f) + (maindb #f) + (dbfile #f) + (writeable #f) + (rundbs (make-hash-table)) ;; id => #(dbhandle readq writeq) + (stats (make-hash-table)) + (mreadq (make-queue)) ;; read queue for main.db + (mwriteq (make-queue)) ;; write queue for main.db + (localq (make-queue)) ;; queue for cpuload, numcores and other OS requests + (respq (make-queue)) ;; queue for responses + ) + +(defstruct rundbinfo + (rundb #f) ;; db handle + (dbfile #f) + (readq (make-queue)) + (writeq (make-queue)) + (sdbcache (make-hash-table)) ;; cache the id => strings as we read them + (stats (make-hash-table)) + ) + +(defstruct request + (srchost #f) + (srcport #f) + (reqtype #f) ;; read, write, local + (response #f) + (status 'new) + (start (current-milliseconds))) + +;; create a dbinfo record initialized to a specific Megatest area +;; +(define (db:create-dbinfo mtrah) + (make-dbinfo mtrah: mtrah dbpath: (conc mtrah "/.mtdb"))) + +(define (db:get-open-db dbinfo run-id #!key (dbpath #f)) + (let* ((dbpath (dbinfo-dbpath dbinfo)) + (ismain (if (number? run-id) #f #t)) + (dbname (if run-id (conc run-id ".db") "main.db")) ;; can use string for run-id + (dbfile (conc dbpath "/" dbname)) + (dbexists (file-exists? dbfile)) + (readable (file-read-access? dbpath)) ;; should be safe to assume can read db file + (writeable (file-write-access? dbpath))) + ;; handle error conditions + (cond + ((and (not dbexists) (not writeable))(values #f "No db file and no write access")) + ((not readable) (values #f "No read access")) + (else + ;; TODO - transfer over the error handling from MT1.65 db:lock-create-open + (let ((db (sqlite3:open-database dbfile))) + (if (not dbexists)(db:initialize-db db)) + ;; now deal with the added structure for run-id based db if needed + (if ismain + (begin + (dbinfo-maindb-set! dbinfo db) + (dbinfo-writeable-set! dbinfo writeable)) + (let ((runrec (or (hash-table-ref/default (dbinfo-rundbs dbinfo) run-id (make-rundbinfo rundb: db dbfile: dbfile))))) + (hash-table-set! (dbinfo-rundbs dbinfo) run-id runrec))) + (values #t "Success")))))) + +;; dbinfo must have been initiatized with the dbpath +;; +#;(define (db:with-db dbinfo run-id proc . params) + (let* ((db (db:get-open-db dbinfo run-id)) + (use-mutex (> *api-process-request-count* 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*)) + (debug:print-info 2 *default-log-port* "Parallel api request count: " *api-process-request-count* " max parallel requests: " *max-api-process-requests*)) + (handle-exceptions + exn + (begin + (print-call-chain (current-error-port)) + (debug:print-error 0 *default-log-port* "sqlite3 issue in db:with-db, dbstruct=" dbstruct ", run-id=" run-id ", proc=" proc ", params=" params " error: " ((condition-property-accessor 'exn 'message) exn)) + ;; there is no recovering at this time. exit + (exit 50)) + (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)))) + +(define (db:initialize-db db) + (sqlite3:with-transaction + db + (lambda () + (sqlite3:execute db "CREATE TABLE IF NOT EXISTS ttype ( + id SERIAL PRIMARY KEY, + target_spec TEXT DEFAULT '');") + (sqlite3:execute db "CREATE TABLE IF NOT EXISTS runs ( + id INTEGER PRIMARY KEY, + target TEXT DEFAULT 'nodata', + ttype_id INTEGER DEFAULT 0, + run_name TEXT DEFAULT 'norun', + contour TEXT DEFAULT '', + state TEXT DEFAULT '', + status TEXT DEFAULT '', + owner TEXT DEFAULT '', + event_time TIMESTAMP DEFAULT (strftime('%s','now')), + comment TEXT DEFAULT '', + fail_count INTEGER DEFAULT 0, + pass_count INTEGER DEFAULT 0, + last_update INTEGER DEFAULT (strftime('%s','now')), + CONSTRAINT runsconstraint UNIQUE (target,ttype_id,run_name, area_id));") + (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')))") + (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 '', + description TEXT DEFAULT '', + reviewed TIMESTAMP, + iterated TEXT DEFAULT '', + avg_runtime REAL, + avg_disk REAL, + tags TEXT DEFAULT '', + jobgroup TEXT DEFAULT 'default', + CONSTRAINT test_meta_constraint UNIQUE (testname));") + (sqlite3:execute db "CREATE TABLE IF NOT EXISTS tasks_queue (id INTEGER PRIMARY KEY, + action TEXT DEFAULT '', + owner TEXT, + state TEXT DEFAULT 'new', + target TEXT DEFAULT '', + name TEXT DEFAULT '', + testpatt TEXT DEFAULT '', + keylock TEXT, + params TEXT, + creation_time TIMESTAMP DEFAULT (strftime('%s','now')), + execution_time TIMESTAMP);") + ;; archive disk areas, cached info from [archive-disks] + (sqlite3:execute db "CREATE TABLE IF NOT EXISTS archive_disks ( + id INTEGER PRIMARY KEY, + archive_area_name TEXT, + disk_path TEXT, + last_df INTEGER DEFAULT -1, + last_df_time TIMESTAMP DEFAULT (strftime('%s','now')), + creation_time TIMESTAMP DEFAULT (strftime('%','now')));") + ;; individual bup (or tar) data chunks + (sqlite3:execute db "CREATE TABLE IF NOT EXISTS archive_blocks ( + id INTEGER PRIMARY KEY, + archive_disk_id INTEGER, + disk_path TEXT, + last_du INTEGER DEFAULT -1, + last_du_time TIMESTAMP DEFAULT (strftime('%s','now')), + creation_time TIMESTAMP DEFAULT (strftime('%','now')));") + ;; tests allocated to what chunks. reusing a chunk for a test/item_path is very efficient + ;; NB// the per run/test recording of where the archive is stored is done in the test + ;; record. + (sqlite3:execute db "CREATE TABLE IF NOT EXISTS archive_allocations ( + id INTEGER PRIMARY KEY, + archive_block_id INTEGER, + testname TEXT, + item_path TEXT, + creation_time TIMESTAMP DEFAULT (strftime('%','now')));") + ;; move this clean up call somewhere else + (sqlite3:execute db "DELETE FROM tasks_queue WHERE state='done' AND creation_time < ?;" (- (current-seconds)(* 24 60 60))) ;; remove older than 24 hrs + (sqlite3:execute db (conc "CREATE INDEX IF NOT EXISTS runs_index ON runs (runname);")) ;; (if havekeys "," "") keystr ");")) + ;; (sqlite3:execute db "CREATE VIEW runs_tests AS SELECT * FROM runs INNER JOIN tests ON runs.id=tests.run_id;") + (sqlite3:execute db "CREATE TABLE IF NOT EXISTS extradat (id INTEGER PRIMARY KEY, run_id INTEGER, key TEXT, val TEXT);") + (sqlite3:execute db "CREATE TABLE IF NOT EXISTS metadat (id INTEGER PRIMARY KEY, var TEXT, val TEXT, + CONSTRAINT metadat_constraint UNIQUE (var));") + (sqlite3:execute db "CREATE TABLE IF NOT EXISTS access_log (id INTEGER PRIMARY KEY, user TEXT, accessed TIMESTAMP, args TEXT);") + ;; Must do this *after* running patch db !! No more. + ;; cannot use db:set-var since it will deadlock, hardwire the code here + + ;; ERROR: Cannot do this here - must update from Megatest itself, not from mtserver + ;; (sqlite3:execute db "INSERT OR REPLACE INTO metadat (var,val) VALUES (?,?);" "MEGATEST_VERSION" (common:version-signature)) + + ;;====================================================================== + ;; R U N S P E C I F I C D B + ;;====================================================================== + + (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', + cpuload REAL DEFAULT -1, + diskfree INTEGER DEFAULT -1, + uname TEXT DEFAULT 'n/a', + rundir TEXT DEFAULT '/tmp/badname', + shortdir TEXT DEFAULT '/tmp/badname', + item_path TEXT DEFAULT '', + state TEXT DEFAULT 'NOT_STARTED', + status TEXT DEFAULT 'FAIL', + attemptnum INTEGER DEFAULT 0, + final_logf TEXT DEFAULT 'logs/final.log', + logdat TEXT DEFAULT '', + run_duration INTEGER DEFAULT 0, + comment TEXT DEFAULT '', + event_time TIMESTAMP DEFAULT (strftime('%s','now')), + fail_count INTEGER DEFAULT 0, + pass_count INTEGER DEFAULT 0, + archived INTEGER DEFAULT 0, -- 0=no, > 1=archive block id where test data can be found + last_update INTEGER DEFAULT (strftime('%s','now')), + CONSTRAINT testsconstraint UNIQUE (run_id, testname, item_path));") + ;; 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 + + (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', + status TEXT DEFAULT 'n/a', + event_time TIMESTAMP, + 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);") + (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, + expected REAL, + tol REAL, + units TEXT, + comment TEXT DEFAULT '', + 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);") + (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, + diskfree INTEGER DEFAULT -1, + diskusage INTGER DEFAULT -1, + run_duration INTEGER DEFAULT 0);") + (sqlite3:execute db "CREATE TABLE IF NOT EXISTS archives ( + id INTEGER PRIMARY KEY, + test_id INTEGER, + state TEXT DEFAULT 'new', + status TEXT DEFAULT 'n/a', + archive_type TEXT DEFAULT 'bup', + du INTEGER, + archive_path TEXT);"))) + db) (define (db:general-sqlite-error-dump . args) #t) (define (db:first-result-default . args) #t) (define (db:get-db . args) #t) (define (db:dbdat-get-db . args) #t) @@ -198,6 +487,78 @@ (define (db:get-prereqs-not-met . args) #t) (define (db:get-run-record-ids . args) #t) (define (db:get-changed-record-ids . args) #t) (define (db:extract-ods-file . args) #t) +;;====================================================================== +;; Strings table (kept in the .db) +;;====================================================================== + +;; Move this into the runid db init +;; +(define (db:sdb-initialize sdb) + (sqlite3:execute sdb "CREATE TABLE IF NOT EXISTS strs + (id INTEGER PRIMARY KEY, + str TEXT, + CONSTRAINT str UNIQUE (str));") + (sqlite3:execute sdb "CREATE INDEX IF NOT EXISTS strindx ON strs (str);")) + +;; (define sumup (let ((a 0))(lambda (x)(set! a (+ x a)) a))) + +(define (db:sdb-register-string sdb str) + (sqlite3:execute sdb "INSERT OR IGNORE INTO strs (str) VALUES (?);" str)) + +(define (db:sdb-string->id sdb str-cache str) + (let ((id (hash-table-ref/default str-cache str #f))) + (if (not id) + (sqlite3:for-each-row + (lambda (sid) + (set! id sid) + (hash-table-set! str-cache str id)) + sdb + "SELECT id FROM strs WHERE str=?;" str)) + id)) + +(define (db:sdb-id->string sdb id-cache id) + (let ((str (hash-table-ref/default id-cache id #f))) + (if (not str) + (sqlite3:for-each-row + (lambda (istr) + (set! str istr) + (hash-table-set! id-cache id str)) + sdb + "SELECT str FROM strs WHERE id=?;" id)) + str)) + +;; Numbers get passed though in both directions +;; +#;(define (db:sdb-qry fname) + (let ((sdb #f) + (scache (make-hash-table)) + (icache (make-hash-table))) + (lambda (cmd var) + (case cmd + ((setup) (set! sdb (if (not sdb) + (db:sdb-open (if var var fname))))) + ((setdb) (set! sdb var)) + ((getdb) sdb) + ((finalize) (if sdb + (begin + (sqlite3:finalize! sdb) + (set! sdb #f)))) + ((getid) (let ((id (if (or (number? var) + (string->number var)) + var + (db:sdb-string->id sdb scache var)))) + (if id + id + (begin + (db:sdb-register-string sdb var) + (db:sdb-string->id sdb scache var))))) + ((getstr) (if (or (number? var) + (string->number var)) + (db:sdb-id->string sdb icache var) + var)) + ((passid) var) + ((passstr) var) + (else #f))))) )