@@ -1,7 +1,7 @@ ;;====================================================================== -;; Copyright 2006-2012, Matthew Welland. +;; Copyright 2006-2013, Matthew Welland. ;; ;; This program is made available under the GNU GPL version 2.0 or ;; greater. See the accompanying file COPYING for details. ;; ;; This program is distributed WITHOUT ANY WARRANTY; without even the @@ -27,10 +27,11 @@ (declare (uses common)) (declare (uses keys)) (declare (uses ods)) (declare (uses fs-transport)) (declare (uses client)) +(declare (uses mt)) (include "common_records.scm") (include "db_records.scm") (include "key_records.scm") (include "run_records.scm") @@ -68,14 +69,18 @@ (begin (debug:print 0 "ERROR: Attempted to open db when not in megatest area. Exiting.") (exit)))) (let* ((dbpath (conc *toppath* "/megatest.db")) ;; fname) (dbexists (file-exists? dbpath)) + (write-access (file-write-access? dbpath)) (db (sqlite3:open-database dbpath)) ;; (never-give-up-open-db dbpath)) (handler (make-busy-timeout (if (args:get-arg "-override-timeout") (string->number (args:get-arg "-override-timeout")) 136000)))) ;; 136000))) ;; 136000 = 2.2 minutes + (if (and dbexists + (not write-access)) + (set! *db-write-access* write-access)) ;; only unset so other db's also can use this control (debug:print-info 11 "open-db, dbpath=" dbpath " argv=" (argv)) (sqlite3:set-busy-handler! db handler) (if (not dbexists) (db:initialize db)) (db:set-sync db) @@ -133,16 +138,16 @@ res)) (define (db:initialize db) (debug:print-info 11 "db:initialize START") (let* ((configdat (car *configinfo*)) ;; tut tut, global warning... - (keys (config-get-fields configdat)) + (keys (keys:config-get-fields configdat)) (havekeys (> (length keys) 0)) (keystr (keys->keystr keys)) (fieldstr (keys->key/field keys))) (for-each (lambda (key) - (let ((keyn (vector-ref key 0))) + (let ((keyn key)) (if (member (string-downcase keyn) (list "runname" "state" "status" "owner" "event_time" "comment" "fail_count" "pass_count")) (begin (print "ERROR: your key cannot be named " keyn " as this conflicts with the same named field in the runs table") @@ -151,11 +156,11 @@ keys) ;; (sqlite3:execute db "PRAGMA synchronous = OFF;") (db:set-sync db) (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 INTO keys (fieldname,fieldtype) VALUES (?,?);" (key:get-fieldname key)(key:get-fieldtype key))) + (sqlite3:execute db "INSERT INTO keys (fieldname,fieldtype) VALUES (?,?);" key "TEXT")) keys) (sqlite3:execute db (conc "CREATE TABLE IF NOT EXISTS runs (id INTEGER PRIMARY KEY, " fieldstr (if havekeys "," "") "runname TEXT," @@ -492,24 +497,26 @@ (define (db:del-var db var) (debug:print-info 11 "db:del-var START " var) (sqlite3:execute db "DELETE FROM metadat WHERE var=?;" var) (debug:print-info 11 "db:del-var END " var)) -;; use a global for some primitive caching, it is just silly to re-read the db -;; over and over again for the keys since they never change +;; use a global for some primitive caching, it is just silly to +;; re-read the db over and over again for the keys since they never +;; change + +;; why get the keys from the db? why not get from the *configdat* +;; using keys:config-get-fields? (define (db:get-keys db) (if *db-keys* *db-keys* (let ((res '())) - (debug:print-info 11 "db:get-keys START (cache miss)") (sqlite3:for-each-row - (lambda (key keytype) - (set! res (cons (vector key keytype) res))) + (lambda (key) + (set! res (cons key res))) db - "SELECT fieldname,fieldtype FROM keys ORDER BY id DESC;") + "SELECT fieldname FROM keys ORDER BY id DESC;") (set! *db-keys* res) - (debug:print-info 11 "db:get-keys END (cache miss)") res))) ;; (define (db:get-value-by-header row header field) (debug:print-info 4 "db:get-value-by-header row: " row " header: " header " field: " field) @@ -522,15 +529,34 @@ (if (null? tal) #f (loop (car tal)(cdr tal)(+ n 1))))))) ;;====================================================================== ;; R U N S ;;====================================================================== + +(define (db:get-run-name-from-id db run-id) + (let ((res #f)) + (sqlite3:for-each-row + (lambda (runname) + (set! res runname)) + db + "SELECT runname FROM runs WHERE id=?;" + run-id) + res)) + +(define (db:get-run-key-val db run-id key) + (let ((res #f)) + (sqlite3:for-each-row + (lambda (val) + (set! res val)) + db + (conc "SELECT " key " FROM runs WHERE id=?;") + run-id) + res)) ;; keys list to key1,key2,key3 ... (define (runs:get-std-run-fields keys remfields) - (let* ((header (append (map key:get-fieldname keys) - remfields)) + (let* ((header (append keys remfields)) (keystr (conc (keys->keystr keys) "," (string-intersperse remfields ",")))) (list keystr header))) ;; make a query (fieldname like 'patt1' OR fieldname @@ -546,22 +572,22 @@ patts)) comparator))) ;; register a test run with the db -(define (db:register-run db keys keyvallst runname state status user) - (debug:print 3 "runs:register-run, keys: " keys " keyvallst: " keyvallst " runname: " runname " state: " state " status: " status " user: " user) - (let* ((keystr (keys->keystr keys)) +(define (db:register-run db keyvals runname state status user) + (debug:print 3 "runs:register-run runname: " runname " state: " state " status: " status " user: " user) + (let* ((keys (map car keyvals)) + (keystr (keys->keystr keys)) (comma (if (> (length keys) 0) "," "")) (andstr (if (> (length keys) 0) " AND " "")) (valslots (keys->valslots keys)) ;; ?,?,? ... - (keyvals (map cadr keyvallst)) - (allvals (append (list runname state status user) keyvals)) - (qryvals (append (list runname) keyvals)) - (key=?str (string-intersperse (map (lambda (k)(conc (key:get-fieldname k) "=?")) keys) " AND "))) - (debug:print 3 "keys: " keys " allvals: " allvals " keyvals: " keyvals) - (debug:print 2 "NOTE: using target " (string-intersperse keyvals "/") " for this run") + (allvals (append (list runname state status user) (map cadr keyvals))) + (qryvals (append (list runname) (map cadr keyvals))) + (key=?str (string-intersperse (map (lambda (k)(conc k "=?")) keys) " AND "))) + (debug:print 3 "keys: " keys " allvals: " allvals " keyvals: " keyvals " key=?str is " key=?str) + (debug:print 2 "NOTE: using target " (string-intersperse (map cadr keyvals) "/") " for this run") (if (and runname (null? (filter (lambda (x)(not x)) keyvals))) ;; there must be a better way to "apply and" (let ((res #f)) (apply sqlite3:execute db (conc "INSERT OR IGNORE INTO runs (runname,state,status,owner,event_time" comma keystr ") VALUES (?,?,?,?,strftime('%s','now')" comma valslots ");") allvals) (apply sqlite3:for-each-row @@ -587,12 +613,11 @@ (define (db:get-runs db runpatt count offset keypatts) (let* ((res '()) (keys (db:get-keys db)) (runpattstr (db:patt->like "runname" runpatt)) (remfields (list "id" "runname" "state" "status" "owner" "event_time")) - (header (append (map key:get-fieldname keys) - remfields)) + (header (append keys remfields)) (keystr (conc (keys->keystr keys) "," (string-intersperse remfields ","))) (qrystr (conc "SELECT " keystr " FROM runs WHERE (" runpattstr ") " ;; runname LIKE ? " ;; Generate: " AND x LIKE 'keypatt' ..." (if (null? keypatts) "" @@ -602,11 +627,11 @@ (let ((key (car keypatt)) (patt (cadr keypatt))) (db:patt->like key patt))) keypatts) " AND "))) - " ORDER BY event_time DESC " + " AND state != 'deleted' ORDER BY event_time DESC " (if (number? count) (conc " LIMIT " count) "") (if (number? offset) (conc " OFFSET " offset) @@ -648,11 +673,11 @@ (debug:print-info 11 "db:get-num-runs START " runpatt) (sqlite3:for-each-row (lambda (count) (set! numruns count)) db - "SELECT COUNT(id) FROM runs WHERE runname LIKE ?;" runpatt) + "SELECT COUNT(id) FROM runs WHERE runname LIKE ? AND state != 'DELETED';" runpatt) (debug:print-info 11 "db:get-num-runs END " runpatt) numruns)) ;; use (get-value-by-header (db:get-header runinfo)(db:get-row runinfo)) (define (db:get-run-info db run-id) @@ -659,20 +684,19 @@ ;;(if (hash-table-ref/default *run-info-cache* run-id #f) ;; (hash-table-ref *run-info-cache* run-id) (let* ((res #f) (keys (db:get-keys db)) (remfields (list "id" "runname" "state" "status" "owner" "event_time")) - (header (append (map key:get-fieldname keys) - remfields)) + (header (append keys remfields)) (keystr (conc (keys->keystr keys) "," (string-intersperse remfields ",")))) (debug:print-info 11 "db:get-run-info run-id: " run-id " header: " header " keystr: " keystr) (sqlite3:for-each-row (lambda (a . x) (set! res (apply vector a x))) db - (conc "SELECT " keystr " FROM runs WHERE id=?;") + (conc "SELECT " keystr " FROM runs WHERE id=? AND state != 'deleted';") run-id) (debug:print-info 11 "db:get-run-info run-id: " run-id " header: " header " keystr: " keystr) (let ((finalres (vector header res))) ;; (hash-table-set! *run-info-cache* run-id finalres) finalres))) @@ -683,11 +707,14 @@ (debug:print-info 11 "db:set-comment-for-run END run-id: " run-id " comment: " comment)) ;; 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 - (sqlite3:execute db "DELETE FROM runs WHERE id=?;" run-id)) + (sqlite3:execute db "UPDATE runs SET state='deleted' WHERE id=?;" run-id)) +;; (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)) @@ -707,54 +734,54 @@ ;;====================================================================== ;; get key val pairs for a given run-id ;; ( (FIELDNAME1 keyval1) (FIELDNAME2 keyval2) ... ) (define (db:get-key-val-pairs db run-id) - (let* ((keys (get-keys db)) + (let* ((keys (db:get-keys db)) (res '())) (debug:print-info 11 "db:get-key-val-pairs START keys: " keys " run-id: " run-id) (for-each (lambda (key) - (let ((qry (conc "SELECT " (key:get-fieldname key) " FROM runs WHERE id=?;"))) + (let ((qry (conc "SELECT " key " FROM runs WHERE id=?;"))) ;; (debug:print 0 "qry: " qry) (sqlite3:for-each-row (lambda (key-val) - (set! res (cons (list (key:get-fieldname key) key-val) res))) + (set! res (cons (list key key-val) res))) db qry run-id))) keys) (debug:print-info 11 "db:get-key-val-pairs END keys: " keys " run-id: " run-id) (reverse res))) ;; get key vals for a given run-id (define (db:get-key-vals db run-id) - (let ((mykeyvals (hash-table-ref/default *keyvals* run-id #f))) + (let ((mykeyvals (hash-table-ref/default *keyvals* run-id #f))) (if mykeyvals mykeyvals - (let* ((keys (get-keys db)) - (res '())) - (debug:print-info 11 "db:get-key-vals START keys: " keys " run-id: " run-id) - (for-each - (lambda (key) - (let ((qry (conc "SELECT " (key:get-fieldname key) " FROM runs WHERE id=?;"))) - ;; (debug:print 0 "qry: " qry) - (sqlite3:for-each-row - (lambda (key-val) - (set! res (cons key-val res))) - db qry run-id))) - keys) - (debug:print-info 11 "db:get-key-vals END keys: " keys " run-id: " run-id) + (let* ((keys (db:get-keys db)) + (res '())) + (debug:print-info 11 "db:get-key-vals START keys: " keys " run-id: " run-id) + (for-each + (lambda (key) + (let ((qry (conc "SELECT " key " FROM runs WHERE id=?;"))) + ;; (debug:print 0 "qry: " qry) + (sqlite3:for-each-row + (lambda (key-val) + (set! res (cons key-val res))) + db qry run-id))) + keys) + (debug:print-info 11 "db:get-key-vals END keys: " keys " run-id: " run-id) (let ((final-res (reverse res))) (hash-table-set! *keyvals* run-id final-res) final-res))))) ;; The target is keyval1/keyval2..., cached in *target* as it is used often (define (db:get-target db run-id) (let ((mytarg (hash-table-ref/default *target* run-id #f))) (if mytarg mytarg - (let* ((keyvals (db:get-key-vals db run-id)) - (thekey (string-intersperse (map (lambda (x)(if x x "-na-")) keyvals) "/"))) + (let* ((keyvals (db:get-key-vals db run-id)) + (thekey (string-intersperse (map (lambda (x)(if x x "-na-")) keyvals) "/"))) (hash-table-set! *target* run-id thekey) thekey)))) ;;====================================================================== ;; T E S T S @@ -762,42 +789,56 @@ ;; states and statuses are lists, turn them into ("PASS","FAIL"...) and use NOT IN ;; i.e. these lists define what to NOT show. ;; states and statuses are required to be lists, empty is ok ;; not-in #t = above behaviour, #f = must match -(define (db:get-tests-for-run db run-id testpatt states statuses - #!key (not-in #t) - (sort-by #f) ;; 'rundir 'event_time +(define (db:get-tests-for-run db run-id testpatt states statuses offset limit not-in sort-by + #!key (qryvals "id,run_id,testname,state,status,event_time,host,cpuload,diskfree,uname,rundir,item_path,run_duration,final_logf,comment") ) (debug:print-info 11 "db:get-tests-for-run START run-id=" run-id ", testpatt=" testpatt ", states=" states ", statuses=" statuses ", not-in=" not-in ", sort-by=" sort-by) (let* ((res '()) ;; if states or statuses are null then assume match all when not-in is false (states-qry (if (null? states) #f (conc " state " - (if not-in "NOT" "") - " IN ('" + (if not-in + " NOT IN ('" + " IN ('") (string-intersperse states "','") "')"))) (statuses-qry (if (null? statuses) #f (conc " status " - (if not-in "NOT" "") - " IN ('" + (if not-in + " NOT IN ('" + " IN ('") (string-intersperse statuses "','") "')"))) + (states-statuses-qry + (cond + ((and states-qry statuses-qry) + (conc " AND ( " states-qry " AND " statuses-qry " ) ")) + (states-qry + (conc " AND " states-qry)) + (statuses-qry + (conc " AND " statuses-qry)) + (else ""))) (tests-match-qry (tests:match->sqlqry testpatt)) (qry (conc "SELECT " qryvals - " FROM tests WHERE run_id=? " - (if states-qry (conc " AND " states-qry) "") - (if statuses-qry (conc " AND " statuses-qry) "") + " FROM tests WHERE run_id=? AND state != 'DELETED' " + states-statuses-qry (if tests-match-qry (conc " AND (" tests-match-qry ") ") "") (case sort-by - ((rundir) " ORDER BY length(rundir) DESC;") - ((event_time) " ORDER BY event_time ASC;") - (else ";")) + ((rundir) " ORDER BY length(rundir) DESC ") + ((event_time) " ORDER BY event_time ASC ") + (else (if (string? sort-by) + (conc " ORDER BY " sort-by) + ""))) + (if limit (conc " LIMIT " limit) "") + (if offset (conc " OFFSET " offset) "") + ";" ))) (debug:print-info 8 "db:get-tests-for-run qry=" qry) (sqlite3:for-each-row (lambda (a . b) ;; id run-id testname state status event-time host cpuload diskfree uname rundir item-path run-duration final-logf comment) (set! res (cons (apply vector a b) res))) ;; id run-id testname state status event-time host cpuload diskfree uname rundir item-path run-duration final-logf comment) res))) @@ -841,11 +882,11 @@ " IN ('" (string-intersperse statuses "','") "')"))) (tests-match-qry (tests:match->sqlqry testpatt)) (qry (conc "SELECT " qryvals - " FROM tests WHERE " + " FROM tests WHERE state != 'DELETED' AND " (if run-ids (if (list? run-ids) (conc " run_id in (" (string-intersperse (map conc run-ids) ",") ") ") (conc "run_id=" run-ids " ")) " ") ;; #f => run-ids don't filter on run-ids @@ -897,16 +938,18 @@ (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_timeobj rawdat)) - (vector-ref tmp 2)))) + (if rawdat + (begin + (set! tmp (db:string->obj rawdat)) + (vector-ref tmp 2)) + (begin + (debug:print 0 "ERROR: Communication with the server failed. Exiting if possible") + (exit 1)))))) ((zmq) (handle-exceptions exn (begin (debug:print-info 0 "cdb:client-call timeout or error. Trying again in 5 seconds") @@ -1327,12 +1406,12 @@ (cdb:client-call serverdat 'register-test #t *default-numtries* run-id test-name item-path)) (define (cdb:flush-queue serverdat) (cdb:client-call serverdat 'flush #f *default-numtries*)) -(define (cdb:kill-server serverdat) - (cdb:client-call serverdat 'killserver #t *default-numtries*)) +(define (cdb:kill-server serverdat pid) + (cdb:client-call serverdat 'killserver #t *default-numtries* pid)) (define (cdb:roll-up-pass-fail-counts serverdat run-id test-name item-path status) (cdb:client-call serverdat 'immediate #f *default-numtries* open-run-close db:roll-up-pass-fail-counts #f run-id test-name item-path status)) (define (cdb:get-test-info serverdat run-id test-name item-path) @@ -1383,10 +1462,12 @@ '(delete-tests-in-state "DELETE FROM tests WHERE state=? AND run_id=?;") '(tests:test-set-toplog "UPDATE tests SET final_logf=? WHERE run_id=? AND testname=? AND item_path='';") '(update-cpuload-diskfree "UPDATE tests SET cpuload=?,diskfree=? WHERE id=?;") '(update-run-duration "UPDATE tests SET run_duration=? WHERE id=?;") '(update-uname-host "UPDATE tests SET uname=?,host=? WHERE id=?;") + '(update-test-state "UPDATE tests SET state=? WHERE state=? AND run_id=? AND testname=? AND NOT (item_path='' AND testname IN (SELECT DISTINCT testname FROM tests WHERE testname=? AND item_path != ''));") + '(update-test-status "UPDATE tests SET status=? WHERE status like ? AND run_id=? AND testname=? AND NOT (item_path='' AND testname IN (SELECT DISTINCT testname FROM tests WHERE testname=? AND item_path != ''));") )) ;; do not run these as part of the transaction (define db:special-queries '(rollup-tests-pass-fail db:roll-up-pass-fail-counts @@ -1562,18 +1643,24 @@ (server:reply return-address qry-sig #f (list #f (conc "Login failed due to mismatch paths: " calling-path ", " *toppath*))))))) ((flush sync) (server:reply return-address qry-sig #t 1)) ;; (length data))) ((set-verbosity) (set! *verbosity* (car params)) - (server:reply return-address qry-sig #t '(#t *verbosity*))) + (server:reply return-address qry-sig #t (list #t *verbosity*))) ((killserver) - (debug:print 0 "WARNING: Server going down in 15 seconds by user request!") - (open-run-close tasks:server-deregister tasks:open-db - (car *runremote*) - pullport: (cadr *runremote*)) - (thread-start! (make-thread (lambda ()(thread-sleep! 15)(exit)))) - (server:reply return-address qry-sig #t '(#t "exit process started"))) + (let ((hostname (car *runremote*)) + (port (cadr *runremote*)) + (pid (car params))) + (debug:print 0 "WARNING: Server on " hostname ":" port " going down by user request!") + (debug:print-info 1 "current pid=" (current-process-id)) + (open-run-close tasks:server-deregister tasks:open-db + hostname + port: port) + (set! *server-run* #f) + (thread-sleep! 3) + (process-signal pid signal/kill) + (server:reply return-address qry-sig #t '(#t "exit process started")))) (else ;; not a command, i.e. is a query (debug:print 0 "ERROR: Unrecognised query/command " stmt-key) (server:reply return-address qry-sig #f 'failed))))) (else (debug:print-info 11 "Executing " stmt-key " for " params) @@ -1985,11 +2072,11 @@ (result '())) (for-each (lambda (waitontest-name) ;; by getting the tests with matching name we are looking only at the matching test ;; and related sub items - (let ((tests (cdb:remote-run db:get-tests-for-run #f run-id waitontest-name '() '())) + (let ((tests (mt:get-tests-for-run run-id waitontest-name '() '())) (ever-seen #f) (parent-waiton-met #f) (item-waiton-met #f)) (for-each (lambda (test)