Index: common.scm ================================================================== --- common.scm +++ common.scm @@ -549,14 +549,17 @@ (define (assoc/default key lst . default) (let ((res (assoc key lst))) (if res (cadr res)(if (null? default) #f (car default))))) (define (common:get-testsuite-name) - (or (configf:lookup *configdat* "setup" "testsuite" ) + (or (configf:lookup *configdat* "setup" "area-name") ;; megatest is a flexible tool, testsuite is too limiting a description. + (configf:lookup *configdat* "setup" "testsuite" ) (if *toppath* (pathname-file *toppath*) (pathname-file (current-directory))))) + +(define common:get-area-name common:get-testsuite-name) (define (common:get-db-tmp-area) (if *db-cache-path* *db-cache-path* (let ((dbpath (create-directory (conc "/tmp/" (current-user-name) Index: db.scm ================================================================== --- db.scm +++ db.scm @@ -2195,10 +2195,13 @@ db qry-str runnamepatt))))))) ;; use (get-value-by-header (db:get-header runinfo)(db:get-rows runinfo)) +;; NOTE: Does NOT return a list of rows (or one row) for the first slot of the vector +;; this is inconsistent with get-runs but it makes some sense. +;; (define (db:get-run-info dbstruct run-id) ;;(if (hash-table-ref/default *run-info-cache* run-id #f) ;; (hash-table-ref *run-info-cache* run-id) (let* ((res (vector #f #f #f #f)) (keys (db:get-keys dbstruct)) Index: mt-pg.sql ================================================================== --- mt-pg.sql +++ mt-pg.sql @@ -1,7 +1,7 @@ -- CREATE TABLE IF NOT EXISTS keys ( --- id INTEGER PRIMARY KEY, +-- id SERIAL PRIMARY KEY, -- fieldname TEXT, -- fieldtype TEXT, -- CONSTRAINT keyconstraint UNIQUE (fieldname)); DROP TABLE IF EXISTS areas; @@ -21,24 +21,24 @@ DROP TABLE IF EXISTS test_data; DROP TABLE IF EXISTS test_rundat; DROP TABLE IF EXISTS archives; CREATE TABLE IF NOT EXISTS areas ( - id INTEGER PRIMARY KEY, - area_name TEXT DEFAULT 'local', - area_path TEXT DEFAULT '.', + id SERIAL PRIMARY KEY, + area_name TEXT NOT NULL, + area_path TEXT NOT NULL, last_sync INTEGER DEFAULT 0, CONSTRAINT areaconstraint UNIQUE (area_name)); INSERT INTO areas (id,area_name,area_path) VALUES (0,'local','.'); CREATE TABLE IF NOT EXISTS ttype ( - id INTEGER PRIMARY KEY, + id SERIAL PRIMARY KEY, target_spec TEXT DEFAULT ''); CREATE TABLE IF NOT EXISTS runs ( - id INTEGER PRIMARY KEY, + id SERIAL PRIMARY KEY, target TEXT DEFAULT '', ttype_id INTEGER DEFAULT 0, runname TEXT DEFAULT 'norun', state TEXT DEFAULT '', status TEXT DEFAULT '', @@ -50,19 +50,19 @@ last_update INTEGER DEFAULT extract(epoch from now()), area_id INTEGER DEFAULT 0, CONSTRAINT runsconstraint UNIQUE (runname)); CREATE TABLE IF NOT EXISTS run_stats ( - id INTEGER PRIMARY KEY, + id SERIAL PRIMARY KEY, run_id INTEGER, state TEXT, status TEXT, count INTEGER, last_update INTEGER DEFAULT extract(epoch from now())); CREATE TABLE IF NOT EXISTS test_meta ( - id INTEGER PRIMARY KEY, + id SERIAL PRIMARY KEY, testname TEXT DEFAULT '', author TEXT DEFAULT '', owner TEXT DEFAULT '', description TEXT DEFAULT '', reviewed TEXT, @@ -72,11 +72,11 @@ tags TEXT DEFAULT '', jobgroup TEXT DEFAULT 'default', CONSTRAINT test_meta_constraint UNIQUE (testname)); CREATE TABLE IF NOT EXISTS tasks_queue ( - id INTEGER PRIMARY KEY, + id SERIAL PRIMARY KEY, action TEXT DEFAULT '', owner TEXT, state TEXT DEFAULT 'new', target TEXT DEFAULT '', name TEXT DEFAULT '', @@ -85,51 +85,51 @@ params TEXT, creation_time INTEGER DEFAULT extract(epoch from now()), execution_time INTEGER); CREATE TABLE IF NOT EXISTS archive_disks ( - id INTEGER PRIMARY KEY, + id SERIAL PRIMARY KEY, archive_area_name TEXT, disk_path TEXT, last_df INTEGER DEFAULT -1, last_df_time INTEGER DEFAULT extract(epoch from now()), creation_time INTEGER DEFAULT extract(epoch from now())); CREATE TABLE IF NOT EXISTS archive_blocks ( - id INTEGER PRIMARY KEY, + id SERIAL PRIMARY KEY, archive_disk_id INTEGER, disk_path TEXT, last_du INTEGER DEFAULT -1, last_du_time INTEGER DEFAULT extract(epoch from now()), creation_time INTEGER DEFAULT extract(epoch from now())); CREATE TABLE IF NOT EXISTS archive_allocations ( - id INTEGER PRIMARY KEY, + id SERIAL PRIMARY KEY, archive_block_id INTEGER, testname TEXT, item_path TEXT, creation_time INTEGER DEFAULT extract(epoch from now())); CREATE TABLE IF NOT EXISTS extradat ( - id INTEGER PRIMARY KEY, + id SERIAL PRIMARY KEY, run_id INTEGER, key TEXT, val TEXT); CREATE TABLE IF NOT EXISTS metadat ( - id INTEGER PRIMARY KEY, + id SERIAL PRIMARY KEY, var TEXT, val TEXT); CREATE TABLE IF NOT EXISTS access_log ( - id INTEGER PRIMARY KEY, + id SERIAL PRIMARY KEY, "user" TEXT, accessed TIMESTAMP, args TEXT); CREATE TABLE IF NOT EXISTS tests ( - id INTEGER PRIMARY KEY, + id SERIAL PRIMARY KEY, run_id INTEGER DEFAULT -1, testname TEXT DEFAULT 'noname', host TEXT DEFAULT 'n/a', cpuload REAL DEFAULT -1, diskfree INTEGER DEFAULT -1, @@ -150,11 +150,11 @@ archived INTEGER DEFAULT 0, -- 0=no, > 1=archive block id where test data can be found last_update INTEGER DEFAULT extract(epoch from now()), CONSTRAINT testsconstraint UNIQUE (run_id, testname, item_path)); CREATE TABLE IF NOT EXISTS test_steps ( - id INTEGER PRIMARY KEY, + id SERIAL PRIMARY KEY, test_id INTEGER, stepname TEXT, state TEXT DEFAULT 'NOT_STARTED', status TEXT DEFAULT 'n/a', event_time INTEGER DEFAULT extract(epoch from now()), @@ -162,11 +162,11 @@ logfile TEXT DEFAULT '', last_update INTEGER DEFAULT extract(epoch from now()), CONSTRAINT test_steps_constraint UNIQUE (test_id,stepname,state)); CREATE TABLE IF NOT EXISTS test_data ( - id INTEGER PRIMARY KEY, + id SERIAL PRIMARY KEY, test_id INTEGER, category TEXT DEFAULT '', variable TEXT, value REAL, expected REAL, @@ -177,26 +177,26 @@ type TEXT DEFAULT '', last_update INTEGER DEFAULT extract(epoch from now()), CONSTRAINT test_data_constraint UNIQUE (test_id,category,variable)); CREATE TABLE IF NOT EXISTS test_rundat ( - id INTEGER PRIMARY KEY, + id SERIAL PRIMARY KEY, test_id INTEGER, update_time INTEGER, cpuload INTEGER DEFAULT -1, diskfree INTEGER DEFAULT -1, diskusage INTEGER DEFAULT -1, run_duration INTEGER DEFAULT 0); CREATE TABLE IF NOT EXISTS archives ( - id INTEGER PRIMARY KEY, + id SERIAL PRIMARY KEY, test_id INTEGER, state TEXT DEFAULT 'new', status TEXT DEFAULT 'n/a', archive_type TEXT DEFAULT 'bup', du INTEGER, archive_path TEXT); -TRUNCATE archive_blocks, archive_allocations, extradat, metadat, -access_log, tests, test_steps, test_data, test_rundat, archives, runs, -run_stats, test_meta, tasks_queue, archive_disks; +-- TRUNCATE archive_blocks, archive_allocations, extradat, metadat, +-- access_log, tests, test_steps, test_data, test_rundat, archives, runs, +-- run_stats, test_meta, tasks_queue, archive_disks; Index: tasks.scm ================================================================== --- tasks.scm +++ tasks.scm @@ -585,9 +585,89 @@ ;;====================================================================== ;; In the spirit of "dump your junk in the tasks module" I'll put the ;; sync to postgres here for now. -(define (tasks:sync-to-postgres) - (let* ((dbh (pgdb:open *configdat*)) - (area-info (pgdb:area-path->area-info dbh *toppath*))) - (print "area-info: " area-info))) +;; attempt to automatically set up an area. call only if get area by path +;; returns naught of interest +;; +(define (tasks:set-area dbh configdat #!key (toppath #f)) ;; could I safely put *toppath* in for the default for toppath? when would it be evaluated? + (let loop ((area-name (or (configf:lookup configdat "setup" "area-name") + (common:get-area-name))) + (modifier 'none)) + (let ((success (handle-exceptions + exn + (begin + (debug:print 0 *default-log-port* "ERROR: cannot create area entry, " ((condition-property-accessor 'exn 'message) exn)) + #f) ;; FIXME: I don't care for now but I should look at *why* there was an exception + (pgdb:add-area dbh area-name (or toppath *toppath*))))) + (or success + (case modifier + ((none)(loop (conc (current-user-name) "_" area-name) 'user)) + ((user)(loop (conc (substring (common:get-area-path-signature) 0 4) + area-name) 'areasig)) + (else #f)))))) ;; give up + +;; gets mtpg-run-id and syncs the record if different +;; +(define (tasks:run-id->mtpg-run-id dbh cached-info run-id) + (let* ((runs-ht (hash-table-ref cached-info 'runs)) + (runinf (hash-table-ref runs-ht run-id))) + (if runinf + runinf ;; already cached + (let* ((keytarg (string-intersperse (rmt:get-keys) "/")) ;; e.g. version/iteration/platform + (spec-id (pgdb:get-ttype dbh keytarg)) + (target (rmt:get-target run-id)) ;; e.g. v1.63/a3e1/ubuntu + (run-dat (rmt:get-run-info run-id)) ;; NOTE: get-run-info returns a vector < row header > + (run-name (rmt:get-run-name-from-id run-id)) + (new-run-id (pgdb:get-run-id dbh spec-id target run-name)) + (row (db:get-rows run-dat)) ;; yes, this returns a single row + (header (db:get-header run-dat)) + (state (db:get-value-by-header rows header "state ")) + (status (db:get-value-by-header row header "status")) + (owner (db:get-value-by-header row header "owner")) + (event-time (db:get-value-by-header row header "event_time")) + (comment (db:get-value-by-header row header "comment")) + (fail-count (db:get-value-by-header row header "fail_count")) + (pass-count (db:get-value-by-header row header "pass_count")) + (area-id (db:get-value-by-header row header "area_id)"))) + (if new-run-id + (begin ;; let ((run-record (pgdb:get-run-info dbh new-run-id)) + (hash-table-set! runs-ht run-id new-run-id) + ;; ensure key fields are up to date + (pgdb:refresh-run-info + dbh + new-run-id + state status owner event-time comment fail-count pass-count area-id)) + (if (handle-exceptions + exn + (begin (print-call-chain) #f) + (pgdb:insert-run + dbh + spec-id target state status owner event-time comment fail-count pass-count area-id)) + (tasks:run-id->mtpg-run-id dbh cached-info run-id) + #f)))))) + + + + ;;(define (tasks:sync-test-data dbh cached-info area-info) + ;; (let* (( + +(define (tasks:sync-to-postgres configdat) + (let* ((dbh (pgdb:open configdat)) + (area-info (pgdb:get-area-by-path dbh *toppath*)) + (cached-info (make-hash-table))) + (for-each (lambda (dtype) + (hash-table-set! cached-info dtype (make-hash-table))) + '(runs targets tests)) + (hash-table-set! cached-info 'start (current-seconds)) + (if area-info + (begin + (print "area-info: " area-info) + (tasks:sync-test-data dbh cached-info area-info) + ) + (if (tasks:set-area dbh configdat) + (tasks:sync-to-postgres configdat) + (begin + (debug:print 0 *default-log-port* "ERROR: unable to create an area record") + #f))))) +