Index: api.scm ================================================================== --- api.scm +++ api.scm @@ -17,30 +17,44 @@ (define (api:execute-requests db cmd params) (case (string->symbol cmd) ;; KEYS ((get-key-val-pairs) (apply db:get-key-val-pairs db params)) + ((get-keys) (db:get-keys db)) + ;; TESTS ;; json doesn't do vectors, convert to list ((get-test-info-by-id) (let ((res (apply db:get-test-info-by-id db params))) (if (vector? res)(vector->list res) res))) ((test-get-rundir-from-test-id) (apply db:test-get-rundir-from-test-id db params)) ((testmeta-get-record) (vector->list (apply db:testmeta-get-record db params))) ((test-set-state-status-by-id) (apply db:test-set-state-status-by-id db params)) + ((get-count-tests-running) (db:get-count-tests-running db)) + ((get-count-tests-running-in-jobgroup) (apply db:get-count-tests-running-in-jobgroup db params)) + ((delete-test-records) (apply db:delete-test-records params)) + ((delete-old-deleted-test-records) (db:delete-old-deleted-test-records db)) + ((test-set-status-state) (apply db:test-set-status-state params)) + ((get-previous-test-run-record) (apply db:get-previous-test-run-record params)) + ((get-matching-previous-test-run-records)(map vector->list (apply db:get-matching-previous-test-run-records db params))) + ;; RUNS ((get-run-info) (let ((res (apply db:get-run-info db params))) (list (vector-ref res 0) (vector->list (vector-ref res 1))))) ((register-run) (apply db:register-run db params)) - ((login) (apply db:login db params)) - ((general-call) (let ((stmtname (car params)) - (realparams (cdr params))) - (db:general-call db stmtname realparams))) ((set-tests-state-status) (apply db:set-state-status db params)) ((get-tests-for-run) (map vector->list (apply db:get-tests-for-run db params))) ((get-test-id) (apply db:get-test-id-not-cached db params)) ((get-tests-for-runs-mindata) (map vector->list (apply db:get-tests-for-runs-mindata db params))) + ((get-run-name-from-id) (apply db:get-run-name-from-id db params)) + ((delete-run) (apply db:delete-run db params)) + + ;; MISC + ((login) (apply db:login db params)) + ((general-call) (let ((stmtname (car params)) + (realparams (cdr params))) + (db:general-call db stmtname realparams))) (else (list "ERROR" 0)))) ;; http-server send-response ;; api:process-request Index: db.scm ================================================================== --- db.scm +++ db.scm @@ -105,47 +105,77 @@ (define (db:sync-to fromdb todb) ;; strategy ;; 1. Get all run-ids ;; 2. For each run-id ;; a. Sync that run in a transaction - (let* ((run-ids (db:get-all-run-ids fromdb)) - (tgetstmt (sqlite3:prepare todb "SELECT id,run_id,testname,state,status,event_time,host,cpuload,diskfree,uname,rundir,item_path,run_duration,final_logf,comment FROM tests WHERE id=?;")) - (tputstmt (sqlite3:prepare todb "INSERT OR REPLACE INTO tests (id,run_id,testname,state,status,event_time,host,cpuload,diskfree,uname,rundir,item_path,run_duration,final_logf,comment) - VALUES (?, ?, ?, ?, ?, ?, ?, ?, ?, ?, ?, ?, ?, ?, ? );")) - (trecchgd 0)) + (let ((trecchgd 0) + (rrecchgd 0) + (tmrecchgd 0)) + + ;; First sync test_meta data + (let ((tmgetstmt (sqlite3:prepare todb "SELECT id,testname,author,owner,description,reviewed,iterated,avg_runtime,avg_disk,tags,jobgroup FROM test_meta WHERE id=?;")) + (tmputstmt (sqlite3:prepare todb "INSERT OR REPLACE INTO test_meta (id,testname,author,owner,description,reviewed,iterated,avg_runtime,avg_disk,tags,jobgroup) + VALUES (?, ?, ?, ?, ?, ?, ?, ?, ?, ?, ?);")) + (tmdats (db:testmeta-get-all fromdb))) + ;; (debug:print 7 "Updating as many as " (length tdats) " records for run " run-id) + (for-each + (lambda (tmdat) ;; iterate over tests + (let ((testm-id (vector-ref tmdat 0))) + (sqlite3:with-transaction + todb + (lambda () + (let ((curr-tmdat #f)) + (sqlite3:for-each-row + (lambda (a . b) + (set! curr-tmdat (apply vector a b))) + tmgetstmt testm-id) + (if (not (equal? curr-tmdat tmdat)) ;; something changed + (begin + (debug:print 0 " test-id: " test-id + "\ncurr-tdat: " curr-tmdat + "\n tdat: " tmdat) + (apply sqlite3:execute tputstmt (vector->list tmdat)) + (set! tmrecchgd (+ tmrecchgd 1))))))))) + tmdats) + (sqlite3:finalize! tmgetstmt) + (sqlite3:finalize! tmputstmt)) + ;; First sync tests data - (for-each - (lambda (run-id) - (let ((tdats (db:get-all-tests-info-by-run-id fromdb run-id))) - ;; (debug:print 7 "Updating as many as " (length tdats) " records for run " run-id) - (for-each - (lambda (tdat) ;; iterate over tests - (let ((test-id (vector-ref tdat 0))) - (sqlite3:with-transaction - todb - (lambda () - (let ((curr-tdat #f)) - (sqlite3:for-each-row - (lambda (a . b) - (set! curr-tdat (apply vector a b))) - tgetstmt - test-id) - (if (not (equal? curr-tdat tdat)) ;; something changed - (begin - (debug:print 0 " test-id: " test-id - "\ncurr-tdat: " curr-tdat - "\n tdat: " tdat) - (apply sqlite3:execute tputstmt (vector->list tdat)) - (set! trecchgd (+ trecchgd 1))))))))) - tdats))) - run-ids) - (sqlite3:finalize! tgetstmt) - (sqlite3:finalize! tputstmt) - (if (> trecchgd 0)(debug:print 0 "sync'd " trecchgd " changed records in tests table")) + (let ((run-ids (db:get-all-run-ids fromdb)) + (tgetstmt (sqlite3:prepare todb "SELECT id,run_id,testname,state,status,event_time,host,cpuload,diskfree,uname,rundir,item_path,run_duration,final_logf,comment FROM tests WHERE id=?;")) + (tputstmt (sqlite3:prepare todb "INSERT OR REPLACE INTO tests (id,run_id,testname,state,status,event_time,host,cpuload,diskfree,uname,rundir,item_path,run_duration,final_logf,comment) + VALUES (?, ?, ?, ?, ?, ?, ?, ?, ?, ?, ?, ?, ?, ?, ? );"))) + (for-each + (lambda (run-id) + (let ((tdats (db:get-all-tests-info-by-run-id fromdb run-id))) + ;; (debug:print 7 "Updating as many as " (length tdats) " records for run " run-id) + (for-each + (lambda (tdat) ;; iterate over tests + (let ((test-id (vector-ref tdat 0))) + (sqlite3:with-transaction + todb + (lambda () + (let ((curr-tdat #f)) + (sqlite3:for-each-row + (lambda (a . b) + (set! curr-tdat (apply vector a b))) + tgetstmt + test-id) + (if (not (equal? curr-tdat tdat)) ;; something changed + (begin + (debug:print 0 " test-id: " test-id + "\ncurr-tdat: " curr-tdat + "\n tdat: " tdat) + (apply sqlite3:execute tputstmt (vector->list tdat)) + (set! trecchgd (+ trecchgd 1))))))))) + tdats))) + run-ids) + (sqlite3:finalize! tgetstmt) + (sqlite3:finalize! tputstmt)) + ;; Next sync runs table - (let* ((rrecchgd 0) - (rdats '()) + (let* ((rdats '()) (keys (db:get-keys fromdb)) (rstdfields (conc "id," (string-intersperse keys ",") ",runname,state,status,owner,event_time,comment,fail_count,pass_count")) (rnumfields (length (string-split rstdfields ","))) (runslots (string-intersperse (make-list rnumfields "?") ",")) (rgetstmt (sqlite3:prepare todb (conc "SELECT " rstdfields " FROM runs WHERE id=?;"))) @@ -177,14 +207,15 @@ "\n rdat: " rdat) (set! rrecchgd (+ rrecchgd 1)) (apply sqlite3:execute rputstmt (vector->list rdat)))))) rdats))) (sqlite3:finalize! rgetstmt) - (sqlite3:finalize! rputstmt) - (if (> rrecchgd 0)(debug:print 0 "synced " rrecchgd " changed records in runs table")) - (if (> trecchgd 0)(debug:print 0 "synced " trecchgd " changed records in tests table")) - ))) + (sqlite3:finalize! rputstmt)) + + (if (> rrecchgd 0) (debug:print 0 "synced " rrecchgd " changed records in runs table")) + (if (> trecchgd 0) (debug:print 0 "synced " trecchgd " changed records in tests table")) + (if (> tmrecchgd 0) (debug:print 0 "sync'd " tmrecchgd " changed records in test_meta table")))) (define (db:sync-back) (db:sync-to *inmemdb* *db*)) ;; keeping it around for debugging purposes only @@ -321,14 +352,14 @@ (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, + reviewed TIMESTAMP DEFAULT (strftime('%s','now')), iterated TEXT DEFAULT '', - avg_runtime REAL, - avg_disk REAL, + avg_runtime REAL DEFAULT -1, + avg_disk REAL DEFAULT -1, tags TEXT DEFAULT '', jobgroup TEXT DEFAULT 'default', CONSTRAINT test_meta_constraint UNIQUE (testname));") (sqlite3:execute db "CREATE TABLE IF NOT EXISTS test_data (id INTEGER PRIMARY KEY, test_id INTEGER, @@ -395,11 +426,11 @@ ;; find and open the testdat.db file for an existing test (define (db:open-test-db-by-test-id db test-id #!key (work-area #f)) (let* ((test-path (if work-area work-area - (cdb:remote-run db:test-get-rundir-from-test-id db test-id)))) + (db:test-get-rundir-from-test-id db test-id)))) (debug:print 3 "TEST PATH: " test-path) (open-test-db test-path))) (define (db:testdb-initialize db) (debug:print 11 "db:testdb-initialize START") @@ -980,27 +1011,23 @@ (let ((finalres (vector header res))) ;; (hash-table-set! *run-info-cache* run-id finalres) finalres))) (define (db:set-comment-for-run db run-id comment) - (debug:print-info 11 "db:set-comment-for-run START run-id: " run-id " comment: " comment) - (sqlite3:execute db "UPDATE runs SET comment=? WHERE id=?;" comment run-id) - (debug:print-info 11 "db:set-comment-for-run END run-id: " run-id " comment: " comment)) + (sqlite3:execute db "UPDATE runs SET comment=? WHERE id=?;" comment run-id)) ;; does not (obviously!) removed dependent data. But why not!!? (define (db:delete-run db run-id) - (common:clear-caches) ;; don't trust caches after doing any deletion ;; First set any related tests to DELETED (let ((stmt1 (sqlite3:prepare db "UPDATE tests SET state='DELETED',comment='' WHERE run_id=?;")) (stmt2 (sqlite3:prepare db "UPDATE runs SET state='deleted',comment='' WHERE id=?;"))) (sqlite3:with-transaction db (lambda () (sqlite3:execute stmt1 run-id) (sqlite3:execute stmt2 run-id))) (sqlite3:finalize! stmt1) (sqlite3:finalize! stmt2))) -;; (sqlite3:execute db "DELETE FROM runs WHERE id=?;" run-id)) (define (db:update-run-event_time db run-id) (debug:print-info 11 "db:update-run-event_time START run-id: " run-id) (sqlite3:execute db "UPDATE runs SET event_time=strftime('%s','now') WHERE id=?;" run-id) (debug:print-info 11 "db:update-run-event_time END run-id: " run-id)) @@ -1254,30 +1281,27 @@ (sqlite3:execute tdb "DELETE FROM test_data;") (sqlite3:finalize! tdb))))) ;; (define (db:delete-test-records db tdb test-id #!key (force #f)) - (common:clear-caches) (if tdb (begin (sqlite3:execute tdb "DELETE FROM test_steps;") - (sqlite3:execute tdb "DELETE FROM test_data;"))) - ;; (sqlite3:execute db "DELETE FROM tests WHERE id=?;" test-id)) + (sqlite3:execute tdb "DELETE FROM test_data;")) + (db:delete-test-step-records db test-id)) (if db (begin (sqlite3:execute db "DELETE FROM test_steps WHERE test_id=?;" test-id) (sqlite3:execute db "DELETE FROM test_data WHERE test_id=?;" test-id) (if force (sqlite3:execute db "DELETE FROM tests WHERE id=?;" test-id) (sqlite3:execute db "UPDATE tests SET state='DELETED',status='n/a',comment='' WHERE id=?;" test-id))))) (define (db:delete-tests-for-run db run-id) - (common:clear-caches) (sqlite3:execute db "DELETE FROM tests WHERE run_id=?;" run-id)) (define (db:delete-old-deleted-test-records db) - (common:clear-caches) (let ((targtime (- (current-seconds)(* 30 24 60 60)))) ;; one month in the past (sqlite3:execute db "DELETE FROM tests WHERE state='DELETED' AND event_time (db:test-get-event_time testdat)(db:test-get-event_time stored-test)))) + ;; this test is younger, store it in the hash + (hash-table-set! tests-hash full-testname testdat)))) + results) + (if (null? tal) + (map cdr (hash-table->alist tests-hash)) ;; return a list of the most recent tests + (loop (car tal)(cdr tal)))))))))) + (define (db:process-queue-item db item) (let* ((stmt-key (cdb:packet-get-qtype item)) (qry-sig (cdb:packet-get-query-sig item)) (return-address (cdb:packet-get-client-sig item)) @@ -2149,10 +2231,19 @@ (sqlite3:execute db "INSERT OR IGNORE INTO test_meta (testname,author,owner,description,reviewed,iterated,avg_runtime,avg_disk,tags) VALUES (?,'','','','','','','','');" testname)) ;; update one of the testmeta fields (define (db:testmeta-update-field db testname field value) (sqlite3:execute db (conc "UPDATE test_meta SET " field "=? WHERE testname=?;") value testname)) + +(define (db:testmeta-get-all db) + (let ((res '())) + (sqlite3:for-each-row + (lambda (a . b) + (set! res (cons (apply vector a b) res))) + db + "SELECT id,testname,author,owner,description,reviewed,iterated,avg_runtime,avg_disk,tags,jobgroup FROM test_meta;") + res)) ;;====================================================================== ;; T E S T D A T A ;;====================================================================== @@ -2707,11 +2798,10 @@ db:delete-tests-for-run db:delete-old-deleted-test-records db:set-tests-state-status db:test-set-state-status-by-id db:test-set-state-status-by-run-id-testname - db:test-set-comment db:testmeta-add-record db:csv->test-data db:test-data-rollup db:teststep-set-status! )) Index: rmt.scm ================================================================== --- rmt.scm +++ rmt.scm @@ -61,20 +61,16 @@ ;; A C T U A L A P I C A L L S ;; ;;====================================================================== ;;====================================================================== -;; A D M I N +;; M I S C ;;====================================================================== (define (rmt:login) (rmt:send-receive 'login (list *toppath* megatest-version *my-client-signature*))) -;;====================================================================== -;; G E N E R A L C A L L -;;====================================================================== - ;; hand off a call to one of the db:queries statements (define (rmt:general-call stmtname . params) (rmt:send-receive 'general-call (append (list stmtname) params))) ;;====================================================================== @@ -82,10 +78,13 @@ ;;====================================================================== (define (rmt:get-key-val-pairs run-id) (rmt:send-receive 'get-key-val-pairs (list run-id))) +(define (rmt:get-keys) + (rmt:send-receive 'get-keys '())) + ;;====================================================================== ;; T E S T S ;;====================================================================== (define (rmt:get-test-id run-id testname item-path) @@ -123,10 +122,31 @@ (map list->vector (rmt:send-receive 'get-tests-for-run (list run-id testpatt states statuses offset limit not-in sort-by sort-order qryvals)))) (define (rmt:get-tests-for-runs-mindata run-ids testpatt states status not-in) (map list->vector (rmt:send-receive 'get-tests-for-runs-mindata (list run-ids testpatt states status not-in)))) +(define (rmt:delete-test-records test-id) + (rmt:send-receive 'delete-test-records (list test-id))) + +(define (rmt:test-set-status-state test-id status state msg) + (rmt:send-receive 'test-set-status-state (list test-id status state msg))) + +(define (rmt:get-previous-test-run-record run-id test-name item-path) + (rmt:send-receive 'get-previous-test-run-record (list run-id test-name item-path))) + +(define (rmt:get-matching-previous-test-run-records run-id test-name item-path) + (map list->vector + (rmt:send-receive 'get-matching-previous-test-run-records (list run-id test-name item-path)))) + +;; Statistical queries + +(define (rmt:get-count-tests-running) + (rmt:send-receive 'get-count-tests-running '())) + +(define (rmt:get-count-tests-running-in-jobgroup jobgroup) + (rmt:send-receive 'get-count-tests-running-in-jobgroup (list jobgroup))) + ;;====================================================================== ;; R U N S ;;====================================================================== (define (rmt:get-run-info run-id) @@ -135,10 +155,18 @@ (list->vector (cadr res))))) (define (rmt:register-run keyvals runname state status user) (rmt:send-receive 'register-run (list keyvals runname state status user))) +(define (rmt:get-run-name-from-id run-id) + (rmt:send-receive 'get-run-name-from-id (list run-id))) + +(define (rmt:delete-run run-id) + (rmt:send-receive 'delete-run (list run-id))) + +(define (rmt:delete-old-deleted-test-records) + (rmt:send-receive 'delete-old-deleted-test-records '())) ;;====================================================================== ;; S T E P S ;;====================================================================== Index: runs.scm ================================================================== --- runs.scm +++ runs.scm @@ -97,21 +97,21 @@ (define (set-megatest-env-vars run-id #!key (inkeys #f)(inrunname #f)(inkeyvals #f)) (let* ((target (or (args:get-arg "-reqtarg") (args:get-arg "-target") (get-environment-variable "MT_TARGET"))) - (keys (if inkeys inkeys (cdb:remote-run db:get-keys #f))) + (keys (if inkeys inkeys (rmt:get-keys))) (keyvals (if inkeyvals inkeyvals (keys:target->keyval keys target))) (vals (hash-table-ref/default *env-vars-by-run-id* run-id #f))) ;; get the info from the db and put it in the cache (if (not vals) (let ((ht (make-hash-table))) (hash-table-set! *env-vars-by-run-id* run-id ht) (set! vals ht) (for-each (lambda (key) - (hash-table-set! vals (car key) (cadr key))) ;; (cdb:remote-run db:get-run-key-val #f run-id (car key)))) + (hash-table-set! vals (car key) (cadr key))) keyvals))) ;; from the cached data set the vars (hash-table-for-each vals (lambda (key val) @@ -121,11 +121,11 @@ (setenv key val) (debug:print 0 "ERROR: Malformed environment variable definition: var=" var ", val=" val)))) (if (not (get-environment-variable "MT_TARGET"))(setenv "MT_TARGET" target)) (alist->env-vars (hash-table-ref/default *configdat* "env-override" '())) ;; Lets use this as an opportunity to put MT_RUNNAME in the environment - (setenv "MT_RUNNAME" (if inrunname inrunname (cdb:remote-run db:get-run-name-from-id #f run-id))) + (setenv "MT_RUNNAME" (if inrunname inrunname (rmt:get-run-name-from-id run-id))) (setenv "MT_RUN_AREA_HOME" *toppath*))) (define (set-item-env-vars itemdat) (for-each (lambda (item) (debug:print 2 "setenv " (car item) " " (cadr item)) @@ -136,19 +136,20 @@ ;; ;; NOTE: We run this server-side!! Do not use this global except in the runs:can-run-more-tests routine ;; (define *last-num-running-tests* 0) (define *runs:can-run-more-tests-count* 0) -(define (runs:shrink-can-run-more-tests-count) ;; the db is a dummy var so we can use cdb:remote-run +(define (runs:shrink-can-run-more-tests-count) (set! *runs:can-run-more-tests-count* 0)) ;; (/ *runs:can-run-more-tests-count* 2))) ;; Temporary globals. Move these into the logic or into common ;; (define *seen-cant-run-tests* (make-hash-table)) ;; use to track tests that we suspect cannot be run (define (runs:inc-cant-run-tests testname) (hash-table-set! *seen-cant-run-tests* testname (+ (hash-table-ref/default *seen-cant-run-tests* testname 0) 1))) + (define (runs:can-keep-running? testname n) (< (hash-table-ref/default *seen-cant-run-tests* testname 0) n)) (define *runs:denoise* (make-hash-table)) ;; key => last-time-ran @@ -163,12 +164,12 @@ (define (runs:can-run-more-tests jobgroup max-concurrent-jobs) (thread-sleep! (cond ((> *runs:can-run-more-tests-count* 20) 2);; obviously haven't had any work to do for a while (else 0))) - (let* ((num-running (cdb:remote-run db:get-count-tests-running #f)) - (num-running-in-jobgroup (cdb:remote-run db:get-count-tests-running-in-jobgroup #f jobgroup)) + (let* ((num-running (rmt:get-count-tests-running)) + (num-running-in-jobgroup (rmt:get-count-tests-running-in-jobgroup jobgroup)) (job-group-limit (config-lookup *configdat* "jobgroups" jobgroup))) (if (> (+ num-running num-running-in-jobgroup) 0) (set! *runs:can-run-more-tests-count* (+ *runs:can-run-more-tests-count* 1))) (if (not (eq? *last-num-running-tests* num-running)) (begin @@ -211,11 +212,10 @@ (all-test-names (hash-table-keys all-tests-registry)) (test-names (tests:filter-test-names all-test-names test-patts))) ;; Update the synchronous setting in the db based on the default or what is set by the user ;; This is done once here on a call to run tests rather than on every call to open-db - ;; (cdb:remote-run db:set-sync #f) (set-megatest-env-vars run-id inkeys: keys) ;; these may be needed by the launching process (if (file-exists? runconfigf) (setup-env-defaults runconfigf run-id *already-seen-runconfig-info* keyvals "pre-launch-env-vars") (debug:print 0 "WARNING: You do not have a run config file: " runconfigf)) @@ -625,20 +625,20 @@ ;; ((not (hash-table-ref/default test-registry (runs:make-full-test-name test-name item-path) #f)) (debug:print-info 4 "Pre-registering test " test-name "/" item-path " to create placeholder" ) (if (eq? *transport-type* 'fs) ;; no point in parallel registration if use fs (begin - (cdb:tests-register-test *runremote* run-id test-name item-path) + (rmt:general-call 'register-test run-id test-name item-path) (hash-table-set! test-registry (runs:make-full-test-name test-name item-path) 'done)) (let ((th (make-thread (lambda () (mutex-lock! registry-mutex) (hash-table-set! test-registry (runs:make-full-test-name test-name item-path) 'start) (mutex-unlock! registry-mutex) ;; If haven't done it before register a top level test if this is an itemized test (if (not (eq? (hash-table-ref/default test-registry (runs:make-full-test-name test-name "") #f) 'done)) - (cdb:tests-register-test *runremote* run-id test-name "")) - (cdb:tests-register-test *runremote* run-id test-name item-path) + (rmt:general-call 'register-test run-id test-name "")) + (rmt:general-call 'register-test run-id test-name item-path) (mutex-lock! registry-mutex) (hash-table-set! test-registry (runs:make-full-test-name test-name item-path) 'done) (mutex-unlock! registry-mutex)) (conc test-name "/" item-path)))) (thread-start! th))) @@ -811,11 +811,11 @@ ;; Ensure all top level tests get registered. This way they show up as "NOT_STARTED" on the dashboard ;; and it is clear they *should* have run but did not. (if (not (hash-table-ref/default test-registry (runs:make-full-test-name test-name "") #f)) (begin - (cdb:tests-register-test *runremote* run-id test-name "") + (rmt:general-call 'register-test run-id test-name "") (hash-table-set! test-registry (runs:make-full-test-name test-name "") 'done))) ;; Fast skip of tests that are already "COMPLETED" - NO! Cannot do that as the items may not have been expanded yet :( ;; (if (member (hash-table-ref/default test-registry tfullname #f) @@ -1033,12 +1033,12 @@ (hash-table-set! *test-meta-updated* test-name #t) (runs:update-test_meta test-name test-conf))) ;; itemdat => ((ripeness "overripe") (temperature "cool") (season "summer")) (let* ((new-test-path (string-intersperse (cons test-path (map cadr itemdat)) "/")) - (test-id (cdb:remote-run db:get-test-id-cached #f run-id test-name item-path)) - (testdat (if test-id (cdb:get-test-info-by-id *runremote* test-id) #f))) + (test-id (rmt:get-test-id run-id test-name item-path)) + (testdat (if test-id (rmt:get-test-info-by-id test-id) #f))) (if (not testdat) (let loop () ;; ensure that the path exists before registering the test ;; NOPE: Cannot! Don't know yet which disk area will be assigned.... ;; (system (conc "mkdir -p " new-test-path)) @@ -1045,15 +1045,15 @@ ;; ;; (open-run-close tests:register-test db run-id test-name item-path) ;; ;; NB// for the above line. I want the test to be registered long before this routine gets called! ;; - (if (not test-id)(set! test-id (cdb:remote-run db:get-test-id-cached #f run-id test-name item-path))) + (if (not test-id)(set! test-id (rmt:get-test-id-cached run-id test-name item-path))) (if (not test-id) (begin (debug:print 2 "WARN: Test not pre-created? test-name=" test-name ", item-path=" item-path ", run-id=" run-id) - (rmt:general-call 'tests-register-test run-id test-name item-path) + (rmt:general-call 'register-test run-id test-name item-path) (set! test-id (rmt:get-test-id run-id test-name item-path)))) (debug:print-info 4 "test-id=" test-id ", run-id=" run-id ", test-name=" test-name ", item-path=\"" item-path "\"") (set! testdat (rmt:get-test-info-by-id test-id)) (if (not testdat) (begin @@ -1202,11 +1202,11 @@ ;; NB// should pass in keys? ;; (define (runs:operate-on action target runnamepatt testpatt #!key (state #f)(status #f)(new-state-status #f)) (common:clear-caches) ;; clear all caches (let* ((db #f) - (keys (cdb:remote-run db:get-keys db)) + (keys (rmt:get-keys)) (rundat (mt:get-runs-by-patt keys runnamepatt target)) (header (vector-ref rundat 0)) (runs (vector-ref rundat 1)) (states (if state (string-split state ",") '())) (statuses (if status (string-split status ",") '())) @@ -1257,11 +1257,11 @@ (test-retry-time (make-hash-table)) (allow-run-time 10)) ;; seconds to allow for killing tests before just brutally killing 'em (let loop ((test (car sorted-tests)) (tal (cdr sorted-tests))) (let* ((test-id (db:test-get-id test)) - (new-test-dat (cdb:get-test-info-by-id *runremote* test-id))) + (new-test-dat (rmt:get-test-info-by-id test-id))) (if (not new-test-dat) (begin (debug:print 0 "ERROR: We have a test-id of " test-id " but no record was found. NOTE: No locking of records is done between processes, do not simultaneously remove the same run from two processes!") (if (not (null? tal)) (loop (car tal)(cdr tal)))) @@ -1328,11 +1328,11 @@ (if run-dir (debug:print 0 "WARNING: not removing " run-dir " as it either doesn't exist or is not a symlink") (debug:print 0 "NOTE: the run dir for this test is undefined. Test may have already been deleted.")) )) ;; Only delete the records *after* removing the directory. If things fail we have a record - (cdb:remote-run db:delete-test-records db #f (db:test-get-id test)) + (rmt:delete-test-records (db:test-get-id test)) (if (not (null? tal)) (loop (car tal)(cdr tal)))))) ((set-state-status) (debug:print-info 2 "new state " (car state-status) ", new status " (cadr state-status)) (mt:test-set-state-status-by-id (db:test-get-id test) (car state-status)(cadr state-status) #f) @@ -1353,14 +1353,12 @@ (let* ((dparts (string-split lasttpath "/")) (runpath (conc "/" (string-intersperse (take dparts (- (length dparts) 1)) "/")))) (debug:print 1 "Removing run: " runkey " " (db:get-value-by-header run header "runname") " and related record") - (cdb:remote-run db:delete-run db run-id) - ;; This is a pretty good place to purge old DELETED tests - (cdb:remote-run db:delete-tests-for-run db run-id) - (cdb:remote-run db:delete-old-deleted-test-records db) + (rmt:delete-run run-id) + (rmt:delete-old-deleted-test-records) (cdb:remote-run db:set-var db "DELETED_TESTS" (current-seconds)) ;; need to figure out the path to the run dir and remove it if empty ;; (if (null? (glob (conc runpath "/*"))) ;; (begin ;; (debug:print 1 "Removing run dir " runpath) Index: tests.scm ================================================================== --- tests.scm +++ tests.scm @@ -127,99 +127,10 @@ (if (null? tal) (string-intersperse (append (reverse res)(list qry)) " OR ") (loop (car tal)(cdr tal)(cons qry res))))))) #f)) -;; get the previous record for when this test was run where all keys match but runname -;; returns #f if no such test found, returns a single test record if found -;; -;; Run this server-side -;; -(define (test:get-previous-test-run-record db run-id test-name item-path) - (let* ((keys (db:get-keys db)) - (selstr (string-intersperse keys ",")) - (qrystr (string-intersperse (map (lambda (x)(conc x "=?")) keys) " AND ")) - (keyvals #f)) - ;; first look up the key values from the run selected by run-id - (sqlite3:for-each-row - (lambda (a . b) - (set! keyvals (cons a b))) - db - (conc "SELECT " selstr " FROM runs WHERE id=? ORDER BY event_time DESC;") run-id) - (if (not keyvals) - #f - (let ((prev-run-ids '())) - (apply sqlite3:for-each-row - (lambda (id) - (set! prev-run-ids (cons id prev-run-ids))) - db - (conc "SELECT id FROM runs WHERE " qrystr " AND id != ?;") (append keyvals (list run-id))) - ;; for each run starting with the most recent look to see if there is a matching test - ;; if found then return that matching test record - (debug:print 4 "selstr: " selstr ", qrystr: " qrystr ", keyvals: " keyvals ", previous run ids found: " prev-run-ids) - (if (null? prev-run-ids) #f - (let loop ((hed (car prev-run-ids)) - (tal (cdr prev-run-ids))) - (let ((results (db:get-tests-for-run db hed (conc test-name "/" item-path)'() '() #f #f #f #f #f))) - (debug:print 4 "Got tests for run-id " run-id ", test-name " test-name ", item-path " item-path ": " results) - (if (and (null? results) - (not (null? tal))) - (loop (car tal)(cdr tal)) - (if (null? results) #f - (car results)))))))))) - -;; get the previous records for when these tests were run where all keys match but runname -;; NB// Merge this with test:get-previous-test-run-records? This one looks for all matching tests -;; can use wildcards. Also can likely be factored in with get test paths? -;; -;; Run this remotely!! -;; -(define (test:get-matching-previous-test-run-records db run-id test-name item-path) - (let* ((keys (db:get-keys db)) - (selstr (string-intersperse (map (lambda (x)(vector-ref x 0)) keys) ",")) - (qrystr (string-intersperse (map (lambda (x)(conc (vector-ref x 0) "=?")) keys) " AND ")) - (keyvals #f) - (tests-hash (make-hash-table))) - ;; first look up the key values from the run selected by run-id - (sqlite3:for-each-row - (lambda (a . b) - (set! keyvals (cons a b))) - db - (conc "SELECT " selstr " FROM runs WHERE id=? ORDER BY event_time DESC;") run-id) - (if (not keyvals) - '() - (let ((prev-run-ids '())) - (apply sqlite3:for-each-row - (lambda (id) - (set! prev-run-ids (cons id prev-run-ids))) - db - (conc "SELECT id FROM runs WHERE " qrystr " AND id != ?;") (append keyvals (list run-id))) - ;; collect all matching tests for the runs then - ;; extract the most recent test and return that. - (debug:print 4 "selstr: " selstr ", qrystr: " qrystr ", keyvals: " keyvals - ", previous run ids found: " prev-run-ids) - (if (null? prev-run-ids) '() ;; no previous runs? return null - (let loop ((hed (car prev-run-ids)) - (tal (cdr prev-run-ids))) - (let ((results (db:get-tests-for-run db hed (conc test-name "/" item-path) '() '() #f #f #f #f #f))) - (debug:print 4 "Got tests for run-id " run-id ", test-name " test-name - ", item-path " item-path " results: " (intersperse results "\n")) - ;; Keep only the youngest of any test/item combination - (for-each - (lambda (testdat) - (let* ((full-testname (conc (db:test-get-testname testdat) "/" (db:test-get-item-path testdat))) - (stored-test (hash-table-ref/default tests-hash full-testname #f))) - (if (or (not stored-test) - (and stored-test - (> (db:test-get-event_time testdat)(db:test-get-event_time stored-test)))) - ;; this test is younger, store it in the hash - (hash-table-set! tests-hash full-testname testdat)))) - results) - (if (null? tal) - (map cdr (hash-table->alist tests-hash)) ;; return a list of the most recent tests - (loop (car tal)(cdr tal)))))))))) - ;; Check for waiver eligibility ;; (define (tests:check-waiver-eligibility testdat prev-testdat) (let* ((test-registry (make-hash-table)) (testconfig (tests:get-testconfig (db:test-get-testname testdat) test-registry #f)) @@ -279,20 +190,20 @@ #f)))))) (pop-directory) result))))) (define (tests:test-force-state-status! test-id state status) - (cdb:test-set-status-state *runremote* test-id status state #f) + (rmt:test-set-status-state test-id status state #f) (mt:process-triggers test-id state status)) ;; Do not rpc this one, do the underlying calls!!! (define (tests:test-set-status! test-id state status comment dat #!key (work-area #f)) (debug:print-info 4 "tests:test-set-status! test-id=" test-id ", state=" state ", status=" status ", dat=" dat) (let* ((db #f) (real-status status) (otherdat (if dat dat (make-hash-table))) - (testdat (cdb:get-test-info-by-id *runremote* test-id)) + (testdat (rmt:get-test-info-by-id test-id)) (run-id (db:test-get-run_id testdat)) (test-name (db:test-get-testname testdat)) (item-path (db:test-get-item-path testdat)) ;; before proceeding we must find out if the previous test (where all keys matched except runname) ;; was WAIVED if this test is FAIL @@ -300,11 +211,11 @@ ;; NOTES: ;; 1. Is the call to test:get-previous-run-record remotified? ;; 2. Add test for testconfig waiver propagation control here ;; (prev-test (if (equal? status "FAIL") - (cdb:remote-run test:get-previous-test-run-record #f run-id test-name item-path) + (rmt:get-previous-test-run-record run-id test-name item-path) #f)) (waived (if prev-test (if prev-test ;; true if we found a previous test in this run series (let ((prev-status (db:test-get-status prev-test)) (prev-state (db:test-get-state prev-test)) @@ -325,11 +236,11 @@ (debug:print 4 "real-status " real-status ", waived " waived ", status " status) ;; update the primary record IF state AND status are defined (if (and state status) (begin - (cdb:test-set-status-state *runremote* test-id real-status state (if waived waived comment)) + (rmt:test-set-status-state test-id real-status state (if waived waived comment)) (mt:process-triggers test-id state real-status))) ;; if status is "AUTO" then call rollup (note, this one modifies data in test ;; run area, it does remote calls under the hood. (if (and test-id state status (equal? status "AUTO")) @@ -377,11 +288,11 @@ (if (or (and (string? comment) (string-match (regexp "\\S+") comment)) waived) (let ((cmt (if waived waived comment))) - (cdb:remote-run db:test-set-comment #f test-id cmt))) + (rmt:general-call 'set-test-comment cmt test-id))) )) (define (tests:test-set-toplog! db run-id test-name logf) (cdb:client-call *runremote* 'tests:test-set-toplog #t 2 logf run-id test-name)) Index: tests/simplerun/megatest.config ================================================================== --- tests/simplerun/megatest.config +++ tests/simplerun/megatest.config @@ -3,11 +3,15 @@ RELEASE TEXT [setup] # Adjust max_concurrent_jobs to limit how much you load your machines max_concurrent_jobs 50 -tmpdb /tmp + +# Uncomment this to make the in-mem db into a disk based db (slower but good for debug) +# be aware that some unit tests will fail with this due to persistent data +# +# tmpdb /tmp # This is your link path, you can move it but it is generally better to keep it stable linktree #{shell readlink -f #{getenv PWD}/../simplelinks} # Valid values for state and status for steps, NB// It is not recommended you use this Index: tests/unittests/server.scm ================================================================== --- tests/unittests/server.scm +++ tests/unittests/server.scm @@ -28,11 +28,11 @@ ;; (test "launch server" #t (let ((pid (process-fork (lambda () ;; ;; (daemon:ize) ;; (server:launch 'http))))) ;; (set! server-pid pid) ;; (number? pid))) -(system "megatest -server - -debug 22&") +(system "megatest -server - -debug 0 &") (thread-sleep! 3) ;; need to wait for server to start. Yes, a better way is needed. (test "get-best-server" #t (begin (client:launch) (let ((dat (open-run-close tasks:get-best-server tasks:open-db))) @@ -42,24 +42,32 @@ (define *keyvals* (keys:target->keyval *keys* "a/b/c")) (test #f #t (string? (car *runremote*))) (test #f '(#t "successful login") (rmt:login)) ;; *runremote* *toppath* *my-client-signature*))) (test #f #f (rmt:get-test-info-by-id 99)) ;; get non-existant test + +;; RUNS (test #f 1 (rmt:register-run *keyvals* "firstrun" "new" "n/a" (current-user-name))) (test "get run info" "firstrun" (let ((rinfo (rmt:get-run-info 1))) (vector-ref (vector-ref rinfo 1) 3))) +(test "get runname from id" "firstrun" (rmt:get-run-name-from-id 1)) + +;; TESTS (test "get tests (no data)" '() (rmt:get-tests-for-run 1 "%" '() '() #f #f #f #f #f #f)) (test "register test" #t (rmt:general-call 'register-test 1 "test1" "")) (test "get tests (some data)" 1 (length (rmt:get-tests-for-run 1 "%" '() '() #f #f #f #f #f #f))) (test "get test id" 1 (rmt:get-test-id 1 "test1" "")) (test "get test id from main" 1 (db:get-test-id *db* 1 "test1" "")) - +(test "get keys" #t (list? (rmt:get-keys))) +(test "set comment" #t (begin (rmt:general-call 'set-test-comment "this is a comment" 1) #t)) +(test "get comment" "this is a comment" (let ((trec (rmt:get-test-info-by-id 1))) + (db:test-get-comment trec))) ;; (test "sync back" #t (begin (rmt:sync-back) #t)) ;;====================================================================== ;; D B ;;====================================================================== (test #f '(#t "exit process started") (cdb:kill-server *runremote* #f)) ;; *toppath* *my-client-signature* #f)))