Index: apimod.scm ================================================================== --- apimod.scm +++ apimod.scm @@ -1585,23 +1585,10 @@ (let* ((header (append keys remfields)) (keystr (conc (keys->keystr keys) "," (string-intersperse remfields ",")))) (list keystr header))) -;; make a query (fieldname like 'patt1' OR fieldname -(define (db:patt->like fieldname pattstr #!key (comparator " OR ")) - (let ((patts (if (string? pattstr) - (string-split pattstr ",") - '("%")))) - (string-intersperse (map (lambda (patt) - (let ((wildtype (if (substring-index "%" patt) "LIKE" "GLOB"))) - (conc fieldname " " wildtype " '" patt "'"))) - (if (null? patts) - '("") - patts)) - comparator))) - ;; register a test run with the db, this accesses the main.db and does NOT ;; use server api ;; (define (db:register-run dbstruct keyvals runname state status user contour-in) @@ -1634,53 +1621,10 @@ res))) (begin (debug:print-error 0 *default-log-port* "Called without all necessary keys") #f)))) -;; replace header and keystr with a call to runs:get-std-run-fields -;; -;; keypatts: ( (KEY1 "abc%def")(KEY2 "%") ) -;; runpatts: patt1,patt2 ... -;; -(define (db:get-runs dbstruct runpatt count offset keypatts) - (let* ((res '()) - (keys (db:get-keys dbstruct)) - (runpattstr (db:patt->like "runname" runpatt)) - (remfields (list "id" "runname" "state" "status" "owner" "event_time")) - (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) "" - (conc " AND " - (string-join - (map (lambda (keypatt) - (let ((key (car keypatt)) - (patt (cadr keypatt))) - (db:patt->like key patt))) - keypatts) - " AND "))) - " AND state != 'deleted' ORDER BY event_time DESC " - (if (number? count) - (conc " LIMIT " count) - "") - (if (number? offset) - (conc " OFFSET " offset) - "")))) - (debug:print-info 11 *default-log-port* "db:get-runs START qrystr: " qrystr " keypatts: " keypatts " offset: " offset " limit: " count) - (db:with-db dbstruct #f #f - (lambda (db) - (sqlite3:for-each-row - (lambda (a . x) - (set! res (cons (apply vector a x) res))) - db - qrystr - ))) - (debug:print-info 11 *default-log-port* "db:get-runs END qrystr: " qrystr " keypatts: " keypatts " offset: " offset " limit: " count) - (vector header res))) - (define-record simple-run target id runname state status owner event_time) (define-record-printer (simple-run x out) (fprintf out "#,(simple-run ~S ~S ~S ~S)" (simple-run-target x) (simple-run-id x) (simple-run-runname x) (time->string (seconds->local-time (simple-run-event_time x) )))) Index: commonmod.scm ================================================================== --- commonmod.scm +++ commonmod.scm @@ -28,11 +28,12 @@ (import scheme chicken data-structures extras) (import (prefix sqlite3 sqlite3:) posix typed-records srfi-18 srfi-1 files format srfi-13 matchable srfi-69 ports regex-case regex hostinfo srfi-4 - pkts (prefix dbi dbi:)) + pkts (prefix dbi dbi:) + stack) (import configfmod) (import processmod) (import stml2) @@ -14523,11 +14524,11 @@ (hash-table-keys test-names)))) ;; This could probably be refactored into one complex query ... ;; NOT PORTED - DO NOT USE YET ;; -(define (runs:rollup-run keys runname user keyvals) +#;(define (runs:rollup-run keys runname user keyvals) (debug:print 4 *default-log-port* "runs:rollup-run, keys: " keys " -runname " runname " user: " user) (let* ((db #f) ;; register run operates on the main db (new-run-id (rmt:register-run keyvals runname "new" "n/a" user (args:get-arg "-contour"))) (prev-tests (rmt:get-matching-previous-test-run-records new-run-id "%" "%")) @@ -14924,20 +14925,20 @@ ;;====================================================================== ;; synchash ;;====================================================================== -(define (synchash:make) +#;(define (synchash:make) (make-hash-table)) ;; given an alist of objects '((id obj) ...) ;; 1. remove unchanged objects from the list ;; 2. create a list of removed objects by id ;; 3. remove removed objects from synchash ;; 4. replace or add new or changed objects to synchash ;; -(define (synchash:get-delta indat synchash) +#;(define (synchash:get-delta indat synchash) (let ((deleted '()) (changed '()) (found '()) (orig-keys (hash-table-keys synchash))) (for-each @@ -14962,11 +14963,11 @@ ;; (list indat '()) ;; just for debugging )) ;; keynum => the field to use as the unique key (usually 0 but can be other field) ;; -(define (synchash:client-get proc synckey keynum synchash run-id . params) +#;(define (synchash:client-get proc synckey keynum synchash run-id . params) (let* ((data (rmt:synchash-get run-id proc synckey keynum params)) (newdat (car data)) (removs (cadr data)) (myhash (hash-table-ref/default synchash synckey #f))) (if (not myhash) @@ -14986,13 +14987,13 @@ removs) ;; WHICH ONE!? ;; data)) ;; return the changed and deleted list (list newdat removs))) ;; synchash)) -(define *synchashes* (make-hash-table)) +#;(define *synchashes* (make-hash-table)) -(define (synchash:server-get dbstruct run-id proc synckey keynum params) +#;(define (synchash:server-get dbstruct run-id proc synckey keynum params) ;; (debug:print-info 2 *default-log-port* "synckey: " synckey ", keynum: " keynum ", params: " params) (let* ((dbdat (db:get-db dbstruct run-id)) (db (db:dbdat-get-db dbdat)) (synchash (hash-table-ref/default *synchashes* synckey #f)) (newdat (apply (case proc @@ -15166,9 +15167,348 @@ db (conc "SELECT " db:test-record-qry-selector " FROM tests WHERE id in (" (string-intersperse (map conc test-ids) ",") ");")) res)))) +;; (db:with-db alldat run-id sqlite3:exec "select blah fgrom blaz;") +;; r/w is a flag to indicate if the db is modified by this query #t = yes, #f = no +;; +(define (db:with-db alldat run-id r/w proc . params) + (let* ((have-struct (alldat? alldat)) + (dbdat (if have-struct + (db:get-db alldat) + #f)) + (db (if have-struct + (db:dbdat-get-db dbdat) + alldat)) + (use-mutex (> (alldat-api-process-request-count alldat) 25)) + (db-with-db-mutex (alldat-db-with-db-mutex alldat)) + (log-port (alldat-log-port alldat))) + (if (and use-mutex + (common:low-noise-print 120 "over-50-parallel-api-requests")) + (debug:print-info 0 log-port (alldat-api-process-request-count alldat) " parallel api requests being processed in process " (current-process-id) ", throttling access")) + (if (common:low-noise-print 600 (conc "parallel-api-requests" (alldat-max-api-process-requests alldat))) + (debug:print-info 2 log-port "Parallel api request count: " (alldat-api-process-request-count alldat) " max parallel requests: " (alldat-max-api-process-requests alldat))) + (handle-exceptions + exn + (begin + (print-call-chain (current-error-port)) + (debug:print-error 0 log-port "sqlite3 issue in db:with-db, alldat=" alldat ", 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 dbdat (stack-push! (alldat-dbstack alldat) dbdat)) + res)))) + + +(define db:test-record-qry-selector (string-intersperse db:test-record-fields ",")) + +;; get a useful subset of the tests data (used in dashboard +;; use db:mintest-get-{id ,run_id,testname ...} +;; +(define (db:get-tests-for-run-mindata dbstruct run-id testpatt states statuses not-in) + (db:get-tests-for-run dbstruct run-id testpatt states statuses #f #f not-in #f #f "id,run_id,testname,state,status,event_time,item_path" 0 #f)) + +;; 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 +;; mode: +;; 'dashboard - use state = 'COMPLETED' AND status in ( statuses ) OR state in ( states ) +;; +(define (db:get-tests-for-run dbstruct run-id testpatt states statuses offset limit not-in sort-by sort-order qryvals last-update mode) + (let* ((qryvalstr (case qryvals + ((shortlist) "id,run_id,testname,item_path,state,status") + ((#f) db:test-record-qry-selector) ;; "id,run_id,testname,state,status,event_time,host,cpuload,diskfree,uname,rundir,item_path,run_duration,final_logf,comment") + (else qryvals))) + (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 (eq? mode 'dashboard) + " IN ('" + (if not-in + " NOT IN ('" + " IN ('")) + (string-intersperse states "','") + "')"))) + (statuses-qry (if (null? statuses) + #f + (conc " status " + (if (eq? mode 'dashboard) + " IN ('" + (if not-in + " NOT IN ('" + " IN ('") ) + (string-intersperse statuses "','") + "')"))) + (interim-qry (conc " AND " (if not-in "NOT " "") "( state='COMPLETED' " (if statuses-qry (conc " AND " statuses-qry " ) ") " ) ") + (if states-qry + (conc (if not-in " AND " " OR ") states-qry ) ;; " ) ") + ""))) + (states-statuses-qry + (cond + ((and states-qry statuses-qry) + (case mode + ((dashboard) + (if not-in + (conc " AND (state='COMPLETED' AND status NOT IN ('" (string-intersperse statuses "','") "')) " + " OR (state != 'COMPLETED' AND state NOT IN ('" (string-intersperse states "','") "')) ") + (conc " AND (state='COMPLETED' AND status IN ('" (string-intersperse statuses "','") "')) " + " OR (state NOT IN ('COMPLETED','DELETED') AND state IN ('" (string-intersperse states "','") "')) "))) + (else (conc " AND ( " states-qry " AND " statuses-qry " ) ")))) + (states-qry + (case mode + ((dashboard) (conc " AND " (if not-in "NOT " "") " state IN ('" (string-intersperse states "','") "') ")) ;; interim-qry) + (else (conc " AND " states-qry)))) + (statuses-qry + (case mode + ((dashboard) (conc " AND " (if not-in "NOT " "") " status IN ('" (string-intersperse statuses "','") "') ")) ;; interim-qry) + (else (conc " AND " statuses-qry)))) + (else ""))) + (tests-match-qry (tests:match->sqlqry testpatt)) + (qry (conc "SELECT " qryvalstr + (if run-id + " FROM tests WHERE run_id=? " + " FROM tests WHERE ? > 0 ") ;; should work? + (if last-update " " " AND state != 'DELETED' ") ;; if using last-update we want deleted tests? + states-statuses-qry + (if tests-match-qry (conc " AND (" tests-match-qry ") ") "") + (if last-update (conc " AND last_update >= " last-update " ") "") + (case sort-by + ((rundir) " ORDER BY length(rundir) ") + ((testname) (conc " ORDER BY testname " (if sort-order (conc sort-order ",") "") " item_path ")) + ((statestatus) (conc " ORDER BY state " (if sort-order (conc sort-order ",") "") " status ")) + ((event_time) " ORDER BY event_time ") + (else (if (string? sort-by) + (conc " ORDER BY " sort-by " ") + " "))) + (if sort-order sort-order " ") + (if limit (conc " LIMIT " limit) " ") + (if offset (conc " OFFSET " offset) " ") + ";" + ))) + (debug:print-info 8 *default-log-port* "db:get-tests-for-run run-id=" run-id ", qry=" qry) + (db:with-db dbstruct run-id #f + (lambda (db) + (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))) + db + qry + (or run-id 1) ;; 1 > 0 , for the case where we are seeking tests matching criteral for all runs + ))) + (case qryvals + ((shortlist)(map db:test-short-record->norm res)) + ((#f) res) + (else res)))) + +(define db:test-record-fields '("id" "run_id" "testname" "state" "status" "event_time" + "host" "cpuload" "diskfree" "uname" "rundir" "item_path" + "run_duration" "final_logf" "comment" "shortdir" "attemptnum" "archived" "last_update")) + +(define (db:test-short-record->norm inrec) + ;; "id,run_id,testname,item_path,state,status" + ;; "id,run_id,testname,state,status,event_time,host,cpuload,diskfree,uname,rundir,item_path,run_duration,final_logf,comment + (vector (vector-ref inrec 0) ;; id + (vector-ref inrec 1) ;; run_id + (vector-ref inrec 2) ;; testname + (vector-ref inrec 4) ;; state + (vector-ref inrec 5) ;; status + -1 "" -1 -1 "" "-" + (vector-ref inrec 3) ;; item-path + -1 "-" "-")) + +;; if itempath is #f then look only at the testname part +;; +(define (tests:match->sqlqry patterns) + (if (string? patterns) + (let ((patts (string-split patterns ","))) + (if (null? patts) ;;; no pattern(s) means no match, we will do no query + #f + (let loop ((patt (car patts)) + (tal (cdr patts)) + (res '())) + ;; (print "loop: patt: " patt ", tal " tal) + (let* ((patt-parts (string-match (regexp "^([^\\/]*)(\\/(.*)|)$") patt)) + (test-patt (cadr patt-parts)) + (item-patt (cadddr patt-parts)) + (test-qry (db:patt->like "testname" test-patt)) + (item-qry (db:patt->like "item_path" item-patt)) + (qry (conc "(" test-qry " AND " item-qry ")"))) + ;; (print "tests:match => patt-parts: " patt-parts ", test-patt: " test-patt ", item-patt: " item-patt) + (if (null? tal) + (string-intersperse (append (reverse res)(list qry)) " OR ") + (loop (car tal)(cdr tal)(cons qry res))))))) + #f)) + +;; make a query (fieldname like 'patt1' OR fieldname +(define (db:patt->like fieldname pattstr #!key (comparator " OR ")) + (let ((patts (if (string? pattstr) + (string-split pattstr ",") + '("%")))) + (string-intersperse (map (lambda (patt) + (let ((wildtype (if (substring-index "%" patt) "LIKE" "GLOB"))) + (conc fieldname " " wildtype " '" patt "'"))) + (if (null? patts) + '("") + patts)) + comparator))) + +;; replace header and keystr with a call to runs:get-std-run-fields +;; +;; keypatts: ( (KEY1 "abc%def")(KEY2 "%") ) +;; runpatts: patt1,patt2 ... +;; +(define (db:get-runs dbstruct runpatt count offset keypatts) + (let* ((res '()) + (keys (db:get-keys dbstruct)) + (runpattstr (db:patt->like "runname" runpatt)) + (remfields (list "id" "runname" "state" "status" "owner" "event_time")) + (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) "" + (conc " AND " + (string-join + (map (lambda (keypatt) + (let ((key (car keypatt)) + (patt (cadr keypatt))) + (db:patt->like key patt))) + keypatts) + " AND "))) + " AND state != 'deleted' ORDER BY event_time DESC " + (if (number? count) + (conc " LIMIT " count) + "") + (if (number? offset) + (conc " OFFSET " offset) + "")))) + (debug:print-info 11 *default-log-port* "db:get-runs START qrystr: " qrystr " keypatts: " keypatts " offset: " offset " limit: " count) + (db:with-db dbstruct #f #f + (lambda (db) + (sqlite3:for-each-row + (lambda (a . x) + (set! res (cons (apply vector a x) res))) + db + qrystr + ))) + (debug:print-info 11 *default-log-port* "db:get-runs END qrystr: " qrystr " keypatts: " keypatts " offset: " offset " limit: " count) + (vector header res))) + +(define (db:dbdat-get-path dbdat) + (if (pair? dbdat) + (cdr dbdat) + #f)) + +(define (keys->keystr keys) ;; => key1,key2,key3,additiona1, ... + (string-intersperse keys ",")) + +;; ;; legacy handling of structure for managing db's. Refactor this into dbr:? +(define (db:dbdat-get-db dbdat) + (if (pair? dbdat) + (car dbdat) + dbdat)) + +;; Get/open a database +;; if run-id => get run specific db +;; if #f => get main db +;; if db already open - return inmem +;; if db not open, open inmem, rundb and sync then return inmem +;; inuse gets set automatically for rundb's +;; +(define (db:get-db alldat) ;; run-id) + (if (stack? (alldat-dbstack alldat)) + (if (stack-empty? (alldat-dbstack alldat)) + (let ((newdb (db:open-megatest-db path: (common:get-db-tmp-area alldat)))) + ;; (stack-push! (alldat-dbstack alldat) newdb) + newdb) + (stack-pop! (alldat-dbstack alldat))) + (db:open-db alldat))) + +;; This routine creates the db if not already present. It is only called if the db is not already opened +;; +(define (db:open-db alldat #!key (areapath #f)(do-sync #t)) ;; TODO: actually use areapath + (let ((toppath (alldat-areapath alldat)) + (configdat (alldat-mtconfig alldat)) + (log-port (alldat-log-port alldat)) + (tmpdb-stack (alldat-dbstack alldat))) ;; RA => Returns the first reference in alldat + (if (stack? tmpdb-stack) + (db:get-db tmpdb-stack) ;; get previously opened db (will create new db handle if all in the stack are already used + (let* ((max-stale-tmp (configf:lookup-number configdat "server" "filling-db-max-stale-seconds" default: 10)) + (dbpath (common:get-db-tmp-area alldat)) ;; path to tmp db area + (dbexists (file-exists? dbpath)) + (tmpdbfname (conc dbpath "/megatest.db")) + (dbfexists (file-exists? tmpdbfname)) ;; (conc dbpath "/megatest.db"))) + (mtdbexists (file-exists? (conc toppath "/megatest.db"))) + + (mtdbmodtime (if mtdbexists (common:lazy-sqlite-db-modification-time (conc toppath "/megatest.db")) #f)) + (tmpdbmodtime (if dbfexists (common:lazy-sqlite-db-modification-time tmpdbfname) #f)) + (mtdb (db:open-megatest-db)) + (mtdbpath (db:dbdat-get-path mtdb)) + (tmpdb (db:open-megatest-db path: dbpath)) ;; lock-create-open dbpath db:initialize-main-db)) + (refndb (db:open-megatest-db path: dbpath name: "megatest_ref.db")) + (write-access (file-write-access? mtdbpath)) + + ;;(mtdbmodtime (if mtdbexists + ;;(common:lazy-sqlite-db-modification-time mtdbpath) + ;;#f)) ; moving this before db:open-megatest-db is + ;;called. if wal mode is on -WAL and -shm file get + ;;created with causing the tmpdbmodtime timestamp + ;;always greater than mtdbmodtime (tmpdbmodtime (if + ;;dbfexists (common:lazy-sqlite-db-modification-time + ;;tmpdbfname) #f)) + ;;if wal mode is on -WAL and -shm file get created when + ;;db:open-megatest-db is called. modtimedelta will + ;;always be < 10 so db in tmp not get synced + ;;(tmpdbmodtime (if dbfexists (db:get-last-update-time + ;;(car tmpdb)) #f)) (fmt (file-modification-time + ;;tmpdbfname)) + + (modtimedelta (and mtdbmodtime tmpdbmodtime (- mtdbmodtime tmpdbmodtime)))) - + (handle-exceptions + exn + (let ((call-chain (get-call-chain)) + (msg ((condition-property-accessor 'exn 'message) exn))) + (debug:print 0 log-port "ERROR: attempted to drop triggers on MTRA/megatest.db but failed. Error is " msg) + (set! write-access #f)) ;; if we failed to drop the triggers then we probably don't have write access + (when write-access + (sqlite3:execute (car mtdb) "drop trigger if exists update_tests_trigger") + (sqlite3:execute (car mtdb) "drop trigger if exists update_runs_trigger"))) + + ;;(print "mtdbmodtime " mtdbmodtime " tmpdbmodtime " + ;;tmpdbmodtime " mtdbpath " mtdbpath " " (conc *toppath* + ;;"/megatest.db")) (debug:print-info 13 log-port + ;;"db:open-db>> mtdbpath="mtdbpath" mtdbexists="mtdbexists" + ;;and write-access="write-access) + (if (and dbexists (not write-access)) + (begin + (set! *db-write-access* #f) + (alldat-read-only-set! alldat #t))) + (alldat-mtdb-set! alldat mtdb) + (alldat-tmpdb-set! alldat tmpdb) + (alldat-dbstack-set! alldat (make-stack)) ;; why a stack? + (stack-push! (alldat-dbstack alldat) tmpdb) ;; olddb is already a (cons db path) + (alldat-refndb-set! alldat refndb) + ;; (mutex-unlock! *rundb-mutex*) + (if (and (or (not dbfexists) + (and modtimedelta + (> modtimedelta max-stale-tmp))) ;; if db in tmp is over ten seconds older than the file in MTRA then do a sync back + do-sync) + (begin + (debug:print 1 log-port "filling db " (db:dbdat-get-path tmpdb) " with data \n from " (db:dbdat-get-path mtdb) " mod time delta: " modtimedelta) + (db:sync-tables (db:sync-all-tables-list alldat) #f mtdb refndb tmpdb) + ;touch tmp db to avoid wal mode wierdness + (set! (file-modification-time tmpdbfname) (current-seconds)) + (debug:print-info 13 log-port "db:sync-all-tables-list done.") + ) + (debug:print 4 log-port " db, " (db:dbdat-get-path tmpdb) " already exists or fresh enough, not propogating data from\n " (db:dbdat-get-path mtdb) " mod time delta: " modtimedelta) ) + ;; (db:multi-db-sync alldat 'old2new)) ;; migrate data from megatest.db automatically + tmpdb)))) ) Index: dbmod.scm ================================================================== --- dbmod.scm +++ dbmod.scm @@ -29,11 +29,11 @@ * (import scheme chicken data-structures extras) (import (prefix sqlite3 sqlite3:) posix typed-records srfi-18 srfi-69 format ports srfi-1 matchable stack regex - srfi-13) + srfi-13 stack) (import commonmod) (import configfmod) (import keysmod) (import files) @@ -46,14 +46,10 @@ ;;====================================================================== ;; Some utility stuff moved from common.scm ;;====================================================================== -(define (db:dbdat-get-path dbdat) - (if (pair? dbdat) - (cdr dbdat) - #f)) (define (common:get-area-name alldat #!optional (areapath-in #f)) (let* ((configdat (alldat-mtconfig alldat)) (areapath (or (alldat-areapath alldat) (get-environment-variable "MT_RUN_AREA_HOME") @@ -112,16 +108,10 @@ (set! dbdir dbpath) (alldat-tmppath-set! alldat dbpath) dbpath)) #f)))) -;; ;; legacy handling of structure for managing db's. Refactor this into dbr:? -(define (db:dbdat-get-db dbdat) - (if (pair? dbdat) - (car dbdat) - dbdat)) - ;; Make the dbstruct, setup up auxillary db's and call for main db at least once ;; ;; called in http-transport and replicated in rmt.scm for *local* access. ;; (define (db:setup do-sync alldat #!key (areapath #f)) @@ -137,107 +127,10 @@ (db:open-db alldat areapath: areapath do-sync: do-sync) (debug:print-info 13 log-port "Done db:open-db") ;; (set! *dbstruct-db* dbstruct) alldat)))) -;; This routine creates the db if not already present. It is only called if the db is not already opened -;; -(define (db:open-db alldat #!key (areapath #f)(do-sync #t)) ;; TODO: actually use areapath - (let ((toppath (alldat-areapath alldat)) - (configdat (alldat-mtconfig alldat)) - (log-port (alldat-log-port alldat)) - (tmpdb-stack (alldat-dbstack alldat))) ;; RA => Returns the first reference in alldat - (if (stack? tmpdb-stack) - (db:get-db tmpdb-stack) ;; get previously opened db (will create new db handle if all in the stack are already used - (let* ((max-stale-tmp (configf:lookup-number configdat "server" "filling-db-max-stale-seconds" default: 10)) - (dbpath (common:get-db-tmp-area alldat)) ;; path to tmp db area - (dbexists (file-exists? dbpath)) - (tmpdbfname (conc dbpath "/megatest.db")) - (dbfexists (file-exists? tmpdbfname)) ;; (conc dbpath "/megatest.db"))) - (mtdbexists (file-exists? (conc toppath "/megatest.db"))) - - (mtdbmodtime (if mtdbexists (common:lazy-sqlite-db-modification-time (conc toppath "/megatest.db")) #f)) - (tmpdbmodtime (if dbfexists (common:lazy-sqlite-db-modification-time tmpdbfname) #f)) - (mtdb (db:open-megatest-db)) - (mtdbpath (db:dbdat-get-path mtdb)) - (tmpdb (db:open-megatest-db path: dbpath)) ;; lock-create-open dbpath db:initialize-main-db)) - (refndb (db:open-megatest-db path: dbpath name: "megatest_ref.db")) - (write-access (file-write-access? mtdbpath)) - - ;;(mtdbmodtime (if mtdbexists - ;;(common:lazy-sqlite-db-modification-time mtdbpath) - ;;#f)) ; moving this before db:open-megatest-db is - ;;called. if wal mode is on -WAL and -shm file get - ;;created with causing the tmpdbmodtime timestamp - ;;always greater than mtdbmodtime (tmpdbmodtime (if - ;;dbfexists (common:lazy-sqlite-db-modification-time - ;;tmpdbfname) #f)) - - ;;if wal mode is on -WAL and -shm file get created when - ;;db:open-megatest-db is called. modtimedelta will - ;;always be < 10 so db in tmp not get synced - ;;(tmpdbmodtime (if dbfexists (db:get-last-update-time - ;;(car tmpdb)) #f)) (fmt (file-modification-time - ;;tmpdbfname)) - - (modtimedelta (and mtdbmodtime tmpdbmodtime (- mtdbmodtime tmpdbmodtime)))) - - (handle-exceptions - exn - (let ((call-chain (get-call-chain)) - (msg ((condition-property-accessor 'exn 'message) exn))) - (debug:print 0 log-port "ERROR: attempted to drop triggers on MTRA/megatest.db but failed. Error is " msg) - (set! write-access #f)) ;; if we failed to drop the triggers then we probably don't have write access - (when write-access - (sqlite3:execute (car mtdb) "drop trigger if exists update_tests_trigger") - (sqlite3:execute (car mtdb) "drop trigger if exists update_runs_trigger"))) - - ;;(print "mtdbmodtime " mtdbmodtime " tmpdbmodtime " - ;;tmpdbmodtime " mtdbpath " mtdbpath " " (conc *toppath* - ;;"/megatest.db")) (debug:print-info 13 log-port - ;;"db:open-db>> mtdbpath="mtdbpath" mtdbexists="mtdbexists" - ;;and write-access="write-access) - (if (and dbexists (not write-access)) - (begin - (set! *db-write-access* #f) - (alldat-read-only-set! alldat #t))) - (alldat-mtdb-set! alldat mtdb) - (alldat-tmpdb-set! alldat tmpdb) - (alldat-dbstack-set! alldat (make-stack)) ;; why a stack? - (stack-push! (alldat-dbstack alldat) tmpdb) ;; olddb is already a (cons db path) - (alldat-refndb-set! alldat refndb) - ;; (mutex-unlock! *rundb-mutex*) - (if (and (or (not dbfexists) - (and modtimedelta - (> modtimedelta max-stale-tmp))) ;; if db in tmp is over ten seconds older than the file in MTRA then do a sync back - do-sync) - (begin - (debug:print 1 log-port "filling db " (db:dbdat-get-path tmpdb) " with data \n from " (db:dbdat-get-path mtdb) " mod time delta: " modtimedelta) - (db:sync-tables (db:sync-all-tables-list alldat) #f mtdb refndb tmpdb) - ;touch tmp db to avoid wal mode wierdness - (set! (file-modification-time tmpdbfname) (current-seconds)) - (debug:print-info 13 log-port "db:sync-all-tables-list done.") - ) - (debug:print 4 log-port " db, " (db:dbdat-get-path tmpdb) " already exists or fresh enough, not propogating data from\n " (db:dbdat-get-path mtdb) " mod time delta: " modtimedelta) ) - ;; (db:multi-db-sync alldat 'old2new)) ;; migrate data from megatest.db automatically - tmpdb)))) - -;; Get/open a database -;; if run-id => get run specific db -;; if #f => get main db -;; if db already open - return inmem -;; if db not open, open inmem, rundb and sync then return inmem -;; inuse gets set automatically for rundb's -;; -(define (db:get-db alldat) ;; run-id) - (if (stack? (alldat-dbstack alldat)) - (if (stack-empty? (alldat-dbstack alldat)) - (let ((newdb (db:open-megatest-db path: (common:get-db-tmp-area alldat)))) - ;; (stack-push! (alldat-dbstack alldat) newdb) - newdb) - (stack-pop! (alldat-dbstack alldat))) - (db:open-db alldat))) (define (db:sync-all-tables-list alldat) (append (db:sync-main-list alldat) db:sync-tests-only)) @@ -336,42 +229,10 @@ db "SELECT fieldname FROM keys ORDER BY id DESC;"))) (alldat-db-keys-set! alldat res) res))) -;; (db:with-db alldat run-id sqlite3:exec "select blah fgrom blaz;") -;; r/w is a flag to indicate if the db is modified by this query #t = yes, #f = no -;; -(define (db:with-db alldat run-id r/w proc . params) - (let* ((have-struct (alldat? alldat)) - (dbdat (if have-struct - (db:get-db alldat) - #f)) - (db (if have-struct - (db:dbdat-get-db dbdat) - alldat)) - (use-mutex (> (alldat-api-process-request-count alldat) 25)) - (db-with-db-mutex (alldat-db-with-db-mutex alldat)) - (log-port (alldat-log-port alldat))) - (if (and use-mutex - (common:low-noise-print 120 "over-50-parallel-api-requests")) - (debug:print-info 0 log-port (alldat-api-process-request-count alldat) " parallel api requests being processed in process " (current-process-id) ", throttling access")) - (if (common:low-noise-print 600 (conc "parallel-api-requests" (alldat-max-api-process-requests alldat))) - (debug:print-info 2 log-port "Parallel api request count: " (alldat-api-process-request-count alldat) " max parallel requests: " (alldat-max-api-process-requests alldat))) - (handle-exceptions - exn - (begin - (print-call-chain (current-error-port)) - (debug:print-error 0 log-port "sqlite3 issue in db:with-db, alldat=" alldat ", 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 dbdat (stack-push! (alldat-dbstack alldat) dbdat)) - res)))) - ;; tbls is ( ("tablename" ( "field1" [#f|proc1] ) ( "field2" [#f|proc2] ) .... ) ) ;; db's are dbdat's ;; ;; if last-update specified ("field-name" . time-in-seconds) ;; then sync only records where field-name >= time-in-seconds @@ -2195,23 +2056,10 @@ (let* ((header (append keys remfields)) (keystr (conc (keys->keystr keys) "," (string-intersperse remfields ",")))) (list keystr header))) -;; make a query (fieldname like 'patt1' OR fieldname -(define (db:patt->like fieldname pattstr #!key (comparator " OR ")) - (let ((patts (if (string? pattstr) - (string-split pattstr ",") - '("%")))) - (string-intersperse (map (lambda (patt) - (let ((wildtype (if (substring-index "%" patt) "LIKE" "GLOB"))) - (conc fieldname " " wildtype " '" patt "'"))) - (if (null? patts) - '("") - patts)) - comparator))) - ;; register a test run with the db, this accesses the main.db and does NOT ;; use server api ;; (define (db:register-run dbstruct keyvals runname state status user contour-in) @@ -2244,53 +2092,10 @@ res))) (begin (debug:print-error 0 *default-log-port* "Called without all necessary keys") #f)))) -;; replace header and keystr with a call to runs:get-std-run-fields -;; -;; keypatts: ( (KEY1 "abc%def")(KEY2 "%") ) -;; runpatts: patt1,patt2 ... -;; -(define (db:get-runs dbstruct runpatt count offset keypatts) - (let* ((res '()) - (keys (db:get-keys dbstruct)) - (runpattstr (db:patt->like "runname" runpatt)) - (remfields (list "id" "runname" "state" "status" "owner" "event_time")) - (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) "" - (conc " AND " - (string-join - (map (lambda (keypatt) - (let ((key (car keypatt)) - (patt (cadr keypatt))) - (db:patt->like key patt))) - keypatts) - " AND "))) - " AND state != 'deleted' ORDER BY event_time DESC " - (if (number? count) - (conc " LIMIT " count) - "") - (if (number? offset) - (conc " OFFSET " offset) - "")))) - (debug:print-info 11 *default-log-port* "db:get-runs START qrystr: " qrystr " keypatts: " keypatts " offset: " offset " limit: " count) - (db:with-db dbstruct #f #f - (lambda (db) - (sqlite3:for-each-row - (lambda (a . x) - (set! res (cons (apply vector a x) res))) - db - qrystr - ))) - (debug:print-info 11 *default-log-port* "db:get-runs END qrystr: " qrystr " keypatts: " keypatts " offset: " offset " limit: " count) - (vector header res))) - (define-record simple-run target id runname state status owner event_time) (define-record-printer (simple-run x out) (fprintf out "#,(simple-run ~S ~S ~S ~S)" (simple-run-target x) (simple-run-id x) (simple-run-runname x) (time->string (seconds->local-time (simple-run-event_time x) )))) @@ -2802,117 +2607,10 @@ ;;====================================================================== ;; T E S T S ;;====================================================================== -;; 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 -;; mode: -;; 'dashboard - use state = 'COMPLETED' AND status in ( statuses ) OR state in ( states ) -;; -(define (db:get-tests-for-run dbstruct run-id testpatt states statuses offset limit not-in sort-by sort-order qryvals last-update mode) - (let* ((qryvalstr (case qryvals - ((shortlist) "id,run_id,testname,item_path,state,status") - ((#f) db:test-record-qry-selector) ;; "id,run_id,testname,state,status,event_time,host,cpuload,diskfree,uname,rundir,item_path,run_duration,final_logf,comment") - (else qryvals))) - (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 (eq? mode 'dashboard) - " IN ('" - (if not-in - " NOT IN ('" - " IN ('")) - (string-intersperse states "','") - "')"))) - (statuses-qry (if (null? statuses) - #f - (conc " status " - (if (eq? mode 'dashboard) - " IN ('" - (if not-in - " NOT IN ('" - " IN ('") ) - (string-intersperse statuses "','") - "')"))) - (interim-qry (conc " AND " (if not-in "NOT " "") "( state='COMPLETED' " (if statuses-qry (conc " AND " statuses-qry " ) ") " ) ") - (if states-qry - (conc (if not-in " AND " " OR ") states-qry ) ;; " ) ") - ""))) - (states-statuses-qry - (cond - ((and states-qry statuses-qry) - (case mode - ((dashboard) - (if not-in - (conc " AND (state='COMPLETED' AND status NOT IN ('" (string-intersperse statuses "','") "')) " - " OR (state != 'COMPLETED' AND state NOT IN ('" (string-intersperse states "','") "')) ") - (conc " AND (state='COMPLETED' AND status IN ('" (string-intersperse statuses "','") "')) " - " OR (state NOT IN ('COMPLETED','DELETED') AND state IN ('" (string-intersperse states "','") "')) "))) - (else (conc " AND ( " states-qry " AND " statuses-qry " ) ")))) - (states-qry - (case mode - ((dashboard) (conc " AND " (if not-in "NOT " "") " state IN ('" (string-intersperse states "','") "') ")) ;; interim-qry) - (else (conc " AND " states-qry)))) - (statuses-qry - (case mode - ((dashboard) (conc " AND " (if not-in "NOT " "") " status IN ('" (string-intersperse statuses "','") "') ")) ;; interim-qry) - (else (conc " AND " statuses-qry)))) - (else ""))) - (tests-match-qry (tests:match->sqlqry testpatt)) - (qry (conc "SELECT " qryvalstr - (if run-id - " FROM tests WHERE run_id=? " - " FROM tests WHERE ? > 0 ") ;; should work? - (if last-update " " " AND state != 'DELETED' ") ;; if using last-update we want deleted tests? - states-statuses-qry - (if tests-match-qry (conc " AND (" tests-match-qry ") ") "") - (if last-update (conc " AND last_update >= " last-update " ") "") - (case sort-by - ((rundir) " ORDER BY length(rundir) ") - ((testname) (conc " ORDER BY testname " (if sort-order (conc sort-order ",") "") " item_path ")) - ((statestatus) (conc " ORDER BY state " (if sort-order (conc sort-order ",") "") " status ")) - ((event_time) " ORDER BY event_time ") - (else (if (string? sort-by) - (conc " ORDER BY " sort-by " ") - " "))) - (if sort-order sort-order " ") - (if limit (conc " LIMIT " limit) " ") - (if offset (conc " OFFSET " offset) " ") - ";" - ))) - (debug:print-info 8 *default-log-port* "db:get-tests-for-run run-id=" run-id ", qry=" qry) - (db:with-db dbstruct run-id #f - (lambda (db) - (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))) - db - qry - (or run-id 1) ;; 1 > 0 , for the case where we are seeking tests matching criteral for all runs - ))) - (case qryvals - ((shortlist)(map db:test-short-record->norm res)) - ((#f) res) - (else res)))) - -(define (db:test-short-record->norm inrec) - ;; "id,run_id,testname,item_path,state,status" - ;; "id,run_id,testname,state,status,event_time,host,cpuload,diskfree,uname,rundir,item_path,run_duration,final_logf,comment - (vector (vector-ref inrec 0) ;; id - (vector-ref inrec 1) ;; run_id - (vector-ref inrec 2) ;; testname - (vector-ref inrec 4) ;; state - (vector-ref inrec 5) ;; status - -1 "" -1 -1 "" "-" - (vector-ref inrec 3) ;; item-path - -1 "-" "-")) - (define (db:get-tests-for-run-state-status dbstruct run-id testpatt) (let* ((res '()) (tests-match-qry (tests:match->sqlqry testpatt)) (qry (conc "SELECT id,testname,item_path,state,status FROM tests WHERE run_id=? " (if tests-match-qry (conc " AND (" tests-match-qry ") ") "")))) @@ -2939,16 +2637,10 @@ db "SELECT run_id,testname,item_path,state,status FROM tests WHERE id=?;" test-id))) res)) -;; get a useful subset of the tests data (used in dashboard -;; use db:mintest-get-{id ,run_id,testname ...} -;; -(define (db:get-tests-for-run-mindata dbstruct run-id testpatt states statuses not-in) - (db:get-tests-for-run dbstruct run-id testpatt states statuses #f #f not-in #f #f "id,run_id,testname,state,status,event_time,item_path" 0 #f)) - ;; do not use. ;; (define (db:get-tests-for-runs dbstruct run-ids testpatt states statuses #!key (not-in #f)(qryvals #f)) ;; (db:delay-if-busy) (let ((res '())) @@ -3198,14 +2890,10 @@ db "SELECT attemptnum FROM tests WHERE id=?;" #f test-id)))) -(define db:test-record-fields '("id" "run_id" "testname" "state" "status" "event_time" - "host" "cpuload" "diskfree" "uname" "rundir" "item_path" - "run_duration" "final_logf" "comment" "shortdir" "attemptnum" "archived" "last_update")) - ;; fields *must* be a non-empty list ;; (define (db:field->number fieldname fields) (if (null? fields) #f @@ -3216,12 +2904,10 @@ indx (if (null? tal) #f (loop (car tal)(cdr tal)(+ indx 1))))))) -(define db:test-record-qry-selector (string-intersperse db:test-record-fields ",")) - ;; NOTE: Use db:test-get* to access records ;; NOTE: This needs rundir decoding? Decide, decode here or where used? For the moment decode where used. (define (db:get-all-tests-info-by-run-id dbstruct run-id) (let* ((res '())) Index: keysmod.scm ================================================================== --- keysmod.scm +++ keysmod.scm @@ -39,10 +39,7 @@ (string-join (map (lambda (field)(conc (car field) " " (cadr field))) fields) ","))) -(define (keys->keystr keys) ;; => key1,key2,key3,additiona1, ... - (string-intersperse keys ",")) - ) Index: testsmod.scm ================================================================== --- testsmod.scm +++ testsmod.scm @@ -308,33 +308,10 @@ #t (if (null? tal) #f (loop (car tal)(cdr tal))))))))))) -;; if itempath is #f then look only at the testname part -;; -(define (tests:match->sqlqry patterns) - (if (string? patterns) - (let ((patts (string-split patterns ","))) - (if (null? patts) ;;; no pattern(s) means no match, we will do no query - #f - (let loop ((patt (car patts)) - (tal (cdr patts)) - (res '())) - ;; (print "loop: patt: " patt ", tal " tal) - (let* ((patt-parts (string-match (regexp "^([^\\/]*)(\\/(.*)|)$") patt)) - (test-patt (cadr patt-parts)) - (item-patt (cadddr patt-parts)) - (test-qry (db:patt->like "testname" test-patt)) - (item-qry (db:patt->like "item_path" item-patt)) - (qry (conc "(" test-qry " AND " item-qry ")"))) - ;; (print "tests:match => patt-parts: " patt-parts ", test-patt: " test-patt ", item-patt: " item-patt) - (if (null? tal) - (string-intersperse (append (reverse res)(list qry)) " OR ") - (loop (car tal)(cdr tal)(cons qry res))))))) - #f)) - ;; 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) (db:test-get-item-path testdat) test-registry #f))