Index: Makefile ================================================================== --- Makefile +++ Makefile @@ -20,16 +20,16 @@ SHELL=/bin/bash PREFIX=$(PWD) CSCOPTS= INSTALL=install SRCFILES = common.scm items.scm launch.scm \ - ods.scm runconfig.scm server.scm configf.scm \ - keys.scm margs.scm megatest-version.scm \ + ods.scm runconfig.scm configf.scm \ + keys.scm margs.scm server.o megatest-version.scm \ process.scm runs.scm tasks.scm tests.scm genexample.scm \ http-transport.scm filedb.scm tdb.scm \ client.scm mt.scm \ - ezsteps.scm lock-queue.scm sdb.scm \ + ezsteps.scm lock-queue.scm \ rmt.scm api.scm subrun.scm \ archive.scm env.scm diff-report.scm cgisetup/models/pgdb.scm # module source files MSRCFILES = ftail.scm portlogger.scm nmsg-transport.scm db.scm Index: db.scm ================================================================== --- db.scm +++ db.scm @@ -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))))) ) Index: megatest.scm ================================================================== --- megatest.scm +++ megatest.scm @@ -42,25 +42,28 @@ (declare (uses server)) (declare (uses client)) (declare (uses tests)) (declare (uses genexample)) ;; (declare (uses daemon)) -(declare (uses db)) +;; (declare (uses db)) ;; (declare (uses dcommon)) (declare (uses tdb)) (declare (uses mt)) (declare (uses api)) (declare (uses tasks)) ;; only used for debugging. (declare (uses env)) (declare (uses diff-report)) -(declare (uses ftail)) -(import ftail) -(declare (uses portlogger)) -(import portlogger) -(declare (uses nmsg-transport)) -(import (prefix nmsg-transport nmsg:)) + +;; (declare (uses ftail)) +;; (import ftail) +;; +;; (declare (uses portlogger)) +;; (import portlogger) +;; +;; (declare (uses nmsg-transport)) +;; (import (prefix nmsg-transport nmsg:)) (define *db* #f) ;; this is only for the repl, do not use in general!!!! (include "common_records.scm") (include "key_records.scm") DELETED sdb.scm Index: sdb.scm ================================================================== --- sdb.scm +++ /dev/null @@ -1,116 +0,0 @@ -;;====================================================================== -;; Copyright 2006-2013, 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 . - -;;====================================================================== - -;;====================================================================== -;; Simple persistant strings lookup table. Keep out of the main db -;; so writes/reads don't slow down central access. -;;====================================================================== - -(require-extension (srfi 18) extras) -(use sqlite3 srfi-1 posix regex regex-case srfi-69 csv-xml s11n md5 message-digest base64) -(import (prefix sqlite3 sqlite3:)) -(import (prefix base64 base64:)) - -(declare (unit sdb)) - -;; -(define (sdb:open fname) - (let* ((dbpath (pathname-directory fname)) - (dbexists (let ((fe (common:file-exists? fname))) - (if fe - fe - (begin - (create-directory dbpath #t) - #f)))) - (sdb (sqlite3:open-database fname)) - (handler (make-busy-timeout 136000))) - (sqlite3:set-busy-handler! sdb handler) - (if (not dbexists) - (sdb:initialize sdb)) - (sqlite3:execute sdb "PRAGMA synchronous = 1;") - sdb)) - -(define (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 (sdb:register-string sdb str) - (sqlite3:execute sdb "INSERT OR IGNORE INTO strs (str) VALUES (?);" str)) - -(define (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 (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 (make-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) - (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 - (sdb:string->id sdb scache var)))) - (if id - id - (begin - (sdb:register-string sdb var) - (sdb:string->id sdb scache var))))) - ((getstr) (if (or (number? var) - (string->number var)) - (sdb:id->string sdb icache var) - var)) - ((passid) var) - ((passstr) var) - (else #f))))) - Index: server.scm ================================================================== --- server.scm +++ server.scm @@ -39,10 +39,11 @@ (declare (uses db)) ;; Basic stuff for safely kicking off a server (declare (uses portlogger)) (import portlogger) + (declare (uses nmsg-transport)) (import nmsg-transport) ;; Might want to bring the daemonizing back ;; (declare (uses daemon))