Index: dashboard.scm ================================================================== --- dashboard.scm +++ dashboard.scm @@ -17,10 +17,12 @@ (use canvas-draw) (import canvas-draw-iup) (use sqlite3 srfi-1 posix regex regex-case srfi-69 typed-records sparse-vectors) ;; defstruct (import (prefix sqlite3 sqlite3:)) +(include "/nfs/site/disks/icf_fdk_cw_gwa002/srehman/fossil/dbi/dbi.scm") +(import (prefix dbi dbi:)) (declare (uses common)) (declare (uses margs)) (declare (uses keys)) (declare (uses items)) @@ -2944,12 +2946,12 @@ (cadr parts) (begin (debug:print 0 *default-log-port* "ERROR: I only know sqlite3 databases for now: " dbstr) #f))))) (if (and dbpth (file-read-access? dbpth)) - (let ((db (sqlite3:open-database dbpth))) ;; (open-database dbpth))) - (sqlite3:set-busy-handler! db (make-busy-timeout 10000)) + (let ((db (dbi:open 'sqlite3 (cons (cons ('dbname dbpth) '()))))) ;; (open-database dbpth))) + ;;(sqlite3:set-busy-handler! db (make-busy-timeout 10000)) db) #f))) ;; sqlite3:path tablename timefieldname varfieldname field1 field2 ... ;; @@ -2971,18 +2973,18 @@ (lambda (fieldname) ;; fields (let ((all-dat-qrystr (conc "SELECT " timef "," varfn "," valfn " FROM " tablen " WHERE " varfn "='" fieldname "' AND " timef " >= " tstart " AND " timef " <= " tend " ORDER BY " timef " ASC")) (zeroth-point (conc "SELECT " timef "," varfn "," valfn " FROM " tablen " WHERE " varfn "='" fieldname "' AND " timef " < " tstart " LIMIT 1"))) (hash-table-set! res-ht fieldname ;; (fetch-rows (sql db qrystr))))) (reverse - (sqlite3:fold-row + (dbi:fold-row (lambda (res t var val) (cons (vector t var val) res)) '() db all-dat-qrystr))) (let ((zeropt (handle-exceptions exn #f - (sqlite3:first-row db all-dat-qrystr)))) + (dbi:get-one-row db all-dat-qrystr)))) (if zeropt ;; NOTE: Add zeropt to the beginning of the list as the list was reversed above. (hash-table-set! res-ht fieldname (cons (apply vector tstart (cdr zeropt)) Index: datashare.scm ================================================================== --- datashare.scm +++ datashare.scm @@ -28,10 +28,12 @@ (use canvas-draw) (import canvas-draw-iup) (use sqlite3 srfi-1 posix regex regex-case srfi-69) (import (prefix sqlite3 sqlite3:)) +(include "/nfs/site/disks/icf_fdk_cw_gwa002/srehman/fossil/dbi/dbi.scm") +(import (prefix dbi dbi:)) (declare (uses configf)) (declare (uses tree)) (declare (uses margs)) ;; (declare (uses dcommon)) @@ -114,11 +116,11 @@ ;;====================================================================== (define (datashare:initialize-db db) (for-each (lambda (qry) - (sqlite3:execute db qry)) + (dbi:exec db qry)) (list "CREATE TABLE pkgs (id INTEGER PRIMARY KEY, area TEXT, version_name TEXT, @@ -142,49 +144,50 @@ (id INTEGER PRIMARY KEY, storegrp TEXT, path TEXT);"))) (define (datashare:register-data db area version-name store-type submitter quality source-path comment) - (let ((iter-qry (sqlite3:prepare db "SELECT max(iteration) FROM pkgs WHERE area=? AND version_name=?;")) + (let ((iter-qry (dbi:prepare db "SELECT max(iteration) FROM pkgs WHERE area=? AND version_name=?;")) (next-iteration 0)) - (sqlite3:with-transaction + (dbi:with-transaction db (lambda () - (sqlite3:for-each-row + (dbi:for-each-row + (lambda (output) (lambda (iteration) - (if (and (number? iteration) + (if (and (number? (vector-refiteration) (>= iteration next-iteration)) (set! next-iteration (+ iteration 1)))) - iter-qry area version-name) + iter-qry area version-name)) ;; now store the data - (sqlite3:execute db "INSERT INTO pkgs (area,version_name,iteration,store_type,submitter,source_path,quality,comment) + (dbi:exec db "INSERT INTO pkgs (area,version_name,iteration,store_type,submitter,source_path,quality,comment) VALUES (?,?,?,?,?,?,?,?);" area version-name next-iteration (conc store-type) submitter source-path quality comment))) - (sqlite3:finalize! iter-qry) + (dbi:close iter-qry) next-iteration)) (define (datashare:get-id db area version-name iteration) (let ((res #f)) - (sqlite3:for-each-row + (dbi:for-each-row (lambda (id) - (set! res id)) + (set! res (vector-ref id 0))) db "SELECT id FROM pkgs WHERE area=? AND version_name=? AND iteration=?;" area version-name iteration) res)) (define (datashare:set-stored-path db id path) - (sqlite3:execute db "UPDATE pkgs SET stored_path=? WHERE id=?;" path id)) + (dbi:exec db "UPDATE pkgs SET stored_path=? WHERE id=?;" path id)) (define (datashare:set-copied db id value) - (sqlite3:execute db "UPDATE pkgs SET copied=? WHERE id=?;" value id)) + (dbi:exec db "UPDATE pkgs SET copied=? WHERE id=?;" value id)) (define (datashare:get-pkg-record db area version-name iteration) (let ((res #f)) - (sqlite3:for-each-row - (lambda (a . b) - (set! res (apply vector a b))) + (dbi:for-each-row + (lambda (output) + (set! res output)) db "SELECT * FROM pkgs WHERE area=? AND version_name=? AND iteration=?;" area version-name iteration) @@ -206,17 +209,17 @@ ;; if there is nothing at that location then the record can be removed ;; if there are no refs for a particular pkg-id then that pkg-id is a ;; candidate for removal ;; (define (datashare:record-pkg-ref db pkg-id dest-link) - (sqlite3:execute db "INSERT INTO refs (pkg_id,destlink) VALUES (?,?);" pkg-id dest-link)) + (dbi:exec db "INSERT INTO refs (pkg_id,destlink) VALUES (?,?);" pkg-id dest-link)) (define (datashare:count-refs db pkg-id) (let ((res 0)) - (sqlite3:for-each-row + (dbi:for-each-row (lambda (count) - (set! res count)) + (set! res (vector-ref count 0)) db "SELECT count(id) FROM refs WHERE pkg_id=?;" pkg-id) res)) @@ -234,12 +237,12 @@ exn (begin (debug:print 2 *default-log-port* "ERROR: problem accessing db " dbpath ((condition-property-accessor 'exn 'message) exn)) (exit)) - (set! db (sqlite3:open-database dbpath))) - (if *db-write-access* (sqlite3:set-busy-handler! db handler)) + (set! db (dbi:open 'sqlite3 (cons (cons ('dbname dbpath) '())))) + ;;(if *db-write-access* (sqlite3:set-busy-handler! db handler)) (if (not dbexists) (begin (datashare:initialize-db db))) db) (print "ERROR: invalid path for storing database: " path)))) @@ -264,39 +267,39 @@ (apply open-run-close-no-exception-handling proc idb params))) (define (open-run-close-no-exception-handling proc idb . params) ;; (print "open-run-close-no-exception-handling START given a db=" (if idb "yes " "no ") ", params=" params) (let* ((db (cond - ((sqlite3:database? idb) idb) + ((dbi:database? idb) idb) ((not idb) (print "ERROR: cannot open-run-close with #f anymore")) ((procedure? idb) (idb)) (else (print "ERROR: cannot open-run-close with #f anymore")))) (res #f)) (set! res (apply proc db params)) - (if (not idb)(sqlite3:finalize! dbstruct)) + (if (not idb)(dbi:close dbstruct)) ;; (print "open-run-close-no-exception-handling END" ) res)) (define open-run-close open-run-close-no-exception-handling) (define (datashare:get-pkgs db area-filter version-filter iter-filter) (let ((res '())) - (sqlite3:for-each-row ;; replace with fold ... - (lambda (a . b) - (set! res (cons (list->vector (cons a b)) res))) + (dbi:for-each-row ;; replace with fold ... + (lambda (output) + (set! res (cons output res))) db (conc "SELECT id,area,version_name,store_type,copied,source_path,iteration,submitter,datetime,storegrp,datavol,quality,disk_id,comment,stored_path " " FROM pkgs WHERE area like ? AND version_name LIKE ? AND iteration " iter-filter ";") area-filter version-filter) (reverse res))) (define (datashare:get-pkg db area-name version-name #!key (iteration #f)) (let ((dat '()) (res #f)) - (sqlite3:for-each-row ;; replace with fold ... - (lambda (a . b) - (set! dat (cons (list->vector (cons a b)) dat))) + (dbi:for-each-row ;; replace with fold ... + (lambda (output) + (set! dat (cons output dat))) db (conc "SELECT id,area,version_name,store_type,copied,source_path,iteration,submitter,datetime,storegrp,datavol,quality,disk_id,comment,stored_path " " FROM pkgs WHERE area=? AND version_name=? ORDER BY iteration ASC;") area-name version-name) ;; now filter for iteration, either max if #f or specific one @@ -313,14 +316,15 @@ (loop (car tal)(cdr tal))))))))) (define (datashare:get-versions-for-area db area-name #!key (version-patt #f)) (let ((res '()) (data (make-hash-table))) - (sqlite3:for-each-row + (dbi:for-each-row + (lambda (output) (lambda (version-name submitter iteration submitted-time comment) ;; 0 1 2 3 4 - (hash-table-set! data version-name (vector version-name submitter iteration submitted-time comment))) + (hash-table-set! data version-name (vector version-name submitter iteration submitted-time comment)))) db "SELECT version_name,submitter,iteration,datetime,comment FROM pkgs WHERE area='megatest' AND version_name != 'latest' AND version_name LIKE ? ORDER BY datetime asc;" (or version-patt "%")) (map (lambda (x)(hash-table-ref data x))(sort (hash-table-keys data) string-ci>=)))) @@ -341,18 +345,18 @@ (print "Running command: rsync -av " source-path "/ " targ-path "/") (let ((th1 (make-thread (lambda () (let ((pid (process-run "rsync" (list "-av" (conc source-path "/") (conc targ-path "/"))))) (process-wait pid) (datashare:set-copied db id "yes") - (sqlite3:finalize! db))) + (dbi:close db))) "Data copy"))) (thread-start! th1)) #t) (begin (print "ERROR: Not enough space in storage area " dest-path) (datashare:set-copied db id "no") - (sqlite3:finalize! db) + (dbi:close db) #f)))) (define (datashare:get-areas configdat) (let* ((areadat (configf:get-section configdat "areas")) (areas (if areadat (map car areadat) '()))) @@ -377,11 +381,11 @@ (datashare:set-stored-path db id spath) (datashare:set-copied db id "yes") (datashare:set-copied db id "n/a") (datashare:set-latest db id area-name version iteration))) (print "ERROR: Failed to get an iteration number")) - (sqlite3:finalize! db) + (dbi:close db) (cons #t "Successfully saved data"))))) (define (datashare:get-best-storage configdat) (let* ((storage (configf:lookup configdat "settings" "storage")) (store-areas (if storage (string-split storage) '()))) @@ -607,11 +611,11 @@ (fullpath (conc basepath path))) (if (not (hash-table-ref/default installed-dat path #f)) (tree:add-node tb2 "Installed" (datashare:path->lst path))) (hash-table-set! installed-dat path (datashare:pathdat-apply-heuristics configdat fullpath)))) areas) - (sqlite3:finalize! db)))) + (dbi:close db)))) (apply (iup:button "Apply" #:action (lambda (obj) (if curr-record (let* ((area (datashare:pkg-get-area curr-record)) @@ -739,11 +743,11 @@ (else #f))) (dest-stub (configf:lookup configdat "areas" area)) (target-path (conc basepath "/" dest-stub))) (datashare:build-dir-make-link stored-path target-path) (datashare:record-pkg-ref db (datashare:pkg-get-id curr-record) target-path) - (sqlite3:finalize! db) + (dbi:close db) (print "Creating link from " stored-path " to " target-path)))))) ((publish) (if (< (length args) 3) (begin (print "ERROR: Missing arguments; " (string-intersperse args ", ")) @@ -781,11 +785,11 @@ (vector-ref x 2) (conc "\"" (time->string (seconds->local-time (vector-ref x 3))) "\"") (conc "\"" (vector-ref x 4) "\"")) (print (vector-ref x 0)))) versions) - (sqlite3:finalize! db))))) + (dbi:close db))))) ;; ease debugging by loading ~/.dashboardrc - REMOVE FROM PRODUCTION! (let ((debugcontrolf (conc (get-environment-variable "HOME") "/.datasharerc"))) (if (file-exists? debugcontrolf) (load debugcontrolf))) Index: db.scm ================================================================== --- db.scm +++ db.scm @@ -18,10 +18,13 @@ (require-extension (srfi 18) extras tcp) ;; RADT => use of require-extension? (use sqlite3 srfi-1 posix regex regex-case srfi-69 csv-xml s11n md5 message-digest base64 format dot-locking z3 typed-records) (import (prefix sqlite3 sqlite3:)) (import (prefix base64 base64:)) ;; RADT => prefix?? +(include "/nfs/site/disks/icf_fdk_cw_gwa002/srehman/fossil/dbi/dbi.scm") +(import (prefix dbi dbi:)) + (declare (unit db)) (declare (uses common)) (declare (uses keys)) (declare (uses ods)) (declare (uses client)) @@ -82,11 +85,12 @@ default (begin (debug:print-error 0 *default-log-port* " query " stmt " failed, params: " params ", error: " ((condition-property-accessor 'exn 'message) exn)) (print-call-chain (current-error-port)) default))) - (apply sqlite3:first-result db stmt params))) + ;;(apply dbi:get-one db stmt params))) + (apply dbi:get-one db stmt params))) ;; Get/open a database ;; if run-id => get run specific db ;; if #f => get main db ;; if db already open - return inmem @@ -131,11 +135,11 @@ (db:get-db dbstruct run-id) (begin (print-call-chain) (print "db:with-db called with dbdat instead of dbstruct, FIXME!!") dbstruct))) ;; cheat, allow for passing in a dbdat - (db (db:dbdat-get-db dbdat))) + (db (db:dbdat-get-db dbdat))) (handle-exceptions exn (begin (debug:print-error 0 *default-log-port* "sqlite3 issue in db:with-db, dbstruct=" dbstruct ", run-id=" run-id ", proc=" proc ", params=" params " error: " ((condition-property-accessor 'exn 'message) exn)) (print-call-chain (current-error-port))) @@ -193,11 +197,11 @@ ;; (or (configf:lookup *configdat* "setup" "dbdir") ;; (conc (configf:lookup *configdat* "setup" "linktree") "/.db"))) (define (db:set-sync db) (let ((syncprag (configf:lookup *configdat* "setup" "sychronous"))) - (sqlite3:execute db (conc "PRAGMA synchronous = " (or syncprag 0) ";")))) + (dbi:exec db (conc "PRAGMA synchronous = " (or syncprag 0) ";")))) ;; open an sql database inside a file lock ;; returns: db existed-prior-to-opening ;; RA => Returns a db handler; sets the lock if opened in writable mode ;; @@ -205,28 +209,31 @@ (let* ((parent-dir (or (pathname-directory fname)(current-directory))) ;; no parent? go local (dir-writable (file-write-access? parent-dir)) (file-exists (file-exists? fname)) (file-write (if file-exists (file-write-access? fname) - dir-writable ))) + dir-writable )) + (dbdat (cons (cons 'dbname fname) '()))) (if file-write ;; dir-writable (let (;; (lock (obtain-dot-lock fname 1 5 10)) - (db (sqlite3:open-database fname))) - (sqlite3:set-busy-handler! db (make-busy-timeout 136000)) + (db (dbi:open 'sqlite3 dbdat))) + ;;(db (sqlite3:open-database fname))) + ;;(sqlite3:set-busy-handler! db (make-busy-timeout 136000)) ;; (db:set-sync db) - (sqlite3:execute db "PRAGMA synchronous = 0;") + (dbi:exec db "PRAGMA synchronous = 0;") (if (not file-exists) (begin (if (string-match "^/tmp/.*" fname) ;; this is a file in /tmp - (sqlite3:execute db "PRAGMA journal_mode=WAL;") + (dbi:exec db "PRAGMA journal_mode=WAL;") (print "Creating " fname " in NON-WAL mode.")) (initproc db))) ;; (release-dot-lock fname) db) (begin (debug:print 2 *default-log-port* "WARNING: opening db in non-writable dir " fname) - (sqlite3:open-database fname))))) ;; ) + (dbi:open 'sqlite3 dbdat))))) + ;;(sqlite3:open-database fname))))) ;; ) ;; ;; This routine creates the db. It is only called if the db is not already opened ;; ;; ;; (define (db:open-rundb dbstruct run-id #!key (attemptnum 0)(do-not-open #f)) ;; (conc *toppath* "/megatest.db") (car *configinfo*))) ;; (let* ((dbfile (db:dbfile-path run-id)) ;; (conc toppath "/db/" run-id ".db")) @@ -238,17 +245,17 @@ ;; ;; (release-dot-lock dbpath) ;; (if (> attemptnum 2) ;; (debug:print-error 0 *default-log-port* "tried twice, cannot create/initialize db for run-id " run-id ", at path " dbpath) ;; (db:open-rundb dbstruct run-id attemptnum (+ attemptnum 1)))) ;; (db:initialize-run-id-db db) -;; (sqlite3:execute +;; (dbi:exec ;; db ;; "INSERT OR IGNORE INTO tests (id,run_id,testname,event_time,item_path,state,status) VALUES (?,?,'bogustest',strftime('%s','now'),'nowherepath','DELETED','n/a');" ;; (* run-id 30000) ;; allow for up to 30k tests per run ;; run-id) ;; ;; do a dummy query to test that the table exists and the db is truly readable -;; (sqlite3:execute db "SELECT * FROM tests WHERE id=?;" (* run-id 30000)) +;; (dbi:exec db "SELECT * FROM tests WHERE id=?;" (* run-id 30000)) ;; )))) ;; add strings db to rundb, not in use yet ;; (olddb (if *megatest-db* ;; *megatest-db* ;; (let ((db (db:open-megatest-db))) ;; (set! *megatest-db* db) @@ -345,13 +352,16 @@ (begin ;; (db:sync-touched dbstruct 0 force-sync: #t) ;; NO. Do not do this here. Instead we rely on a server to be started when there are writes, even if the server itself is not going to be used as a server. (let ((tdb (db:dbdat-get-db (dbr:dbstruct-tmpdb dbstruct))) (mdb (db:dbdat-get-db (dbr:dbstruct-mtdb dbstruct))) (rdb (db:dbdat-get-db (dbr:dbstruct-refndb dbstruct)))) - (if tdb (sqlite3:finalize! tdb)) - (if mdb (sqlite3:finalize! mdb)) - (if rdb (sqlite3:finalize! rdb)))))) + (if tdb (dbi:close tdb)) + (if mdb (dbi:close mdb)) + (if rdb (dbi:close rdb)))))) + ;;(if tdb (dbi:close tdb)) + ;;(if mdb (dbi:close mdb)) + ;;(if rdb (dbi:close rdb)))))) ;; (let ((locdbs (dbr:dbstruct-locdbs dbstruct))) ;; (if (hash-table? locdbs) ;; (for-each (lambda (run-id) ;; (db:close-run-db dbstruct run-id)) @@ -501,24 +511,24 @@ "megatest -import-megatest.db;megatest -cleanup-db") "\"\n") (exit) ;; we can not safely continue when a db was corrupted - even if fixed. ) ;; test read/write access to the database - (let ((db (sqlite3:open-database dbpath))) + (let ((db (dbi:open 'sqlite3 (cons (cons ('dbname dbpath) '()))))) (cond ((equal? fname "megatest.db") - (sqlite3:execute db "DELETE FROM tests WHERE state='DELETED';")) + (dbi:exec db "DELETE FROM tests WHERE state='DELETED';")) ((equal? fname "main.db") - (sqlite3:execute db "DELETE FROM runs WHERE state='deleted';")) + (dbi:exec db "DELETE FROM runs WHERE state='deleted';")) ((string-match "\\d.db" fname) - (sqlite3:execute db "UPDATE tests SET state='DELETED' WHERE state='DELETED';")) + (dbi:exec db "UPDATE tests SET state='DELETED' WHERE state='DELETED';")) ((equal? fname "monitor.db") - (sqlite3:execute "DELETE FROM servers WHERE state LIKE 'defunct%';")) + (dbi:exec "DELETE FROM servers WHERE state LIKE 'defunct%';")) (else - (sqlite3:execute db "vacuum;"))) + (dbi:exec db "vacuum;"))) - (finalize! db) + (dbi:close db) #t)))))) ;; tbls is ( ("tablename" ( "field1" [#f|proc1] ) ( "field2" [#f|proc2] ) .... ) ) ;; db's are dbdat's ;; @@ -548,13 +558,13 @@ 0) ;; this is the work to be done (cond ((not fromdb) (debug:print 3 *default-log-port* "WARNING: db:sync-tables called with fromdb missing") -1) ((not todb) (debug:print 3 *default-log-port* "WARNING: db:sync-tables called with todb missing") -2) - ((not (sqlite3:database? (db:dbdat-get-db fromdb))) + ((not (dbi:database? (db:dbdat-get-db fromdb))) (debug:print-error 0 *default-log-port* "db:sync-tables called with fromdb not a database " fromdb) -3) - ((not (sqlite3:database? (db:dbdat-get-db todb))) + ((not (dbi:database? (db:dbdat-get-db todb))) (debug:print-error 0 *default-log-port* "db:sync-tables called with todb not a database " todb) -4) (else (let ((stmts (make-hash-table)) ;; table-field => stmt (all-stmts '()) ;; ( ( stmt1 value1 ) ( stml2 value2 )) (numrecs (make-hash-table)) @@ -586,22 +596,21 @@ (fromdats '()) (totrecords 0) (batch-len (string->number (or (configf:lookup *configdat* "sync" "batchsize") "10"))) (todat (make-hash-table)) (count 0)) - ;; set up the field->num table (for-each (lambda (field) (hash-table-set! field->num field count) (set! count (+ count 1))) fields) ;; read the source table - (sqlite3:for-each-row - (lambda (a . b) - (set! fromdat (cons (apply vector a b) fromdat)) + (dbi:for-each-row + (lambda (output) + (set! fromdat (cons output fromdat)) (if (> (length fromdat) batch-len) (begin (set! fromdats (cons fromdat fromdats)) (set! fromdat '()) (set! totrecords (+ totrecords 1))))) @@ -614,25 +623,25 @@ (if (common:low-noise-print 120 "sync-records") (debug:print-info 4 *default-log-port* "found " totrecords " records to sync")) ;; read the target table - (sqlite3:for-each-row - (lambda (a . b) - (hash-table-set! todat a (apply vector a b))) + (dbi:for-each-row + (lambda (output) + (hash-table-set! todat (vector-ref output 0) output)) (db:dbdat-get-db todb) full-sel) ;; first pass implementation, just insert all changed rows (for-each (lambda (targdb) (let* ((db (db:dbdat-get-db targdb)) - (stmth (sqlite3:prepare db full-ins))) + (stmth (dbi:prepare db full-ins))) ;; (db:delay-if-busy targdb) ;; NO WAITING (for-each (lambda (fromdat-lst) - (sqlite3:with-transaction + (dbi:with-transaction db (lambda () (for-each ;; (lambda (fromrow) (let* ((a (vector-ref fromrow 0)) @@ -645,16 +654,16 @@ (if (and same (< i (- num-fields 1))) (loop (+ i 1)))) (if (not same) (begin - (apply sqlite3:execute stmth (vector->list fromrow)) + (dbi:exec stmth (vector->list fromrow)) (hash-table-set! numrecs tablename (+ 1 (hash-table-ref/default numrecs tablename 0))))))) fromdat-lst)) )) fromdats) - (sqlite3:finalize! stmth))) + (dbi:close stmth))) (append (list todb) slave-dbs)))) tbls) (let* ((runtime (- (current-milliseconds) start-time)) (should-print (or (debug:debug-mode 12) (common:low-noise-print 120 "db sync" (> runtime 500))))) ;; low and high sync times treated as separate. @@ -678,17 +687,17 @@ (handle-exceptions exn (if (string-match ".*duplicate.*" ((condition-property-accessor 'exn 'message) exn)) (debug:print 0 *default-log-port* "Column last_update already added to " table-name " table") (db:general-sqlite-error-dump exn "alter table " table-name " ..." #f "none")) - (sqlite3:execute + (dbi:exec frundb (conc "ALTER TABLE " table-name " ADD COLUMN last_update INTEGER DEFAULT 0"))) - (sqlite3:execute + (dbi:exec frundb (conc "DROP TRIGGER IF EXISTS update_" table-name "_trigger;")) - (sqlite3:execute + (dbi:exec frundb (conc "CREATE TRIGGER IF NOT EXISTS update_" table-name "_trigger AFTER UPDATE ON " table-name " FOR EACH ROW BEGIN UPDATE " table-name " SET last_update=(strftime('%s','now')) @@ -704,30 +713,30 @@ (handle-exceptions exn (if (string-match ".*duplicate.*" ((condition-property-accessor 'exn 'message) exn)) (debug:print 0 *default-log-port* "Column last_update already added to runs table") (db:general-sqlite-error-dump exn "alter table runs ..." #f "none")) - (sqlite3:execute + (dbi:exec maindb "ALTER TABLE runs ADD COLUMN last_update INTEGER DEFAULT 0")) ;; these schema changes don't need exception handling - (sqlite3:execute + (dbi:exec maindb "CREATE TRIGGER IF NOT EXISTS update_runs_trigger AFTER UPDATE ON runs FOR EACH ROW BEGIN UPDATE runs SET last_update=(strftime('%s','now')) WHERE id=old.id; END;") - (sqlite3:execute maindb "CREATE TABLE IF NOT EXISTS run_stats ( + (dbi:exec maindb "CREATE TABLE IF NOT EXISTS run_stats ( id INTEGER PRIMARY KEY, run_id INTEGER, state TEXT, status TEXT, count INTEGER, last_update INTEGER DEFAULT (strftime('%s','now')))") - (sqlite3:execute maindb "CREATE TRIGGER IF NOT EXISTS update_run_stats_trigger AFTER UPDATE ON run_stats + (dbi:exec maindb "CREATE TRIGGER IF NOT EXISTS update_run_stats_trigger AFTER UPDATE ON run_stats FOR EACH ROW BEGIN UPDATE run_stats SET last_update=(strftime('%s','now')) WHERE id=old.id; END;")) @@ -857,11 +866,11 @@ ;; (db:delay-if-busy mtdb) ;; (let ((testrecs (db:get-all-tests-info-by-run-id mtdb run-id))) ;; ;; (dbstruct (if toppath (make-dbr:dbstruct path: toppath local: #t) #f))) ;; (debug:print 0 *default-log-port* "INFO: Propagating " (length testrecs) " records for run-id=" run-id " to run specific db") ;; (db:replace-test-records dbstruct run-id testrecs) -;; (sqlite3:finalize! (db:dbdat-get-db (dbr:dbstruct-rundb dbstruct))))) +;; (dbi:close (db:dbdat-get-db (dbr:dbstruct-rundb dbstruct))))) ;; run-ids))) ;; now ensure all newdb data are synced to megatest.db ;; do not use the run-ids list passed in to the function ;; @@ -941,11 +950,11 @@ ;; (debug:print 0 *default-log-port* "Removing database file for deleted run " fullname) ;; (delete-file fullname))))) ;; dead-runs)))) ;; ;; (db:close-all dbstruct) - ;; (sqlite3:finalize! mdb) + ;; (dbi:close mdb) data-synced))) ;; keeping it around for debugging purposes only (define (open-run-close-no-exception-handling proc idb . params) (debug:print-info 11 *default-log-port* "open-run-close-no-exception-handling START given a db=" (if idb "yes " "no ") ", params=" params) @@ -953,17 +962,17 @@ (exit) (if (or *db-write-access* (not #t)) ;; was: (member proc * db:all-write-procs *))) (let* ((db (cond ((pair? idb) (db:dbdat-get-db idb)) - ((sqlite3:database? idb) idb) + ((dbi:database? idb) idb) ((not idb) (debug:print-error 0 *default-log-port* "cannot open-run-close with #f anymore")) ((procedure? idb) (idb)) (else (debug:print-error 0 *default-log-port* "cannot open-run-close with #f anymore")))) (res #f)) (set! res (apply proc db params)) - (if (not idb)(sqlite3:finalize! dbstruct)) + (if (not idb)(dbi:close dbstruct)) (debug:print-info 11 *default-log-port* "open-run-close-no-exception-handling END" ) res) #f)) (define (open-run-close-exception-handling proc idb . params) @@ -1005,18 +1014,18 @@ "pass_count")) (begin (print "ERROR: your key cannot be named " keyn " as this conflicts with the same named field in the runs table, you must remove your megatest.db and /.db before trying again.") (exit 1))))) keys) - (sqlite3:with-transaction + (dbi:with-transaction db (lambda () - (sqlite3:execute db "CREATE TABLE IF NOT EXISTS keys (id INTEGER PRIMARY KEY, fieldname TEXT, fieldtype TEXT, CONSTRAINT keyconstraint UNIQUE (fieldname));") + (dbi:exec 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 OR REPLACE INTO keys (fieldname,fieldtype) VALUES (?,?);" key "TEXT")) + (dbi:exec db "INSERT OR REPLACE INTO keys (fieldname,fieldtype) VALUES (?,?);" key "TEXT")) keys) - (sqlite3:execute db (conc + (dbi:exec db (conc "CREATE TABLE IF NOT EXISTS runs (id INTEGER PRIMARY KEY, \n " fieldstr (if havekeys "," "") " runname TEXT DEFAULT 'norun', state TEXT DEFAULT '', status TEXT DEFAULT '', @@ -1025,30 +1034,30 @@ comment TEXT DEFAULT '', fail_count INTEGER DEFAULT 0, pass_count INTEGER DEFAULT 0, last_update INTEGER DEFAULT (strftime('%s','now')), CONSTRAINT runsconstraint UNIQUE (runname" (if havekeys "," "") keystr "));")) - (sqlite3:execute db "CREATE TRIGGER IF NOT EXISTS update_runs_trigger AFTER UPDATE ON runs + (dbi:exec db "CREATE TRIGGER IF NOT EXISTS update_runs_trigger AFTER UPDATE ON runs FOR EACH ROW BEGIN UPDATE runs SET last_update=(strftime('%s','now')) WHERE id=old.id; END;") - (sqlite3:execute db "CREATE TABLE IF NOT EXISTS run_stats ( + (dbi:exec db "CREATE TABLE IF NOT EXISTS run_stats ( id INTEGER PRIMARY KEY, run_id INTEGER, state TEXT, status TEXT, count INTEGER, last_update INTEGER DEFAULT (strftime('%s','now')))") - (sqlite3:execute db "CREATE TRIGGER IF NOT EXISTS update_run_stats_trigger AFTER UPDATE ON run_stats + (dbi:exec db "CREATE TRIGGER IF NOT EXISTS update_run_stats_trigger AFTER UPDATE ON run_stats FOR EACH ROW BEGIN UPDATE run_stats SET last_update=(strftime('%s','now')) WHERE id=old.id; END;") - (sqlite3:execute db "CREATE TABLE IF NOT EXISTS test_meta ( + (dbi:exec db "CREATE TABLE IF NOT EXISTS test_meta ( id INTEGER PRIMARY KEY, testname TEXT DEFAULT '', author TEXT DEFAULT '', owner TEXT DEFAULT '', description TEXT DEFAULT '', @@ -1057,11 +1066,11 @@ avg_runtime REAL, avg_disk REAL, tags TEXT DEFAULT '', jobgroup TEXT DEFAULT 'default', CONSTRAINT test_meta_constraint UNIQUE (testname));") - (sqlite3:execute db "CREATE TABLE IF NOT EXISTS tasks_queue (id INTEGER PRIMARY KEY, + (dbi:exec db "CREATE TABLE IF NOT EXISTS tasks_queue (id INTEGER PRIMARY KEY, action TEXT DEFAULT '', owner TEXT, state TEXT DEFAULT 'new', target TEXT DEFAULT '', name TEXT DEFAULT '', @@ -1069,56 +1078,56 @@ keylock TEXT, params TEXT, creation_time TIMESTAMP DEFAULT (strftime('%s','now')), execution_time TIMESTAMP);") ;; archive disk areas, cached info from [archive-disks] - (sqlite3:execute db "CREATE TABLE IF NOT EXISTS archive_disks ( + (dbi:exec db "CREATE TABLE IF NOT EXISTS archive_disks ( id INTEGER PRIMARY KEY, archive_area_name TEXT, disk_path TEXT, last_df INTEGER DEFAULT -1, last_df_time TIMESTAMP DEFAULT (strftime('%s','now')), creation_time TIMESTAMP DEFAULT (strftime('%','now')));") ;; individual bup (or tar) data chunks - (sqlite3:execute db "CREATE TABLE IF NOT EXISTS archive_blocks ( + (dbi:exec db "CREATE TABLE IF NOT EXISTS archive_blocks ( id INTEGER PRIMARY KEY, archive_disk_id INTEGER, disk_path TEXT, last_du INTEGER DEFAULT -1, last_du_time TIMESTAMP DEFAULT (strftime('%s','now')), creation_time TIMESTAMP DEFAULT (strftime('%','now')));") ;; tests allocated to what chunks. reusing a chunk for a test/item_path is very efficient ;; NB// the per run/test recording of where the archive is stored is done in the test ;; record. - (sqlite3:execute db "CREATE TABLE IF NOT EXISTS archive_allocations ( + (dbi:exec db "CREATE TABLE IF NOT EXISTS archive_allocations ( id INTEGER PRIMARY KEY, archive_block_id INTEGER, testname TEXT, item_path TEXT, creation_time TIMESTAMP DEFAULT (strftime('%','now')));") ;; move this clean up call somewhere else - (sqlite3:execute db "DELETE FROM tasks_queue WHERE state='done' AND creation_time < ?;" (- (current-seconds)(* 24 60 60))) ;; remove older than 24 hrs - (sqlite3:execute db (conc "CREATE INDEX IF NOT EXISTS runs_index ON runs (runname" (if havekeys "," "") keystr ");")) - ;; (sqlite3:execute db "CREATE VIEW runs_tests AS SELECT * FROM runs INNER JOIN tests ON runs.id=tests.run_id;") - (sqlite3:execute db "CREATE TABLE IF NOT EXISTS extradat (id INTEGER PRIMARY KEY, run_id INTEGER, key TEXT, val TEXT);") - (sqlite3:execute db "CREATE TABLE IF NOT EXISTS metadat (id INTEGER PRIMARY KEY, var TEXT, val TEXT, + (dbi:exec db "DELETE FROM tasks_queue WHERE state='done' AND creation_time < ?;" (- (current-seconds)(* 24 60 60))) ;; remove older than 24 hrs + (dbi:exec db (conc "CREATE INDEX IF NOT EXISTS runs_index ON runs (runname" (if havekeys "," "") keystr ");")) + ;; (dbi:exec db "CREATE VIEW runs_tests AS SELECT * FROM runs INNER JOIN tests ON runs.id=tests.run_id;") + (dbi:exec db "CREATE TABLE IF NOT EXISTS extradat (id INTEGER PRIMARY KEY, run_id INTEGER, key TEXT, val TEXT);") + (dbi:exec db "CREATE TABLE IF NOT EXISTS metadat (id INTEGER PRIMARY KEY, var TEXT, val TEXT, CONSTRAINT metadat_constraint UNIQUE (var));") - (sqlite3:execute db "CREATE TABLE IF NOT EXISTS access_log (id INTEGER PRIMARY KEY, user TEXT, accessed TIMESTAMP, args TEXT);") + (dbi:exec db "CREATE TABLE IF NOT EXISTS access_log (id INTEGER PRIMARY KEY, user TEXT, accessed TIMESTAMP, args TEXT);") ;; Must do this *after* running patch db !! No more. ;; cannot use db:set-var since it will deadlock, hardwire the code here - (sqlite3:execute db "INSERT OR REPLACE INTO metadat (var,val) VALUES (?,?);" "MEGATEST_VERSION" (common:version-signature)) + (dbi:exec db "INSERT OR REPLACE INTO metadat (var,val) VALUES (?,?);" "MEGATEST_VERSION" (common:version-signature)) (debug:print-info 11 *default-log-port* "db:initialize END"))))) ;;====================================================================== ;; R U N S P E C I F I C D B ;;====================================================================== (define (db:initialize-run-id-db db) - (sqlite3:with-transaction + (dbi:with-transaction db (lambda () - (sqlite3:execute db "CREATE TABLE IF NOT EXISTS tests + (dbi:exec db "CREATE TABLE IF NOT EXISTS tests (id INTEGER PRIMARY KEY, run_id INTEGER DEFAULT -1, testname TEXT DEFAULT 'noname', host TEXT DEFAULT 'n/a', cpuload REAL DEFAULT -1, @@ -1138,18 +1147,18 @@ fail_count INTEGER DEFAULT 0, pass_count INTEGER DEFAULT 0, archived INTEGER DEFAULT 0, -- 0=no, > 1=archive block id where test data can be found last_update INTEGER DEFAULT (strftime('%s','now')), CONSTRAINT testsconstraint UNIQUE (run_id, testname, item_path));") - (sqlite3:execute db "CREATE INDEX IF NOT EXISTS tests_index ON tests (run_id, testname, item_path);") - (sqlite3:execute db "CREATE TRIGGER IF NOT EXISTS update_tests_trigger AFTER UPDATE ON tests + (dbi:exec db "CREATE INDEX IF NOT EXISTS tests_index ON tests (run_id, testname, item_path);") + (dbi:exec db "CREATE TRIGGER IF NOT EXISTS update_tests_trigger AFTER UPDATE ON tests FOR EACH ROW BEGIN UPDATE tests SET last_update=(strftime('%s','now')) WHERE id=old.id; END;") - (sqlite3:execute db "CREATE TABLE IF NOT EXISTS test_steps + (dbi:exec db "CREATE TABLE IF NOT EXISTS test_steps (id INTEGER PRIMARY KEY, test_id INTEGER, stepname TEXT, state TEXT DEFAULT 'NOT_STARTED', status TEXT DEFAULT 'n/a', @@ -1156,18 +1165,18 @@ event_time TIMESTAMP, comment TEXT DEFAULT '', logfile TEXT DEFAULT '', last_update INTEGER DEFAULT (strftime('%s','now')), CONSTRAINT test_steps_constraint UNIQUE (test_id,stepname,state));") - (sqlite3:execute db "CREATE INDEX IF NOT EXISTS teststeps_index ON tests (run_id, testname, item_path);") - (sqlite3:execute db "CREATE TRIGGER IF NOT EXISTS update_teststeps_trigger AFTER UPDATE ON test_steps + (dbi:exec db "CREATE INDEX IF NOT EXISTS teststeps_index ON tests (run_id, testname, item_path);") + (dbi:exec db "CREATE TRIGGER IF NOT EXISTS update_teststeps_trigger AFTER UPDATE ON test_steps FOR EACH ROW BEGIN UPDATE test_steps SET last_update=(strftime('%s','now')) WHERE id=old.id; END;") - (sqlite3:execute db "CREATE TABLE IF NOT EXISTS test_data (id INTEGER PRIMARY KEY, + (dbi:exec db "CREATE TABLE IF NOT EXISTS test_data (id INTEGER PRIMARY KEY, test_id INTEGER, category TEXT DEFAULT '', variable TEXT, value REAL, expected REAL, @@ -1176,26 +1185,26 @@ comment TEXT DEFAULT '', status TEXT DEFAULT 'n/a', type TEXT DEFAULT '', last_update INTEGER DEFAULT (strftime('%s','now')), CONSTRAINT test_data_constraint UNIQUE (test_id,category,variable));") - (sqlite3:execute db "CREATE INDEX IF NOT EXISTS test_data_index ON test_data (test_id);") - (sqlite3:execute db "CREATE TRIGGER IF NOT EXISTS update_test_data_trigger AFTER UPDATE ON test_data + (dbi:exec db "CREATE INDEX IF NOT EXISTS test_data_index ON test_data (test_id);") + (dbi:exec db "CREATE TRIGGER IF NOT EXISTS update_test_data_trigger AFTER UPDATE ON test_data FOR EACH ROW BEGIN UPDATE test_data SET last_update=(strftime('%s','now')) WHERE id=old.id; END;") - (sqlite3:execute db "CREATE TABLE IF NOT EXISTS test_rundat ( + (dbi:exec db "CREATE TABLE IF NOT EXISTS test_rundat ( id INTEGER PRIMARY KEY, test_id INTEGER, update_time TIMESTAMP, cpuload INTEGER DEFAULT -1, diskfree INTEGER DEFAULT -1, diskusage INTGER DEFAULT -1, run_duration INTEGER DEFAULT 0);") - (sqlite3:execute db "CREATE TABLE IF NOT EXISTS archives ( + (dbi:exec db "CREATE TABLE IF NOT EXISTS archives ( id INTEGER PRIMARY KEY, test_id INTEGER, state TEXT DEFAULT 'new', status TEXT DEFAULT 'n/a', archive_type TEXT DEFAULT 'bup', @@ -1214,24 +1223,26 @@ (define (db:archive-get-allocations dbstruct testname itempath dneeded) (let* ((dbdat (db:get-db dbstruct #f)) ;; archive tables are in main.db (db (db:dbdat-get-db dbdat)) (res '()) (blocks '())) ;; a block is an archive chunck that can be added too if there is space - (sqlite3:for-each-row + (dbi:for-each-row + (lambda (output) (lambda (id archive-disk-id disk-path last-du last-du-time) - (set! res (cons (vector id archive-disk-id disk-path last-du last-du-time) res))) + (set! res (cons (vector id archive-disk-id disk-path last-du last-du-time) res)))) db "SELECT b.id,b.archive_disk_id,b.disk_path,b.last_du,b.last_du_time FROM archive_blocks AS b INNER JOIN archive_allocations AS a ON a.archive_block_id=b.id WHERE a.testname=? AND a.item_path=?;" testname itempath) ;; Now res has list of candidate paths, look in archive_disks for candidate with potential free space (if (null? res) '() - (sqlite3:for-each-row + (dbi:for-each-row + (lambda (output) (lambda (id archive-area-name disk-path last-df last-df-time) - (set! blocks (cons (vector id archive-area-name disk-path last-df last-df-time) blocks))) + (set! blocks (cons (vector id archive-area-name disk-path last-df last-df-time) blocks)))) db (conc "SELECT d.id,d.archive_area_name,disk_path,last_df,last_df_time FROM archive_disks AS d INNER JOIN archive_blocks AS b ON d.id=b.archive_disk_id WHERE b.id IN (" (string-intersperse (map conc res) ",") ") AND @@ -1244,24 +1255,25 @@ ;; (define (db:archive-register-disk dbstruct bdisk-name bdisk-path df) (let* ((dbdat (db:get-db dbstruct #f)) ;; archive tables are in main.db (db (db:dbdat-get-db dbdat)) (res #f)) - (sqlite3:for-each-row + (dbi:for-each-row + (lambda (output) (lambda (id) - (set! res id)) + (set! res id))) db "SELECT id FROM archive_disks WHERE archive_area_name=? AND disk_path=?;" bdisk-name bdisk-path) (if res ;; record exists, update df and return id (begin - (sqlite3:execute db "UPDATE archive_disks SET last_df=?,last_df_time=(strftime('%s','now')) + (dbi:exec db "UPDATE archive_disks SET last_df=?,last_df_time=(strftime('%s','now')) WHERE archive_area_name=? AND disk_path=?;" df bdisk-name bdisk-path) res) (begin - (sqlite3:execute + (dbi:exec db "INSERT OR REPLACE INTO archive_disks (archive_area_name,disk_path,last_df) VALUES (?,?,?);" bdisk-name bdisk-path df) (db:archive-register-disk dbstruct bdisk-name bdisk-path df))))) @@ -1273,24 +1285,25 @@ (define (db:archive-register-block-name dbstruct bdisk-id archive-path #!key (du #f)) (let* ((dbdat (db:get-db dbstruct #f)) ;; archive tables are in main.db (db (db:dbdat-get-db dbdat)) (res #f)) ;; first look to see if this path is already registered - (sqlite3:for-each-row + (dbi:for-each-row + (lambda (output) (lambda (id) - (set! res id)) + (set! res id))) db "SELECT id FROM archive_blocks WHERE archive_disk_id=? AND disk_path=?;" bdisk-id archive-path) (if res ;; record exists, update du if applicable and return res (begin - (if du (sqlite3:exectute db "UPDATE archive_blocks SET last_du=?,last_du_time=(strftime('%s','now')) + (if du (dbi:exec db "UPDATE archive_blocks SET last_du=?,last_du_time=(strftime('%s','now')) WHERE archive_disk_id=? AND disk_path=?;" bdisk-id archive-path du)) res) (begin - (sqlite3:execute db "INSERT OR REPLACE INTO archive_blocks (archive_disk_id,disk_path,last_du) + (dbi:exec db "INSERT OR REPLACE INTO archive_blocks (archive_disk_id,disk_path,last_du) VALUES (?,?,?);" bdisk-id archive-path (or du 0)) (db:archive-register-block-name dbstruct bdisk-id archive-path du: du))))) @@ -1300,11 +1313,11 @@ (db:with-db dbstruct run-id #f (lambda (db) - (sqlite3:execute db "UPDATE tests SET archived=? WHERE id=?;" + (dbi:exec db "UPDATE tests SET archived=? WHERE id=?;" archive-block-id test-id)))) ;; Look up the archive block info given a block-id ;; (define (db:test-get-archive-block-info dbstruct archive-block-id) @@ -1312,14 +1325,15 @@ dbstruct #f #f (lambda (db) (let ((res #f)) - (sqlite3:for-each-row + (dbi:for-each-row + (lambda (output) ;; 0 1 2 3 4 5 (lambda (id archive-disk-id disk-path last-du last-du-time creation-time) - (set! res (vector id archive-disk-id disk-path last-du last-du-time creation-time))) + (set! res (vector id archive-disk-id disk-path last-du last-du-time creation-time)))) db "SELECT id,archive_disk_id,disk_path,last_du,last_du_time,creation_time FROM archive_blocks WHERE id=?;" archive-block-id) res)))) @@ -1326,43 +1340,43 @@ ;; (define (db:archive-allocate-testsuite/area-to-block block-id testsuite-name areakey) ;; (let* ((dbdat (db:get-db dbstruct #f)) ;; archive tables are in main.db ;; (db (db:dbdat-get-db dbdat)) ;; (res '()) ;; (blocks '())) ;; a block is an archive chunck that can be added too if there is space -;; (sqlite3:for-each-row #f) +;; (dbi:for-each-row #f) ;;====================================================================== ;; L O G G I N G D B ;;====================================================================== (define (open-logging-db) (let* ((dbpath (conc (if *toppath* (conc *toppath* "/") "") "logging.db")) ;; fname) (dbexists (file-exists? dbpath)) - (db (sqlite3:open-database dbpath)) + (db (dbi:open 'sqlite3 (cons (cons ('dbname dbpath) '())))) (handler (make-busy-timeout (if (args:get-arg "-override-timeout") (string->number (args:get-arg "-override-timeout")) 136000)))) ;; 136000))) - (sqlite3:set-busy-handler! db handler) + ;;(sqlite3:set-busy-handler! db handler) (if (not dbexists) (begin - (sqlite3:execute db "CREATE TABLE IF NOT EXISTS log (id INTEGER PRIMARY KEY,event_time TIMESTAMP DEFAULT (strftime('%s','now')),logline TEXT,pwd TEXT,cmdline TEXT,pid INTEGER);") - (db:set-sync db) ;; (sqlite3:execute db (conc "PRAGMA synchronous = 0;")) + (dbi:exec db "CREATE TABLE IF NOT EXISTS log (id INTEGER PRIMARY KEY,event_time TIMESTAMP DEFAULT (strftime('%s','now')),logline TEXT,pwd TEXT,cmdline TEXT,pid INTEGER);") + (db:set-sync db) ;; (dbi:exec db (conc "PRAGMA synchronous = 0;")) )) db)) (define (db:log-local-event . loglst) (let ((logline (apply conc loglst))) (db:log-event logline))) (define (db:log-event logline) (let ((db (open-logging-db))) - (sqlite3:execute db "INSERT INTO log (logline,pwd,cmdline,pid) VALUES (?,?,?,?);" + (dbi:exec db "INSERT INTO log (logline,pwd,cmdline,pid) VALUES (?,?,?,?);" logline (current-directory) (string-intersperse (argv) " ") (current-process-id)) - (sqlite3:finalize! db) + (dbi:close db) logline)) ;;====================================================================== ;; D B U T I L S ;;====================================================================== @@ -1389,33 +1403,35 @@ ;; HOWEVER: this code in run:test seems to work fine ;; (> (- (current-seconds)(+ (db:test-get-event_time testdat) ;; (db:test-get-run_duration testdat))) ;; 600) ;; (db:delay-if-busy dbdat) - (sqlite3:for-each-row + (dbi:for-each-row + (lambda (output) (lambda (test-id run-dir uname testname item-path) (if (and (equal? uname "n/a") (equal? item-path "")) ;; this is a toplevel test ;; what to do with toplevel? call rollup? (begin (set! toplevels (cons (list test-id run-dir uname testname item-path run-id) toplevels)) (debug:print-info 0 *default-log-port* "Found old toplevel test in RUNNING state, test-id=" test-id)) - (set! incompleted (cons (list test-id run-dir uname testname item-path run-id) incompleted)))) + (set! incompleted (cons (list test-id run-dir uname testname item-path run-id) incompleted))))) db "SELECT id,rundir,uname,testname,item_path FROM tests WHERE run_id=? AND (strftime('%s','now') - event_time) > (run_duration + ?) AND state IN ('RUNNING','REMOTEHOSTSTART');" run-id deadtime) ;; in LAUNCHED for more than one day. Could be long due to job queues TODO/BUG: Need override for this in config ;; ;; (db:delay-if-busy dbdat) - (sqlite3:for-each-row + (dbi:for-each-row + (lambda (output) (lambda (test-id run-dir uname testname item-path) (if (and (equal? uname "n/a") (equal? item-path "")) ;; this is a toplevel test ;; what to do with toplevel? call rollup? (set! toplevels (cons (list test-id run-dir uname testname item-path run-id) toplevels)) - (set! oldlaunched (cons (list test-id run-dir uname testname item-path run-id) oldlaunched)))) + (set! oldlaunched (cons (list test-id run-dir uname testname item-path run-id) oldlaunched))))) db "SELECT id,rundir,uname,testname,item_path FROM tests WHERE run_id=? AND (strftime('%s','now') - event_time) > 86400 AND state IN ('LAUNCHED');" run-id) (debug:print-info 18 *default-log-port* "Found " (length oldlaunched) " old LAUNCHED items, " (length toplevels) " old LAUNCHED toplevel tests and " (length incompleted) " tests marked RUNNING but apparently dead.") @@ -1453,33 +1469,35 @@ ;; HOWEVER: this code in run:test seems to work fine ;; (> (- (current-seconds)(+ (db:test-get-event_time testdat) ;; (db:test-get-run_duration testdat))) ;; 600) ;; (db:delay-if-busy dbdat) - (sqlite3:for-each-row + (dbi:for-each-row + (lambda (output) (lambda (test-id run-dir uname testname item-path) (if (and (equal? uname "n/a") (equal? item-path "")) ;; this is a toplevel test ;; what to do with toplevel? call rollup? (begin (set! toplevels (cons (list test-id run-dir uname testname item-path run-id) toplevels)) (debug:print-info 0 *default-log-port* "Found old toplevel test in RUNNING state, test-id=" test-id)) - (set! incompleted (cons (list test-id run-dir uname testname item-path run-id) incompleted)))) + (set! incompleted (cons (list test-id run-dir uname testname item-path run-id) incompleted))))) db "SELECT id,rundir,uname,testname,item_path FROM tests WHERE run_id=? AND (strftime('%s','now') - event_time) > (run_duration + ?) AND state IN ('RUNNING','REMOTEHOSTSTART');" run-id deadtime) ;; in LAUNCHED for more than one day. Could be long due to job queues TODO/BUG: Need override for this in config ;; ;; (db:delay-if-busy dbdat) - (sqlite3:for-each-row + (dbi:for-each-row + (lambda (output) (lambda (test-id run-dir uname testname item-path) (if (and (equal? uname "n/a") (equal? item-path "")) ;; this is a toplevel test ;; what to do with toplevel? call rollup? (set! toplevels (cons (list test-id run-dir uname testname item-path run-id) toplevels)) - (set! oldlaunched (cons (list test-id run-dir uname testname item-path run-id) oldlaunched)))) + (set! oldlaunched (cons (list test-id run-dir uname testname item-path run-id) oldlaunched))))) db "SELECT id,rundir,uname,testname,item_path FROM tests WHERE run_id=? AND (strftime('%s','now') - event_time) > 86400 AND state IN ('LAUNCHED');" run-id) (debug:print-info 18 *default-log-port* "Found " (length oldlaunched) " old LAUNCHED items, " (length toplevels) " old LAUNCHED toplevel tests and " (length incompleted) " tests marked RUNNING but apparently dead.") @@ -1497,11 +1515,11 @@ (min-incompleted-ids (map car incompleted)) ;; do 'em all (all-ids (append min-incompleted-ids (map car oldlaunched)))) (if (> (length all-ids) 0) (begin (debug:print 0 *default-log-port* "WARNING: Marking test(s); " (string-intersperse (map conc all-ids) ", ") " as INCOMPLETE") - (sqlite3:execute + (dbi:exec db (conc "UPDATE tests SET state='INCOMPLETE' WHERE run_id=? AND id IN (" (string-intersperse (map conc all-ids) ",") ");") run-id)))) @@ -1534,42 +1552,43 @@ ;; b. .... ;; (define (db:clean-up dbdat) ;; (debug:print 0 *default-log-port* "WARNING: db clean up not fully ported to v1.60, cleanup action will be on megatest.db") (let* ((db (db:dbdat-get-db dbdat)) - (count-stmt (sqlite3:prepare db "SELECT (SELECT count(id) FROM tests)+(SELECT count(id) FROM runs);")) - (statements - (map (lambda (stmt) - (sqlite3:prepare db stmt)) - (list - ;; delete all tests that belong to runs that are 'deleted' - "DELETE FROM tests WHERE run_id in (SELECT id FROM runs WHERE state='deleted');" - ;; delete all tests that are 'DELETED' - "DELETE FROM tests WHERE state='DELETED';" - ;; delete all tests that have no run - "DELETE FROM tests WHERE run_id NOT IN (SELECT DISTINCT id FROM runs);" - ;; delete all runs that are state='deleted' - "DELETE FROM runs WHERE state='deleted';" - ;; delete empty runs - "DELETE FROM runs WHERE id NOT IN (SELECT DISTINCT r.id FROM runs AS r INNER JOIN tests AS t ON t.run_id=r.id);" - )))) + (count-stmt (dbi:prepare db "SELECT (SELECT count(id) FROM tests)+(SELECT count(id) FROM runs);")) + (statements + (map (lambda (stmt) + (dbi:prepare db stmt)) + (list + ;; delete all tests that belong to runs that are 'deleted' + "DELETE FROM tests WHERE run_id in (SELECT id FROM runs WHERE state='deleted');" + ;; delete all tests that are 'DELETED' + "DELETE FROM tests WHERE state='DELETED';" + ;; delete all tests that have no run + "DELETE FROM tests WHERE run_id NOT IN (SELECT DISTINCT id FROM runs);" + ;; delete all runs that are state='deleted' + "DELETE FROM runs WHERE state='deleted';" + ;; delete empty runs + "DELETE FROM runs WHERE id NOT IN (SELECT DISTINCT r.id FROM runs AS r INNER JOIN tests AS t ON t.run_id=r.id);" + )))) ;; (db:delay-if-busy dbdat) - (sqlite3:with-transaction + (dbi:with-transaction db (lambda () - (sqlite3:for-each-row (lambda (tot) - (debug:print-info 0 *default-log-port* "Records count before clean: " tot)) - count-stmt) - (map sqlite3:execute statements) - (sqlite3:for-each-row (lambda (tot) - (debug:print-info 0 *default-log-port* "Records count after clean: " tot)) - count-stmt))) - (map sqlite3:finalize! statements) - (sqlite3:finalize! count-stmt) + (dbi:for-each-row (lambda (tot) + (debug:print-info 0 *default-log-port* "Records count before clean: " tot)) + count-stmt) + (map dbi:exec statements) + (dbi:for-each-row (lambda (tot) + (debug:print-info 0 *default-log-port* "Records count after clean: " tot)) + count-stmt))) + (map dbi:close statements) + (dbi:close count-stmt) ;; (db:find-and-mark-incomplete db) ;; (db:delay-if-busy dbdat) - (sqlite3:execute db "VACUUM;"))) + (dbi:exec db "VACUUM;"))) + ;; Clean out old junk and vacuum the database ;; ;; Ultimately do something like this: ;; @@ -1581,36 +1600,36 @@ ;; b. .... ;; (define (db:clean-up-rundb dbdat) ;; (debug:print 0 *default-log-port* "WARNING: db clean up not fully ported to v1.60, cleanup action will be on megatest.db") (let* ((db (db:dbdat-get-db dbdat)) - (count-stmt (sqlite3:prepare db "SELECT (SELECT count(id) FROM tests);")) + (count-stmt (dbi:prepare db "SELECT (SELECT count(id) FROM tests);")) (statements (map (lambda (stmt) - (sqlite3:prepare db stmt)) + (dbi:prepare db stmt)) (list ;; delete all tests that belong to runs that are 'deleted' ;; (conc "DELETE FROM tests WHERE run_id NOT IN (" (string-intersperse (map conc valid-runs) ",") ");") ;; delete all tests that are 'DELETED' "DELETE FROM tests WHERE state='DELETED';" )))) ;; (db:delay-if-busy dbdat) - (sqlite3:with-transaction + (dbi:with-transaction db (lambda () - (sqlite3:for-each-row (lambda (tot) + (dbi:for-each-row (lambda (tot) (debug:print-info 0 *default-log-port* "Records count before clean: " tot)) count-stmt) - (map sqlite3:execute statements) - (sqlite3:for-each-row (lambda (tot) + (map dbi:exec statements) + (dbi:for-each-row (lambda (tot) (debug:print-info 0 *default-log-port* "Records count after clean: " tot)) count-stmt))) - (map sqlite3:finalize! statements) - (sqlite3:finalize! count-stmt) + (map dbi:close statements) + (dbi:close count-stmt) ;; (db:find-and-mark-incomplete db) ;; (db:delay-if-busy dbdat) - (sqlite3:execute db "VACUUM;"))) + (dbi:exec db "VACUUM;"))) ;; Clean out old junk and vacuum the database ;; ;; Ultimately do something like this: ;; @@ -1622,42 +1641,43 @@ ;; b. .... ;; (define (db:clean-up-maindb dbdat) ;; (debug:print 0 *default-log-port* "WARNING: db clean up not fully ported to v1.60, cleanup action will be on megatest.db") (let* ((db (db:dbdat-get-db dbdat)) - (count-stmt (sqlite3:prepare db "SELECT (SELECT count(id) FROM runs);")) + (count-stmt (dbi:prepare db "SELECT (SELECT count(id) FROM runs);")) (statements (map (lambda (stmt) - (sqlite3:prepare db stmt)) + (dbi:prepare db stmt)) (list ;; delete all tests that belong to runs that are 'deleted' ;; (conc "DELETE FROM tests WHERE run_id NOT IN (" (string-intersperse (map conc valid-runs) ",") ");") ;; delete all tests that are 'DELETED' "DELETE FROM runs WHERE state='deleted';" ))) (dead-runs '())) - (sqlite3:for-each-row + (dbi:for-each-row + (lambda (output) (lambda (run-id) - (set! dead-runs (cons run-id dead-runs))) + (set! dead-runs (cons run-id dead-runs)))) db "SELECT id FROM runs WHERE state='deleted';") ;; (db:delay-if-busy dbdat) - (sqlite3:with-transaction + (dbi:with-transaction db (lambda () - (sqlite3:for-each-row (lambda (tot) + (dbi:for-each-row (lambda (tot) (debug:print-info 0 *default-log-port* "Records count before clean: " tot)) count-stmt) - (map sqlite3:execute statements) - (sqlite3:for-each-row (lambda (tot) + (map dbi:exec statements) + (dbi:for-each-row (lambda (tot) (debug:print-info 0 *default-log-port* "Records count after clean: " tot)) count-stmt))) - (map sqlite3:finalize! statements) - (sqlite3:finalize! count-stmt) + (map dbi:close statements) + (dbi:close count-stmt) ;; (db:find-and-mark-incomplete db) ;; (db:delay-if-busy dbdat) - (sqlite3:execute db "VACUUM;") + (dbi:exec db "VACUUM;") dead-runs)) ;;====================================================================== ;; M E T A G E T A N D S E T V A R S ;;====================================================================== @@ -1667,13 +1687,13 @@ ;; (define (db:get-var dbstruct var) (let* ((res #f) (dbdat (db:get-db dbstruct #f)) (db (db:dbdat-get-db dbdat))) - (sqlite3:for-each-row + (dbi:for-each-row (lambda (val) - (set! res val)) + (set! res (vector-ref val 0))) db "SELECT val FROM metadat WHERE var=?;" var) ;; convert to number if can (if (string? res) (let ((valnum (string->number res))) @@ -1693,17 +1713,17 @@ ;; (set! *last-global-delta-printed* *global-delta*))) (define (db:set-var dbstruct var val) (let* ((dbdat (db:get-db dbstruct #f)) (db (db:dbdat-get-db dbdat))) - (sqlite3:execute db "INSERT OR REPLACE INTO metadat (var,val) VALUES (?,?);" var val))) + (dbi:exec db "INSERT OR REPLACE INTO metadat (var,val) VALUES (?,?);" var val))) (define (db:del-var dbstruct var) ;; (db:delay-if-busy) (db:with-db dbstruct #f #t (lambda (db) - (sqlite3:execute db "DELETE FROM metadat WHERE var=?;" var)))) + (dbi:exec db "DELETE FROM metadat WHERE var=?;" 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 @@ -1713,13 +1733,13 @@ (define (db:get-keys dbstruct) (if *db-keys* *db-keys* (let ((res '())) (db:with-db dbstruct #f #f (lambda (db) - (sqlite3:for-each-row + (dbi:for-each-row (lambda (key) - (set! res (cons key res))) + (set! res (cons (vector-ref key 0) res))) db "SELECT fieldname FROM keys ORDER BY id DESC;"))) (set! *db-keys* res) res))) @@ -1748,13 +1768,13 @@ dbstruct #f ;; this is for the main runs db #f ;; does not modify db (lambda (db) (let ((res #f)) - (sqlite3:for-each-row + (dbi:for-each-row (lambda (runname) - (set! res runname)) + (set! res (vector-ref runname 0))) db "SELECT runname FROM runs WHERE id=?;" run-id) res)))) @@ -1763,13 +1783,13 @@ dbstruct #f #f (lambda (db) (let ((res #f)) - (sqlite3:for-each-row + (dbi:for-each-row (lambda (val) - (set! res val)) + (set! res (vector-ref val 0))) db (conc "SELECT " key " FROM runs WHERE id=?;") run-id) res)))) @@ -1811,23 +1831,23 @@ (debug:print 3 *default-log-port* "keys: " keys " allvals: " allvals " keyvals: " keyvals " key=?str is " key=?str) (debug:print 2 *default-log-port* "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)) ;; (db:delay-if-busy dbdat) - (apply sqlite3:execute db (conc "INSERT OR IGNORE INTO runs (runname,state,status,owner,event_time" comma keystr ") VALUES (?,?,?,?,strftime('%s','now')" comma valslots ");") + (apply dbi:exec db (conc "INSERT OR IGNORE INTO runs (runname,state,status,owner,event_time" comma keystr ") VALUES (?,?,?,?,strftime('%s','now')" comma valslots ");") allvals) ;; (db:delay-if-busy dbdat) - (apply sqlite3:for-each-row + (apply dbi:for-each-row (lambda (id) - (set! res id)) + (set! res (vector-ref id 0))) db (let ((qry (conc "SELECT id FROM runs WHERE (runname=? " andstr key=?str ");"))) ;(debug:print 4 *default-log-port* "qry: " qry) qry) qryvals) ;; (db:delay-if-busy dbdat) - (sqlite3:execute db "UPDATE runs SET state=?,status=?,event_time=strftime('%s','now') WHERE id=? AND state='deleted';" state status res) + (dbi:exec db "UPDATE runs SET state=?,status=?,event_time=strftime('%s','now') WHERE id=? AND state='deleted';" state status res) res) (begin (debug:print-error 0 *default-log-port* "Called without all necessary keys") #f)))) @@ -1863,13 +1883,13 @@ (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))) + (dbi:for-each-row + (lambda (output) + (set! res (cons output 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))) @@ -1904,13 +1924,13 @@ (db:with-db dbstruct #f #f (lambda (db) - (sqlite3:for-each-row - (lambda (a . x) - (let ((targ (cons a x))) + (dbi:for-each-row + (lambda (output) + (let ((targ (vector->list output))) (if (not (hash-table-ref/default seen targ #f)) (begin (hash-table-set! seen targ #t) (set! res (cons (apply vector targ) res)))))) db @@ -1925,13 +1945,13 @@ #f #f (lambda (db) (let ((numruns 0)) (debug:print-info 11 *default-log-port* "db:get-num-runs START " runpatt) - (sqlite3:for-each-row + (dbi:for-each-row (lambda (count) - (set! numruns count)) + (set! numruns (vector-ref count 0))) db "SELECT COUNT(id) FROM runs WHERE runname LIKE ? AND state != 'deleted';" runpatt) (debug:print-info 11 *default-log-port* "db:get-num-runs END " runpatt) numruns)))) @@ -1941,11 +1961,11 @@ (db:with-db dbstruct run-id #f (lambda (db) - (sqlite3:fold-row + (dbi:fold-row (lambda (res state status count) (cons (list state status count) res)) '() db "SELECT state,status,count(id) AS count FROM tests WHERE run_id=? AND NOT(uname='n/a' AND item_path='') GROUP BY state,status;;" @@ -1959,32 +1979,32 @@ dbstruct #f #f (lambda (db) ;; remove previous data - (let* ((stmt1 (sqlite3:prepare db "DELETE FROM run_stats WHERE run_id=? AND state=? AND status=?;")) - (stmt2 (sqlite3:prepare db "INSERT INTO run_stats (run_id,state,status,count) VALUES (?,?,?,?);")) + (let* ((stmt1 (dbi:prepare db "DELETE FROM run_stats WHERE run_id=? AND state=? AND status=?;")) + (stmt2 (dbi:prepare db "INSERT INTO run_stats (run_id,state,status,count) VALUES (?,?,?,?);")) (res - (sqlite3:with-transaction + (dbi:with-transaction db (lambda () (for-each (lambda (dat) - (sqlite3:execute stmt1 run-id (car dat)(cadr dat)) - (apply sqlite3:execute stmt2 run-id dat)) + (dbi:exec stmt1 run-id (car dat)(cadr dat)) + (apply dbi:exec stmt2 run-id dat)) stats))))) - (sqlite3:finalize! stmt1) - (sqlite3:finalize! stmt2) + (dbi:close stmt1) + (dbi:close stmt2) res)))) (define (db:get-main-run-stats dbstruct run-id) (db:with-db dbstruct #f ;; this data comes from main #f (lambda (db) - (sqlite3:fold-row + (dbi:fold-row (lambda (res state status count) (cons (list state status count) res)) '() db "SELECT state,status,count FROM run_stats WHERE run_id=? AND run_id IN (SELECT id FROM runs WHERE state NOT IN ('DELETED','deleted'));" @@ -1995,13 +2015,13 @@ dbstruct #f #f (lambda (db) (let ((run-ids '())) - (sqlite3:for-each-row + (dbi:for-each-row (lambda (run-id) - (set! run-ids (cons run-id run-ids))) + (set! run-ids (cons (vector-ref run-id 0) run-ids))) db "SELECT id FROM runs WHERE state != 'deleted' ORDER BY event_time DESC;") (reverse run-ids))))) ;; get some basic run stats @@ -2015,13 +2035,14 @@ (curr (make-hash-table)) (res '()) (runs-info '())) ;; First get all the runname/run-ids ;; (db:delay-if-busy dbdat) - (sqlite3:for-each-row - (lambda (run-id runname) - (set! runs-info (cons (list run-id runname) runs-info))) + (dbi:for-each-row + (lambda (output) + (lambda (run-id runname) + (set! runs-info (cons (list run-id runname) runs-info)))) db "SELECT id,runname FROM runs WHERE state != 'deleted' ORDER BY event_time DESC;") ;; If you change this to the more logical ASC please adjust calls to db:get-run-stats ;; for each run get stats data (for-each (lambda (run-info) @@ -2031,17 +2052,18 @@ (db:with-db dbstruct run-id #f (lambda (db) - (sqlite3:for-each-row - (lambda (state status count) - (let ((netstate (if (equal? state "COMPLETED") status state))) - (if (string? netstate) - (begin - (hash-table-set! totals netstate (+ (hash-table-ref/default totals netstate 0) count)) - (hash-table-set! curr netstate (+ (hash-table-ref/default curr netstate 0) count)))))) + (dbi:for-each-row + (lambda (output) + (lambda (state status count) + (let ((netstate (if (equal? state "COMPLETED") status state))) + (if (string? netstate) + (begin + (hash-table-set! totals netstate (+ (hash-table-ref/default totals netstate 0) count)) + (hash-table-set! curr netstate (+ (hash-table-ref/default curr netstate 0) count))))))) db "SELECT state,status,count(id) FROM tests AS t GROUP BY state,status ORDER BY state,status DESC;") ;; add the per run counts to res (for-each (lambda (state) (set! res (cons (list run-name state (hash-table-ref curr state)) res))) @@ -2090,11 +2112,11 @@ (debug:print-info 4 *default-log-port* "runs:get-runs-by-patt qry=" qry-str " " runnamepatt) (vector header (reverse (db:with-db dbstruct #f #f ;; reads db, does not write to it. (lambda (db) - (sqlite3:fold-row + (dbi:fold-row (lambda (res . r) (cons (list->vector r) res)) '() db qry-str @@ -2112,13 +2134,13 @@ (header (append keys remfields)) (keystr (conc (keys->keystr keys) "," (string-intersperse remfields ",")))) (debug:print-info 11 *default-log-port* "db:get-run-info run-id: " run-id " header: " header " keystr: " keystr) ;; (db:delay-if-busy dbdat) - (sqlite3:for-each-row - (lambda (a . x) - (set! res (apply vector a x))) + (dbi:for-each-row + (lambda (output) + (set! res output)) db (conc "SELECT " keystr " FROM runs WHERE id=? AND state != 'deleted';") run-id) (debug:print-info 11 *default-log-port* "db:get-run-info run-id: " run-id " header: " header " keystr: " keystr) (let ((finalres (vector header res))) @@ -2129,11 +2151,11 @@ (db:with-db dbstruct #f #f (lambda (db) - (sqlite3:execute db "UPDATE runs SET comment=? WHERE id=?;" comment ;; (sdb:qry 'getid comment) + (dbi:exec db "UPDATE runs SET comment=? WHERE id=?;" comment ;; (sdb:qry 'getid comment) run-id)))) ;; does not (obviously!) removed dependent data. But why not!!? (define (db:delete-run dbstruct run-id) ;; First set any related tests to DELETED @@ -2140,26 +2162,26 @@ (let* ((rdbdat (db:get-db dbstruct run-id)) (rdb (db:dbdat-get-db rdbdat)) (dbdat (db:get-db dbstruct #f)) (db (db:dbdat-get-db dbdat))) ;; (db:delay-if-busy rdbdat) - (sqlite3:with-transaction + (dbi:with-transaction db (lambda () - (sqlite3:execute rdb "DELETE FROM test_steps WHERE test_id IN (SELECT id FROM tests WHERE run_id=?);" run-id) - (sqlite3:execute rdb "DELETE FROM test_data WHERE test_id IN (SELECT id FROM tests WHERE run_id=?);" run-id) - (sqlite3:execute rdb "UPDATE tests SET state='DELETED',comment='' WHERE run_id=?;" run-id) + (dbi:exec rdb "DELETE FROM test_steps WHERE test_id IN (SELECT id FROM tests WHERE run_id=?);" run-id) + (dbi:exec rdb "DELETE FROM test_data WHERE test_id IN (SELECT id FROM tests WHERE run_id=?);" run-id) + (dbi:exec rdb "UPDATE tests SET state='DELETED',comment='' WHERE run_id=?;" run-id) ;; (db:delay-if-busy dbdat) - (sqlite3:execute db "UPDATE runs SET state='deleted',comment='' WHERE id=?;" run-id))))) + (dbi:exec db "UPDATE runs SET state='deleted',comment='' WHERE id=?;" run-id))))) (define (db:update-run-event_time dbstruct run-id) (db:with-db dbstruct #f #t (lambda (db) - (sqlite3:execute db "UPDATE runs SET event_time=strftime('%s','now') WHERE id=?;" run-id)))) + (dbi:exec db "UPDATE runs SET event_time=strftime('%s','now') WHERE id=?;" run-id)))) (define (db:lock/unlock-run dbstruct run-id lock unlock user) (db:with-db dbstruct #f @@ -2167,33 +2189,34 @@ (lambda (db) (let ((newlockval (if lock "locked" (if unlock "unlocked" "locked")))) ;; semi-failsafe - (sqlite3:execute db "UPDATE runs SET state=? WHERE id=?;" newlockval run-id) - (sqlite3:execute db "INSERT INTO access_log (user,accessed,args) VALUES(?,strftime('%s','now'),?);" + (dbi:exec db "UPDATE runs SET state=? WHERE id=?;" newlockval run-id) + (dbi:exec db "INSERT INTO access_log (user,accessed,args) VALUES(?,strftime('%s','now'),?);" user (conc newlockval " " run-id)) (debug:print-info 1 *default-log-port* "" newlockval " run number " run-id))))) (define (db:set-run-status dbstruct run-id status msg) (let* ((dbdat (db:get-db dbstruct #f)) (db (db:dbdat-get-db dbdat))) ;; (db:delay-if-busy dbdat) (if msg - (sqlite3:execute db "UPDATE runs SET status=?,comment=? WHERE id=?;" status msg run-id) - (sqlite3:execute db "UPDATE runs SET status=? WHERE id=?;" status run-id)))) + (dbi:exec db "UPDATE runs SET status=?,comment=? WHERE id=?;" status msg run-id) + (dbi:exec db "UPDATE runs SET status=? WHERE id=?;" status run-id)))) (define (db:get-run-status dbstruct run-id) (let ((res "n/a")) (db:with-db dbstruct #f #f (lambda (db) - (sqlite3:for-each-row - (lambda (status) - (set! res status)) + (dbi:for-each-row + (lambda (output) + (lambda (status) + (set! res status))) db "SELECT status FROM runs WHERE id=?;" run-id) res)))) @@ -2210,13 +2233,14 @@ (db (db:dbdat-get-db dbdat))) (for-each (lambda (key) (let ((qry (conc "SELECT " key " FROM runs WHERE id=?;"))) ;; (db:delay-if-busy dbdat) - (sqlite3:for-each-row - (lambda (key-val) - (set! res (cons (list key key-val) res))) + (dbi:for-each-row + (lambda (output) + (lambda (key-val) + (set! res (cons (list key key-val) res)))) db qry run-id))) keys) (reverse res))) ;; get key vals for a given run-id @@ -2227,13 +2251,14 @@ (db (db:dbdat-get-db dbdat))) (for-each (lambda (key) (let ((qry (conc "SELECT " key " FROM runs WHERE id=?;"))) ;; (db:delay-if-busy dbdat) - (sqlite3:for-each-row - (lambda (key-val) - (set! res (cons key-val res))) + (dbi:for-each-row + (lambda (output) + (lambda (key-val) + (set! res (cons key-val res)))) db qry run-id))) keys) (let ((final-res (reverse res))) (hash-table-set! *keyvals* run-id final-res) final-res))) @@ -2252,13 +2277,14 @@ (keys (rmt:get-keys)) (qrystr (string-intersperse (map (lambda (x)(conc x "=?")) keys) " AND "))) (let ((prev-run-ids '())) (db:with-db dbstruct #f #f ;; #f means work with the zeroth db - i.e. the runs db (lambda (db) - (apply sqlite3:for-each-row - (lambda (id) - (set! prev-run-ids (cons id prev-run-ids))) + (apply dbi:for-each-row + (lambda (output) + (lambda (id) + (set! prev-run-ids (cons id prev-run-ids)))) db (conc "SELECT id FROM runs WHERE " qrystr " AND state != 'deleted' AND id != ?;") (append kvalues (list run-id))))) prev-run-ids))) ;;====================================================================== @@ -2349,13 +2375,13 @@ ";" ))) (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))) + (dbi:for-each-row + (lambda (output) ;; id run-id testname state status event-time host cpuload diskfree uname rundir item-path run-duration final-logf comment) + (set! res (cons output res))) ;; id run-id testname state status event-time host cpuload diskfree uname rundir item-path run-duration final-logf comment) res))) db qry run-id ))) (case qryvals @@ -2381,27 +2407,29 @@ (qry (conc "SELECT id,testname,item_path,state,status FROM tests WHERE run_id=? " (if tests-match-qry (conc " AND (" tests-match-qry ") ") "")))) (debug:print-info 8 *default-log-port* "db:get-tests-for-run qry=" qry) (db:with-db dbstruct run-id #f (lambda (db) - (sqlite3:for-each-row + (dbi:for-each-row + (lambda (output) (lambda (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 - (set! res (cons (vector id run-id testname state status -1 "" -1 -1 "" "-" item-path -1 "-" "-") res))) + (set! res (cons (vector id run-id testname state status -1 "" -1 -1 "" "-" item-path -1 "-" "-") res)))) db qry run-id))) res)) (define (db:get-testinfo-state-status dbstruct run-id test-id) (let ((res #f)) (db:with-db dbstruct run-id #f (lambda (db) - (sqlite3:for-each-row + (dbi:for-each-row + (lambda (output) (lambda (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 - (set! res (vector test-id run-id testname state status -1 "" -1 -1 "" "-" item-path -1 "-" "-"))) + (set! res (vector test-id run-id testname state status -1 "" -1 -1 "" "-" item-path -1 "-" "-")))) db "SELECT run_id,testname,item_path,state,status FROM tests WHERE id=?;" test-id))) res)) @@ -2433,11 +2461,11 @@ (let* ((dbdat (db:get-db dbstruct run-id)) (db (db:dbdat-get-db dbdat))) (db:general-call dbdat 'delete-test-step-records (list test-id)) ;; (db:delay-if-busy) (db:general-call dbdat 'delete-test-data-records (list test-id)) - (sqlite3:execute db "UPDATE tests SET state='DELETED',status='n/a',comment='' WHERE id=?;" test-id))) + (dbi:exec db "UPDATE tests SET state='DELETED',status='n/a',comment='' WHERE id=?;" test-id))) ;; (define (db:delete-old-deleted-test-records dbstruct) (let (;; (run-ids (db:get-all-run-ids dbstruct)) (targtime (- (current-seconds)(* 30 24 60 60)))) ;; one month in the past @@ -2444,16 +2472,16 @@ (db:with-db dbstruct 0 #t (lambda (db) - (sqlite3:with-transaction + (dbi:with-transaction db (lambda () - (sqlite3:execute db "DELETE FROM test_steps WHERE test_id IN (SELECT id FROM tests WHERE state='DELETED' AND event_timelist rec)) ",") "\n") - (apply sqlite3:execute qry (vector->list rec))) + (apply dbi:exec qry (vector->list rec))) testrecs))) - (sqlite3:finalize! qry))))) + (dbi:close qry))))) ;; map a test-id into the proper range ;; (define (db:adj-test-id mtdb min-test-id test-id) (if (>= test-id min-test-id) test-id (let loop ((new-id min-test-id)) (let ((test-id-found #f)) - (sqlite3:for-each-row + (dbi:for-each-row + (lambda (output) (lambda (id) - (set! test-id-found id)) + (set! test-id-found id))) (db:dbdat-get-db mtdb) "SELECT id FROM tests WHERE id=?;" new-id) ;; if test-id-found then need to try again (if test-id-found (loop (+ new-id 1)) (begin (debug:print-info 0 *default-log-port* "New test id " new-id " selected for test with id " test-id) - (sqlite3:execute mtdb "UPDATE tests SET id=? WHERE id=?;" new-id test-id))))))) + (dbi:exec mtdb "UPDATE tests SET id=? WHERE id=?;" new-id test-id))))))) ;; move test ids into the 30k * run_id range ;; (define (db:prep-megatest.db-adj-test-ids mtdb run-id testrecs) (debug:print-info 0 *default-log-port* "Adjusting test ids in megatest.db for run " run-id) @@ -2745,14 +2776,15 @@ dbstruct run-id #f (lambda (db) (let ((res #f)) - (sqlite3:for-each-row ;; attemptnum added to hold pid of top process (not Megatest) controlling a test + (dbi:for-each-row ;; attemptnum added to hold pid of top process (not Megatest) controlling a test + (lambda (output) (lambda (id run-id testname state status event-time host cpuload diskfree uname rundir-id item-path run_duration final-logf-id comment short-dir-id attemptnum archived) ;; 0 1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 - (set! res (vector id run-id testname state status event-time host cpuload diskfree uname rundir-id item-path run_duration final-logf-id comment short-dir-id attemptnum archived))) + (set! res (vector id run-id testname state status event-time host cpuload diskfree uname rundir-id item-path run_duration final-logf-id comment short-dir-id attemptnum archived)))) db (conc "SELECT " db:test-record-qry-selector " FROM tests WHERE id=?;") test-id) res)))) @@ -2764,14 +2796,14 @@ dbstruct run-id #f (lambda (db) (let ((res '())) - (sqlite3:for-each-row - (lambda (a . b) + (dbi:for-each-row + (lambda (output) ;; 0 1 2 3 4 5 6 7 8 9 10 11 12 13 14 - (set! res (cons (apply vector a b) res))) + (set! res (cons output res))) db (conc "SELECT " db:test-record-qry-selector " FROM tests WHERE id in (" (string-intersperse (map conc test-ids) ",") ");")) res)))) @@ -2780,13 +2812,13 @@ dbstruct run-id #f (lambda (db) (let ((res #f)) - (sqlite3:for-each-row - (lambda (a . b) - (set! res (apply vector a b))) + (dbi:for-each-row + (lambda (output) + (set! res output)) db (conc "SELECT " db:test-record-qry-selector " FROM tests WHERE testname=? AND item_path=? AND run_id=?;") test-name item-path run-id) res)))) @@ -2810,11 +2842,11 @@ (db:with-db dbstruct run-id #t (lambda (db) - (sqlite3:execute + (dbi:exec db "INSERT OR REPLACE into test_steps (test_id,stepname,state,status,event_time,comment,logfile) VALUES(?,?,?,?,?,?,?);" test-id teststep-name state-in status-in (current-seconds) (if comment comment "") (if logfile logfile ""))))) @@ -2825,13 +2857,14 @@ dbstruct run-id #f (lambda (db) (let* ((res '())) - (sqlite3:for-each-row + (dbi:for-each-row + (lambda (output) (lambda (id test-id stepname state status event-time logfile comment) - (set! res (cons (vector id test-id stepname state status event-time (if (string? logfile) logfile "") comment) res))) + (set! res (cons (vector id test-id stepname state status event-time (if (string? logfile) logfile "") comment) res)))) db "SELECT id,test_id,stepname,state,status,event_time,logfile,comment FROM test_steps WHERE status != 'DELETED' AND test_id=? ORDER BY id ASC;" ;; event_time DESC,id ASC; test-id) (reverse res))))) @@ -2840,13 +2873,14 @@ dbstruct run-id #f (lambda (db) (let ((res '())) - (sqlite3:for-each-row + (dbi:for-each-row + (lambda (output) (lambda (id test-id stepname state status event-time logfile) - (set! res (cons (vector id test-id stepname state status event-time (if (string? logfile) logfile "")) res))) + (set! res (cons (vector id test-id stepname state status event-time (if (string? logfile) logfile "")) res)))) db "SELECT id,test_id,stepname,state,status,event_time,logfile FROM test_steps WHERE status != 'DELETED' AND test_id=? ORDER BY id ASC;" ;; event_time DESC,id ASC; test-id) (reverse res))))) @@ -2863,14 +2897,15 @@ (let* ((dbdat (db:get-db dbstruct run-id)) (db (db:dbdat-get-db dbdat)) (fail-count 0) (pass-count 0)) ;; (db:delay-if-busy dbdat) - (sqlite3:for-each-row + (dbi:for-each-row + (lambda (output) (lambda (fcount pcount) (set! fail-count fcount) - (set! pass-count pcount)) + (set! pass-count pcount))) db "SELECT (SELECT count(id) FROM test_data WHERE test_id=? AND status like 'fail') AS fail_count, (SELECT count(id) FROM test_data WHERE test_id=? AND status like 'pass') AS pass_count;" test-id test-id) ;; Now rollup the counts to the central megatest.db @@ -3013,11 +3048,11 @@ ((<=) (if (<= value expected) "pass" "fail")) (else (conc "ERROR: bad tol comparator " tol)))))) (debug:print 4 *default-log-port* "AFTER2: category: " category " variable: " variable " value: " value ", expected: " expected " tol: " tol " units: " units " status: " status " comment: " comment) ;; (db:delay-if-busy dbdat) - (sqlite3:execute db "INSERT OR REPLACE INTO test_data (test_id,category,variable,value,expected,tol,units,comment,status,type) VALUES (?,?,?,?,?,?,?,?,?,?);" + (dbi:exec db "INSERT OR REPLACE INTO test_data (test_id,category,variable,value,expected,tol,units,comment,status,type) VALUES (?,?,?,?,?,?,?,?,?,?);" test-id category variable value expected tol units (if comment comment "") status type))) csvlist))) ;; This routine moved from tdb.scm, tdb:read-test-data ;; @@ -3024,13 +3059,14 @@ (define (db:read-test-data dbstruct run-id test-id categorypatt) (let* ((dbdat (db:get-db dbstruct run-id)) (db (db:dbdat-get-db dbdat)) (res '())) ;; (db:delay-if-busy dbdat) - (sqlite3:for-each-row + (dbi:for-each-row + (lambda (output) (lambda (id test_id category variable value expected tol units comment status type) - (set! res (cons (vector id test_id category variable value expected tol units comment status type) res))) + (set! res (cons (vector id test_id category variable value expected tol units comment status type) res)))) db "SELECT id,test_id,category,variable,value,expected,tol,units,comment,status,type FROM test_data WHERE test_id=? AND category LIKE ? ORDER BY category,variable;" test-id categorypatt) (reverse res))) ;;====================================================================== @@ -3046,17 +3082,17 @@ (conc key " like '" val "'")) keynames (string-split target "/")) " AND ")) ;; (testqry (tests:match->sqlqry testpatt)) - (runsqry (sqlite3:prepare db (conc "SELECT id FROM runs WHERE " keystr " AND runname LIKE '" runname "';")))) + (runsqry (dbi:prepare db (conc "SELECT id FROM runs WHERE " keystr " AND runname LIKE '" runname "';")))) ;; (debug:print 8 *default-log-port* "db:test-get-paths-matching-keynames-target-new\n runsqry=" runsqry "\n tstsqry=" testqry) - (sqlite3:for-each-row + (dbi:for-each-row (lambda (rid) - (set! row-ids (cons rid row-ids))) + (set! row-ids (cons (vector-ref rid 0) row-ids))) runsqry) - (sqlite3:finalize! runsqry) + (dbi:close runsqry) row-ids)) ;; finds latest matching all patts for given run-id ;; (define (db:test-get-paths-matching-keynames-target-new dbstruct run-id keynames target res testpatt statepatt statuspatt runname) @@ -3065,13 +3101,14 @@ (db:with-db dbstruct run-id #f (lambda (db) - (sqlite3:for-each-row + (dbi:for-each-row + (lambda (output) (lambda (p) - (set! res (cons p res))) + (set! res (cons p res)))) db tstsqry run-id) res)))) @@ -3080,13 +3117,14 @@ dbstruct run-id #f (lambda (db) (let ((res 0)) - (sqlite3:for-each-row + (dbi:for-each-row + (lambda (output) (lambda (num-items) - (set! res num-items)) + (set! res num-items))) db "SELECT count(id) FROM tests WHERE run_id=? AND testname=? AND item_path != '' AND state NOT IN ('DELETED');" run-id testname) res)))) @@ -3159,11 +3197,11 @@ (db:test-get-testname testdat) test-name)) (item-path (db:test-get-item-path testdat)) (tl-testdat (db:get-test-info dbstruct run-id test-name "")) (tl-test-id (db:test-get-id tl-testdat))) - (sqlite3:with-transaction + (dbi:with-transaction db (lambda () (db:test-set-state-status-by-id dbstruct run-id test-id state status comment) (if (not (equal? item-path "")) ;; only roll up IF incoming test is an item (let* ((state-status-counts (db:get-all-state-status-counts-for-test db run-id test-name item-path)) ;; item-path is used to exclude current state/status of THIS test @@ -3235,27 +3273,27 @@ ;; ;; ((ABORT INCOMPLETE) (db:general-call dbdat 'top-test-set (list status test-name)))) ;; ;; #f) ;; ;; ))) (define (db:get-all-state-status-counts-for-test db run-id test-name item-path) - (sqlite3:map-row + (dbi:map-row (lambda (state status count) (make-dbr:counts state: state status: status count: count)) db "SELECT state,status,count(id) FROM tests WHERE run_id=? AND testname=? AND item_path != '' AND item_path !=? GROUP BY state,status;" run-id test-name item-path)) (define (db:get-all-item-states db run-id test-name) - (sqlite3:map-row + (dbi:map-row (lambda (a) a) db "SELECT DISTINCT state FROM tests WHERE item_path != '' AND state != 'DELETED' AND run_id=? AND testname=?" run-id test-name)) (define (db:get-all-item-statuses db run-id test-name) - (sqlite3:map-row + (dbi:map-row (lambda (a) a) db "SELECT DISTINCT status FROM tests WHERE item_path != '' AND state != 'DELETED' AND state='COMPLETED' AND run_id=? AND testname=?" run-id test-name)) @@ -3264,19 +3302,20 @@ dbstruct run-id #f (lambda (db) (let ((res #f)) - (sqlite3:for-each-row + (dbi:for-each-row + (lambda (output) (lambda (path final_logf) ;; (let ((path (sdb:qry 'getstr path-id)) ;; (final_logf (sdb:qry 'getstr final_logf-id))) (set! logf final_logf) (set! res (list path final_logf)) (if (directory? path) (debug:print 2 *default-log-port* "Found path: " path) - (debug:print 2 *default-log-port* "No such path: " path))) ;; ) + (debug:print 2 *default-log-port* "No such path: " path)))) ;; ) db "SELECT rundir,final_logf FROM tests WHERE testname=? AND item_path='' AND run_id=?;" test-name run-id) res)))) @@ -3453,22 +3492,23 @@ (string->symbol stmtname) stmtname) db:queries))) (if q (car q) #f)))) ;; (db:delay-if-busy dbdat) - (apply sqlite3:execute (db:dbdat-get-db dbdat) query params) + (apply dbi:exec (db:dbdat-get-db dbdat) query params) #t)) ;; get a summary of state and status counts to calculate a rollup ;; ;; NOTE: takes a db, not a dbstruct ;; (define (db:get-state-status-summary db run-id testname) (let ((res '())) - (sqlite3:for-each-row + (dbi:for-each-row + (lambda (output) (lambda (state status count) - (set! res (cons (vector state status count) res))) + (set! res (cons (vector state status count) res)))) db "SELECT state,status,count(state) FROM tests WHERE run_id=? AND testname=? AND item_path='' GROUP BY state,status;" run-id testname) res)) @@ -3511,21 +3551,23 @@ (qrystr (string-intersperse (map (lambda (x)(conc x "=?")) keys) " AND ")) (keyvals #f) (tests-hash (make-hash-table))) ;; first look up the key values from the run selected by run-id ;; (db:delay-if-busy dbdat) - (sqlite3:for-each-row - (lambda (a . b) - (set! keyvals (cons a b))) + (print selstr) + (dbi:for-each-row + (lambda (output) + (set! keyvals (vector->list output))) 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 + (apply dbi:for-each-row + (lambda (output) (lambda (id) - (set! prev-run-ids (cons id prev-run-ids))) + (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 *default-log-port* "selstr: " selstr ", qrystr: " qrystr ", keyvals: " keyvals @@ -3598,13 +3640,14 @@ (db:with-db dbstruct run-id #f (lambda (db) - (sqlite3:for-each-row + (dbi:for-each-row + (lambda (output) (lambda (id itempath state status run_duration logf comment) - (set! res (cons (vector id itempath state status run_duration logf comment) res))) + (set! res (cons (vector id itempath state status run_duration logf comment) res)))) db "SELECT id,item_path,state,status,run_duration,final_logf,comment FROM tests WHERE testname=? AND item_path != '';" test-name) res)))) @@ -3618,41 +3661,42 @@ (db:with-db dbstruct #f #f (lambda (db) - (sqlite3:for-each-row + (dbi:for-each-row + (lambda (output) (lambda (id testname author owner description reviewed iterated avg_runtime avg_disk tags jobgroup) - (set! res (vector id testname author owner description reviewed iterated avg_runtime avg_disk tags jobgroup))) + (set! res (vector id testname author owner description reviewed iterated avg_runtime avg_disk tags jobgroup)))) db "SELECT id,testname,author,owner,description,reviewed,iterated,avg_runtime,avg_disk,tags,jobgroup FROM test_meta WHERE testname=?;" testname) res)))) ;; create a new record for a given testname (define (db:testmeta-add-record dbstruct testname) (db:with-db dbstruct #f #f (lambda (db) - (sqlite3:execute + (dbi:exec 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 dbstruct testname field value) (db:with-db dbstruct #f #f (lambda (db) - (sqlite3:execute + (dbi:exec db (conc "UPDATE test_meta SET " field "=? WHERE testname=?;") value testname)))) (define (db:testmeta-get-all dbstruct) (db:with-db dbstruct #f #f (lambda (db) (let ((res '())) - (sqlite3:for-each-row - (lambda (a . b) - (set! res (cons (apply vector a b) res))) + (dbi:for-each-row + (lambda (output) + (set! res (cons output res))) db "SELECT id,testname,author,owner,description,reviewed,iterated,avg_runtime,avg_disk,tags,jobgroup FROM test_meta;") res)))) ;;====================================================================== @@ -3841,11 +3885,12 @@ (debug:print 2 *default-log-port* "Using " tempdir " for constructing the ods file. keyqry: " keyqry " keystr: " keysstr " with keys: " (map cadr keypatt-alist) "\n mainqry: " mainqry) ;; "Expected Value" ;; "Value Found" ;; "Tolerance" - (apply sqlite3:for-each-row + (apply dbi:for-each-row + (lambda (output) (lambda (test-id . b) (set! test-ids (cons test-id test-ids)) ;; test-id is now testname (set! results (append results ;; note, drop the test-id (list (if pathmod @@ -3874,11 +3919,11 @@ (if windows (string-translate newpath "/" "\\") newpath)) (if (debug:debug-mode 1) (conc final-log " not-found") ""))) (vector->list vb)) - b))))) + b)))))) db mainqry runspatt (map cadr keypatt-alist)) (debug:print 2 *default-log-port* "Found " (length test-ids) " records") (set! results (list (cons "Runs" results))) @@ -3885,14 +3930,15 @@ ;; now, for each test, collect the test_data info and add a new sheet (for-each (lambda (test-id) (let ((test-data (list testdata-header)) (curr-test-name #f)) - (sqlite3:for-each-row + (dbi:for-each-row + (lambda (output) (lambda (run-id testname item-path category variable value expected tol units status comment) (set! curr-test-name testname) - (set! test-data (append test-data (list (list run-id testname item-path category variable value expected tol units status comment))))) + (set! test-data (append test-data (list (list run-id testname item-path category variable value expected tol units status comment)))))) db ;; "SELECT run_id,testname,item_path,category,variable,td.value AS value,expected,tol,units,td.status AS status,td.comment AS comment FROM test_data AS td INNER JOIN tests ON tests.id=td.test_id WHERE test_id=?;" "SELECT run_id,testname,item_path,category,variable,td.value AS value,td.expected,td.tol,td.units,td.status AS status,td.comment AS comment FROM test_data AS td INNER JOIN tests ON tests.id=td.test_id WHERE testname=?;" test-id) (if curr-test-name Index: filedb.scm ================================================================== --- filedb.scm +++ filedb.scm @@ -8,79 +8,81 @@ ;; PURPOSE. ;; (require-extension synch sqlite3 posix srfi-13 srfi-1 utils regex) (use sqlite3 srfi-1 posix regex srfi-69 srfi-13 posix-extras) (import (prefix sqlite3 sqlite3:)) +(include "/nfs/site/disks/icf_fdk_cw_gwa002/srehman/fossil/dbi/dbi.scm") +(import (prefix dbi dbi:)) (declare (unit filedb)) (include "fdb_records.scm") ;; (include "settings.scm") (define (filedb:open-db dbpath) (let* ((fdb (make-filedb:fdb)) (dbexists (file-exists? dbpath)) - (db (sqlite3:open-database dbpath))) + (db (dbi:open 'sqlite3 (cons (cons ('dbname dbpath) '()))))) (filedb:fdb-set-db! fdb db) (filedb:fdb-set-dbpath! fdb dbpath) (filedb:fdb-set-pathcache! fdb (make-hash-table)) (filedb:fdb-set-idcache! fdb (make-hash-table)) (filedb:fdb-set-partcache! fdb (make-hash-table)) - (sqlite3:set-busy-handler! db (make-busy-timeout 136000)) + ;;(sqlite3:set-busy-handler! db (make-busy-timeout 136000)) (if (not dbexists) (begin - (sqlite3:execute db "PRAGMA synchronous = OFF;") - (sqlite3:execute db "CREATE TABLE names (id INTEGER PRIMARY KEY,name TEST);") ;; for future use - change path in paths table to path_id - (sqlite3:execute db "CREATE INDEX name_index ON names (name);") + (dbi:execute db "PRAGMA synchronous = OFF;") + (dbi:exec db "CREATE TABLE names (id INTEGER PRIMARY KEY,name TEST);") ;; for future use - change path in paths table to path_id + (dbi:exec db "CREATE INDEX name_index ON names (name);") ;; NB// We store a useful subset of file attributes but do not attempt to store all - (sqlite3:execute db "CREATE TABLE paths (id INTEGER PRIMARY KEY, + (dbi:exec db "CREATE TABLE paths (id INTEGER PRIMARY KEY, path TEXT, parent_id INTEGER, mode INTEGER DEFAULT -1, uid INTEGER DEFAULT -1, gid INTEGER DEFAULT -1, size INTEGER DEFAULT -1, mtime INTEGER DEFAULT -1);") - (sqlite3:execute db "CREATE INDEX path_index ON paths (path,parent_id);") - (sqlite3:execute db "CREATE TABLE bases (id INTEGER PRIMARY KEY,base TEXT, updated TIMESTAMP);"))) + (dbi:exec db "CREATE INDEX path_index ON paths (path,parent_id);") + (dbi:exec db "CREATE TABLE bases (id INTEGER PRIMARY KEY,base TEXT, updated TIMESTAMP);"))) ;; close the sqlite3 db and open it as needed (filedb:finalize-db! fdb) (filedb:fdb-set-db! fdb #f) fdb)) (define (filedb:reopen-db fdb) - (let ((db (sqlite3:open-database (filedb:fdb-get-dbpath fdb)))) - (filedb:fdb-set-db! fdb db) - (sqlite3:set-busy-handler! db (make-busy-timeout 136000)))) + (let ((db (dbi:open 'sqlite3 (cons (cons ('dbname (filedb:fdb-get-dbpath fdb)) '()))))) + (filedb:fdb-set-db! fdb db))) + ;;(sqlite3:set-busy-handler! db (make-busy-timeout 136000)))) (define (filedb:finalize-db! fdb) - (sqlite3:finalize! (filedb:fdb-get-db fdb))) + (dbi:close (filedb:fdb-get-db fdb))) (define (filedb:get-current-time-string) (string-chomp (time->string (seconds->local-time (current-seconds))))) (define (filedb:get-base-id db path) - (let ((stmt (sqlite3:prepare db "SELECT id FROM bases WHERE base=?;")) + (let ((stmt (dbi:prepare db "SELECT id FROM bases WHERE base=?;")) (id-num #f)) - (sqlite3:for-each-row - (lambda (num) (set! id-num num)) stmt path) - (sqlite3:finalize! stmt) + (dbi:for-each-row + (lambda (num) (set! id-num (vector-ref num 0))) stmt path) + (dbi:close stmt) id-num)) (define (filedb:get-path-id db path parent) - (let ((stmt (sqlite3:prepare db "SELECT id FROM paths WHERE path=? AND parent_id=?;")) + (let ((stmt (dbi:prepare db "SELECT id FROM paths WHERE path=? AND parent_id=?;")) (id-num #f)) - (sqlite3:for-each-row - (lambda (num) (set! id-num num)) stmt path parent) - (sqlite3:finalize! stmt) + (dbi:for-each-row + (lambda (num) (set! id-num (vector-ref num 0))) stmt path parent) + (dbi:close stmt) id-num)) (define (filedb:add-base db path) (let ((existing (filedb:get-base-id db path))) (if existing #f (begin - (sqlite3:execute db "INSERT INTO bases (base,updated) VALUES (?,?);" path (filedb:get-current-time-string)))))) + (dbi:exec db "INSERT INTO bases (base,updated) VALUES (?,?);" path (filedb:get-current-time-string)))))) ;; index value field notes ;; 0 inode number st_ino ;; 1 mode st_mode bitfield combining file permissions and file type ;; 2 number of hard links st_nlink @@ -95,25 +97,25 @@ ;; 11 block size st_blksize ;; 12 number of blocks allocated st_blocks (define (filedb:add-path-stat db path parent statinfo) (let ((stmt (sqlite3:prepare db "INSERT INTO paths (path,parent_id,mode,uid,gid,size,mtime) VALUES (?,?,?,?,?,?,?);"))) - (sqlite3:execute stmt + (dbi:exec stmt path parent (vector-ref statinfo 1) ;; mode (vector-ref statinfo 3) ;; uid (vector-ref statinfo 4) ;; gid (vector-ref statinfo 5) ;; size (vector-ref statinfo 8) ;; mtime ) - (sqlite3:finalize! stmt))) ;; (filedb:get-current-time-string)))) + (dbi:close stmt))) ;; (filedb:get-current-time-string)))) (define (filedb:add-path db path parent) - (let ((stmt (sqlite3:prepare db "INSERT INTO paths (path,parent_id) VALUES (?,?);"))) - (sqlite3:execute stmt path parent) - (sqlite3:finalize! stmt))) + (let ((stmt (dbi:prepare db "INSERT INTO paths (path,parent_id) VALUES (?,?);"))) + (dbi:exec stmt path parent) + (dbi:close stmt))) (define (filedb:register-path fdb path #!key (save-stat #f)) (let* ((db (filedb:fdb-get-db fdb)) (pathcache (filedb:fdb-get-pathcache fdb)) (stat (if save-stat (file-stat path #t))) @@ -173,36 +175,36 @@ (define (filedb:drop-base fdb path) (print "Sorry, I don't do anything yet")) (define (filedb:find-all fdb pattern action) (let* ((db (filedb:fdb-get-db fdb)) - (stmt (sqlite3:prepare db "SELECT id FROM paths WHERE path like ?;")) + (stmt (dbi:prepare db "SELECT id FROM paths WHERE path like ?;")) (result '())) - (sqlite3:for-each-row + (dbi:for-each-row (lambda (num) - (action num) + (action (vector-ref num 0)) (set! result (cons num result))) stmt pattern) - (sqlite3:finalize! stmt) + (dbi:close stmt) result)) (define (filedb:get-path-record fdb id) (let* ((db (filedb:fdb-get-db fdb)) (partcache (filedb:fdb-get-partcache fdb)) (dat (hash-table-ref/default partcache id #f))) (if dat dat - (let ((stmt (sqlite3:prepare db "SELECT path,parent_id FROM paths WHERE id=?;")) + (let ((stmt (dbi:prepare db "SELECT path,parent_id FROM paths WHERE id=?;")) (result #f)) - (sqlite3:for-each-row - (lambda (path parent_id)(set! result (list path parent_id))) stmt id) + (dbi:for-each-row + (lambda (output) (lambda (path parent_id)(set! result (list path parent_id)))) stmt id) (hash-table-set! partcache id result) - (sqlite3:finalize! stmt) + (dbi:close stmt) result)))) (define (filedb:get-children fdb parent-id) (let* ((db (filedb:fdb-get-db fdb)) (res '())) - (sqlite3:for-each-row + (dbi:for-each-row (lambda (id path parent-id) (set! res (cons (vector id path parent-id) res))) db "SELECT id,path,parent_id FROM paths WHERE parent_id=?;" parent-id) res)) @@ -211,13 +213,14 @@ ;; children that match patt (define (filedb:get-children-patt fdb parent-id search-patt) (let* ((db (filedb:fdb-get-db fdb)) (res '())) ;; first get the children that have no children - (sqlite3:for-each-row + (dbi:for-each-row + (lambda (output) (lambda (id path parent-id) - (set! res (cons (vector id path parent-id) res))) + (set! res (cons (vector id path parent-id) res)))) db "SELECT id,path,parent_id FROM paths WHERE parent_id=? AND (id IN (SELECT parent_id FROM paths) OR path LIKE ?);" parent-id search-patt) res)) Index: lock-queue.scm ================================================================== --- lock-queue.scm +++ lock-queue.scm @@ -7,10 +7,12 @@ ;; implied warranty of MERCHANTABILITY or FITNESS FOR A PARTICULAR ;; PURPOSE. (use sqlite3 srfi-18) (import (prefix sqlite3 sqlite3:)) +(include "/nfs/site/disks/icf_fdk_cw_gwa002/srehman/fossil/dbi/dbi.scm") +(import (prefix dbi dbi:)) (declare (unit lock-queue)) (declare (uses common)) (declare (uses tasks)) @@ -34,12 +36,12 @@ (system (conc "rm -f " fname "*")))) (define (lock-queue:open-db fname #!key (count 10)) (let* ((actualfname (conc fname ".lockdb")) (dbexists (file-exists? actualfname)) - (db (sqlite3:open-database actualfname)) - (handler (make-busy-timeout 136000))) + (db (dbi:open 'sqlite3 (cons (cons ('dbname actualfname) '()))))) + ;;(handler (make-busy-timeout 136000))) (if dbexists (vector db actualfname) (begin (handle-exceptions exn @@ -46,29 +48,29 @@ (begin (thread-sleep! 10) (if (> count 0) (lock-queue:open-db fname count: (- count 1)) (vector db actualfname))) - (sqlite3:with-transaction + (dbi:with-transaction db (lambda () - (sqlite3:execute + (dbi:exec db "CREATE TABLE IF NOT EXISTS queue ( id INTEGER PRIMARY KEY, test_id INTEGER, start_time INTEGER, state TEXT, CONSTRAINT queue_constraint UNIQUE (test_id));") - (sqlite3:execute + (dbi:exec db "CREATE TABLE IF NOT EXISTS runlocks ( id INTEGER PRIMARY KEY, test_id INTEGER, run_lock TEXT, CONSTRAINT runlock_constraint UNIQUE (run_lock));")))))) - (sqlite3:set-busy-handler! db handler) + ;;(sqlite3:set-busy-handler! db handler) (vector db actualfname))) (define (lock-queue:set-state dbdat test-id newstate #!key (remtries 10)) (tasks:wait-on-journal (lock-queue:db-dat-get-path dbdat) 1200) (handle-exceptions @@ -80,11 +82,11 @@ (thread-sleep! 30) (lock-queue:set-state dbdat test-id newstate remtries: (- remtries 1))) (begin (debug:print-error 0 *default-log-port* " Failed to set lock state for test with id " test-id ", error: " ((condition-property-accessor 'exn 'message) exn) ", giving up.") #f)) - (sqlite3:execute (lock-queue:db-dat-get-db dbdat) "UPDATE queue SET state=? WHERE test_id=?;" + (dbi:exec (lock-queue:db-dat-get-db dbdat) "UPDATE queue SET state=? WHERE test_id=?;" newstate test-id))) (define (lock-queue:any-younger? dbdat mystart test-id #!key (remtries 10)) ;; no need to wait on journal on read only queries @@ -100,25 +102,26 @@ (lock-queue:any-younger? dbdat mystart test-id remtries: (- remtries 1))) (begin (debug:print-error 0 *default-log-port* " Failed to find younger locks for test with id " test-id ", error: " ((condition-property-accessor 'exn 'message) exn) ", giving up.") #f)) (let ((res #f)) - (sqlite3:for-each-row + (dbi:for-each-row + (lambda (output) (lambda (tid) ;; Actually this should not be needed as mystart cannot be simultaneously less than and test-id same as (if (not (equal? tid test-id)) - (set! res tid))) + (set! res tid)))) (lock-queue:db-dat-get-db dbdat) "SELECT test_id FROM queue WHERE start_time > ?;" mystart) res))) (define (lock-queue:get-lock dbdat test-id #!key (count 10)(waiting-msg #f)) (tasks:wait-on-journal (lock-queue:db-dat-get-path dbdat) 1200 remove: #t waiting-msg: "lock-queue:get-lock, waiting on journal") (let* ((res #f) (db (lock-queue:db-dat-get-db dbdat)) - (lckqry (sqlite3:prepare db "SELECT test_id,run_lock FROM runlocks WHERE run_lock='locked';")) - (mklckqry (sqlite3:prepare db "INSERT INTO runlocks (test_id,run_lock) VALUES (?,'locked');"))) + (lckqry (dbi:prepare db "SELECT test_id,run_lock FROM runlocks WHERE run_lock='locked';")) + (mklckqry (dbi:prepare db "INSERT INTO runlocks (test_id,run_lock) VALUES (?,'locked');"))) (let ((result (handle-exceptions exn (begin (debug:print 0 *default-log-port* "WARNING: failed to get queue lock. Removing lock db and returning fail") ;; Will try again in a few seconds") @@ -127,26 +130,26 @@ ;; (if (> count 0) ;; #f ;; (lock-queue:get-lock dbdat test-id count: (- count 1)) - give up on retries ;; (begin ;; never recovered, remote the lock file and return #f, no lock obtained (lock-queue:delete-lock-db dbdat) #f) - (sqlite3:with-transaction + (dbi:with-transaction db (lambda () - (sqlite3:for-each-row (lambda (tid lockstate) - (set! res (list tid lockstate))) + (dbi:for-each-row (lambda (output) (lambda (tid lockstate) + (set! res (list tid lockstate)))) lckqry) (if res (if (equal? (car res) test-id) #t ;; already have the lock #f) (begin - (sqlite3:execute mklckqry test-id) + (dbi:exec mklckqry test-id) ;; if no error handled then return #t for got the lock #t))))))) - (sqlite3:finalize! lckqry) - (sqlite3:finalize! mklckqry) + (dbi:close lckqry) + (dbi:close mklckqry) result))) (define (lock-queue:release-lock fname test-id #!key (count 10)) (let* ((dbdat (lock-queue:open-db fname))) (tasks:wait-on-journal (lock-queue:db-dat-get-path dbdat) 1200 "lock-queue:release-lock; waiting on journal") @@ -156,11 +159,11 @@ (debug:print 0 *default-log-port* "WARNING: Failed to release queue lock. Will try again in few seconds") (debug:print 0 *default-log-port* " message: " ((condition-property-accessor 'exn 'message) exn)) (thread-sleep! (/ count 10)) (if (> count 0) (begin - (sqlite3:finalize! (lock-queue:db-dat-get-db dbdat)) + (dbi:close (lock-queue:db-dat-get-db dbdat)) (lock-queue:release-lock fname test-id count: (- count 1))) (let ((journal (conc fname "-journal"))) ;; If we've tried ten times and failed there is a serious problem ;; try to remove the lock db and allow it to be recreated (handle-exceptions @@ -167,12 +170,12 @@ exn #f (if (file-exists? journal)(delete-file journal)) (if (file-exists? fname) (delete-file fname)) #f)))) - (sqlite3:execute (lock-queue:db-dat-get-db dbdat) "DELETE FROM runlocks WHERE test_id=?;" test-id) - (sqlite3:finalize! (lock-queue:db-dat-get-db dbdat))))) + (dbi:exec (lock-queue:db-dat-get-db dbdat) "DELETE FROM runlocks WHERE test_id=?;" test-id) + (dbi:close (lock-queue:db-dat-get-db dbdat))))) (define (lock-queue:steal-lock dbdat test-id #!key (count 10)) (debug:print-info 0 *default-log-port* "Attempting to steal lock at " (lock-queue:db-dat-get-path dbdat)) (tasks:wait-on-journal (lock-queue:db-dat-get-path dbdat) 1200 "lock-queue:steal-lock; waiting on journal") (handle-exceptions @@ -182,11 +185,11 @@ (debug:print 0 *default-log-port* " message: " ((condition-property-accessor 'exn 'message) exn)) (thread-sleep! 10) (if (> count 0) (lock-queue:steal-lock dbdat test-id count: (- count 1)) #f)) - (sqlite3:execute (lock-queue:db-dat-get-db dbdat) "DELETE FROM runlocks WHERE run_lock='locked';")) + (dbi:exec (lock-queue:db-dat-get-db dbdat) "DELETE FROM runlocks WHERE run_lock='locked';")) (lock-queue:get-lock dbdat test-it)) ;; returns #f if ok to skip the task ;; returns #t if ok to proceed with task ;; otherwise waits @@ -203,11 +206,11 @@ (debug:print 0 *default-log-port* " message: " ((condition-property-accessor 'exn 'message) exn)) (print-call-chain (current-error-port)) (thread-sleep! 10) (if (> count 0) (begin - (sqlite3:finalize! db) + (dbi:close db) (lock-queue:wait-turn fname test-id count: (- count 1))) (begin (debug:print 0 *default-log-port* "Giving up calls to lock-queue:wait-turn for test-id " test-id " at path " fname ", printing call chain") (print-call-chain (current-error-port)) #f))) @@ -214,11 +217,11 @@ ;; wait 10 seconds and then check to see if someone is already updating the html (thread-sleep! 10) (if (not (lock-queue:any-younger? dbdat mystart test-id)) ;; no processing in flight, must try to start processing (begin (tasks:wait-on-journal (lock-queue:db-dat-get-path dbdat) 1200 waiting-msg: "lock-queue:wait-turn; waiting on journal file") - (sqlite3:execute + (dbi:exec db "INSERT OR REPLACE INTO queue (test_id,start_time,state) VALUES (?,?,'waiting');" test-id mystart) ;; (thread-sleep! 1) ;; give other tests a chance to register (let ((result @@ -235,11 +238,11 @@ (if (> (- (current-seconds) mystart) 36000) ;; waited too long, steal the lock (lock-queue:steal-lock dbdat test-id) (begin (thread-sleep! 1) (loop (lock-queue:any-younger? dbdat mystart test-id))))))))) - (sqlite3:finalize! db) + (dbi:close db) result)))))) ;; (use trace) ;; (trace lock-queue:get-lock lock-queue:release-lock lock-queue:wait-turn lock-queue:any-younger? lock-queue:set-state) Index: megatest.scm ================================================================== --- megatest.scm +++ megatest.scm @@ -13,10 +13,12 @@ ;; fake out readline usage of toplevel-command (define (toplevel-command . a) #f) (use sqlite3 srfi-1 posix regex regex-case srfi-69 base64 readline apropos json http-client directory-utils rpc typed-records;; (srfi 18) extras) http-client srfi-18 extras format) ;; zmq extras) +(include "/nfs/site/disks/icf_fdk_cw_gwa002/srehman/fossil/dbi/dbi.scm") +(import (prefix dbi dbi:)) ;; Added for csv stuff - will be removed ;; (use sparse-vectors) @@ -626,19 +628,19 @@ (loop row (+ col 1) (append curr-row (list val)) result))))))))) (hash-table-keys results)))) ((sqlite3) (let* ((db-file (or out-file (pathname-file input-db))) (db-exists (file-exists? db-file)) - (db (sqlite3:open-database db-file))) - (if (not db-exists)(sqlite3:execute db "CREATE TABLE data (sheet,section,var,val);")) + (db (dbi:open 'sqlite3 (cons (cons ('dbname db-file) '()))))) + (if (not db-exists)(dbi:exec db "CREATE TABLE data (sheet,section,var,val);")) (configf:map-all-hier-alist data (lambda (sheetname sectionname varname val) - (sqlite3:execute db + (dbi:exec db "INSERT OR REPLACE INTO data (sheet,section,var,val) VALUES (?,?,?,?);" sheetname sectionname varname val))) - (sqlite3:finalize! db))) + (dbi:close db))) (else (pp data)))))) (if out-file (close-output-port out-port)) (exit) ;; yes, bending the rules here - need to exit since this is a utility )) @@ -1705,11 +1707,11 @@ (tests:summarize-items run-id test-id test-name #t)) ;; do force here (if (args:get-arg "-runstep") (if (null? remargs) (begin (debug:print-error 0 *default-log-port* "nothing specified to run!") - (if db (sqlite3:finalize! db)) + (if db (dbi:close db)) (exit 6)) (let* ((stepname (args:get-arg "-runstep")) (logprofile (args:get-arg "-logpro")) (logfile (conc stepname ".log")) (cmd (if (null? remargs) #f (car remargs))) @@ -1766,17 +1768,17 @@ (if (and (args:get-arg "-test-status") (or (not state) (not status))) (begin (debug:print-error 0 *default-log-port* "You must specify :state and :status with every call to -test-status\n" help) - (if (sqlite3:database? db)(sqlite3:finalize! db)) + (if (dbi:database? db)(dbi:close db)) (exit 6))) (let* ((msg (args:get-arg "-m")) (numoth (length (hash-table-keys otherdata)))) ;; Convert to rpc inside the tests:test-set-status! call, not here (tests:test-set-status! run-id test-id state newstatus msg otherdata work-area: work-area)))) - (if (sqlite3:database? db)(sqlite3:finalize! db)) + (if (dbi:database? db)(dbi:close db)) (set! *didsomething* #t)))) ;;====================================================================== ;; Various helper commands can go below here ;;====================================================================== @@ -1789,11 +1791,11 @@ (begin (debug:print 0 *default-log-port* "Failed to setup, exiting") (exit 1))) (set! keys (rmt:get-keys)) ;; db)) (debug:print 1 *default-log-port* "Keys: " (string-intersperse keys ", ")) - (if (sqlite3:database? db)(sqlite3:finalize! db)) + (if (dbi:database? db)(dbi:close db)) (set! *didsomething* #t))) (if (args:get-arg "-gui") (begin (debug:print 0 *default-log-port* "Look at the dashboard for now") Index: portlogger.scm ================================================================== --- portlogger.scm +++ portlogger.scm @@ -10,25 +10,28 @@ (require-extension (srfi 18) extras tcp s11n) (use sqlite3 srfi-1 posix srfi-69 hostinfo dot-locking z3) (import (prefix sqlite3 sqlite3:)) +(include "/nfs/site/disks/icf_fdk_cw_gwa002/srehman/fossil/dbi/dbi.scm") +(import (prefix dbi dbi:)) (declare (unit portlogger)) (declare (uses db)) + ;; lsof -i (define (portlogger:open-db fname) (let* ((avail (tasks:wait-on-journal fname 5 remove: #t)) ;; wait up to about 10 seconds for the journal to go away (exists (file-exists? fname)) (db (if avail - (sqlite3:open-database fname) + (dbi:open 'sqlite3 '((dbname . fname))) (begin (system (conc "rm -f " fname)) - (sqlite3:open-database fname)))) + (dbi:open 'sqlite3 '((dbname . fname)))))) (handler (make-busy-timeout 136000)) (canwrite (file-write-access? fname))) ;; (db-init (lambda () ;; (sqlite3:execute ;; db @@ -35,14 +38,14 @@ ;; "CREATE TABLE IF NOT EXISTS ports ( ;; port INTEGER PRIMARY KEY, ;; state TEXT DEFAULT 'not-used', ;; fail_count INTEGER DEFAULT 0, ;; update_time TIMESTAMP DEFAULT (strftime('%s','now')) );")))) - (sqlite3:set-busy-handler! db handler) + ;;(sqlite3:set-busy-handler! db handler) (db:set-sync db) ;; (sqlite3:execute db "PRAGMA synchronous = 0;") ;; (if (not exists) ;; needed with IF NOT EXISTS? - (sqlite3:execute + (dbi:exec db "CREATE TABLE IF NOT EXISTS ports ( port INTEGER PRIMARY KEY, state TEXT DEFAULT 'not-used', fail_count INTEGER DEFAULT 0, @@ -62,43 +65,43 @@ (if (file-exists? fname)(delete-file fname)) ;; brutally get rid of it (print-call-chain (current-error-port))) (let* (;; (lock (obtain-dot-lock fname 2 9 10)) (db (portlogger:open-db fname)) (res (apply proc db params))) - (sqlite3:finalize! db) + (dbi:close db) ;; (release-dot-lock fname) res)))) ;; (fold-row PROC INIT DATABASE SQL . PARAMETERS) (define (portlogger:take-port db portnum) - (let* ((qry1 (sqlite3:prepare db "INSERT INTO ports (port,state) VALUES (?,?);")) - (qry2 (sqlite3:prepare db "UPDATE ports SET state=?,update_time=strftime('%s','now') WHERE port=?;")) - (qry3 (sqlite3:prepare db "SELECT state FROM ports WHERE port=?;")) - (res (sqlite3:with-transaction + (let* ((qry1 (dbi:prepare db "INSERT INTO ports (port,state) VALUES (?,?);")) + (qry2 (dbi:prepare db "UPDATE ports SET state=?,update_time=strftime('%s','now') WHERE port=?;")) + (qry3 (dbi:prepare db "SELECT state FROM ports WHERE port=?;")) + (res (dbi:with-transaction db (lambda () ;; (fold-row (lambda (var curr) (or var curr)) #f db "SELECT var FROM foo WHERE id=100;") (let* ((curr #f) (res #f)) - (set! curr (sqlite3:fold-row + (set! curr (dbi:fold-row (lambda (var curr) (or curr var curr)) "not-tried" qry3 portnum)) ;; (print "curr=" curr) (set! res (case (string->symbol curr) - ((released) (sqlite3:execute qry2 "taken" portnum) 'taken) - ((not-tried) (sqlite3:execute qry1 portnum "taken") 'taken) + ((released) (dbi:execute qry2 "taken" portnum) 'taken) + ((not-tried) (dbi:execute qry1 portnum "taken") 'taken) ((taken) 'already-taken) ((failed) 'failed) (else 'error))) ;; (print "res=" res) res))))) - (sqlite3:finalize! qry1) - (sqlite3:finalize! qry2) - (sqlite3:finalize! qry3) + (dbi:close qry1) + (dbi:close qry2) + (dbi:close qry3) res)) (define (portlogger:get-prev-used-port db) (handle-exceptions exn @@ -107,11 +110,11 @@ (debug:print 0 *default-log-port* " message: " ((condition-property-accessor 'exn 'message) exn)) (debug:print 0 *default-log-port* "exn=" (condition->list exn)) (print-call-chain (current-error-port)) (debug:print 0 *default-log-port* "Continuing anyway.") #f) - (sqlite3:fold-row + (dbi:fold-row (lambda (var curr) (or curr var curr)) #f db "SELECT (port) FROM ports WHERE state='released' LIMIT 1;"))) @@ -137,16 +140,16 @@ portnum)) ;; set port to "released", "failed" etc. ;; (define (portlogger:set-port db portnum value) - (sqlite3:execute db "UPDATE ports SET state=?,update_time=strftime('%s','now') WHERE port=?;" value portnum)) + (dbi:execute db "UPDATE ports SET state=?,update_time=strftime('%s','now') WHERE port=?;" value portnum)) ;; set port to failed (attempted to take but got error) ;; (define (portlogger:set-failed db portnum) - (sqlite3:execute db "UPDATE ports SET state='failed',fail_count=fail_count+1,update_time=strftime('%s','now') WHERE port=?;" portnum)) + (dbi:execute db "UPDATE ports SET state='failed',fail_count=fail_count+1,update_time=strftime('%s','now') WHERE port=?;" portnum)) ;;====================================================================== ;; MAIN ;;====================================================================== @@ -172,9 +175,9 @@ (portlogger:set-port db (if (number? port) port (string->number port)) state) state)) ((failed)(portlogger:set-failed db (string->number (cadr args))) 'failed))))) - (sqlite3:finalize! db) + (dbi:close db) result)) ;; (print (apply portlogger:main (cdr (argv)))) Index: runs.scm ================================================================== --- runs.scm +++ runs.scm @@ -11,10 +11,12 @@ ;; strftime('%m/%d/%Y %H:%M:%S','now','localtime') (use sqlite3 srfi-1 posix regex regex-case srfi-69 dot-locking (srfi 18) posix-extras directory-utils pathname-expand typed-records format) (import (prefix sqlite3 sqlite3:)) +(include "/nfs/site/disks/icf_fdk_cw_gwa002/srehman/fossil/dbi/dbi.scm") +(import (prefix dbi dbi:)) (declare (unit runs)) (declare (uses db)) (declare (uses common)) (declare (uses items)) @@ -2000,11 +2002,11 @@ (full-name (conc testname "/" item-path)) (prev-test-dat (hash-table-ref/default curr-tests-hash full-name #f)) (test-steps (rmt:get-steps-for-test (db:test-get-id testdat))) (new-test-record #f)) ;; replace these with insert ... select - (apply sqlite3:execute + (apply dbi:exec db (conc "INSERT OR REPLACE INTO tests (run_id,testname,state,status,event_time,host,cpuload,diskfree,uname,rundir,item_path,run_duration,final_logf,comment) " "VALUES (?,?,?,?,?,?,?,?,?,?,?,?,?,?);") new-run-id (cddr (vector->list testdat))) (set! new-testdat (car (mt:get-tests-for-run new-run-id (conc testname "/" item-path) '() '()))) @@ -2011,21 +2013,21 @@ (hash-table-set! curr-tests-hash full-name new-testdat) ;; this could be confusing, which record should go into the lookup table? ;; Now duplicate the test steps (debug:print 4 *default-log-port* "Copying records in test_steps from test_id=" (db:test-get-id testdat) " to " (db:test-get-id new-testdat)) (cdb:remote-run ;; to be replaced, note: this routine is not used currently (lambda () - (sqlite3:execute + (dbi:exec db (conc "INSERT OR REPLACE INTO test_steps (test_id,stepname,state,status,event_time,comment) " "SELECT " (db:test-get-id new-testdat) ",stepname,state,status,event_time,comment FROM test_steps WHERE test_id=?;") (db:test-get-id testdat)) ;; Now duplicate the test data (debug:print 4 *default-log-port* "Copying records in test_data from test_id=" (db:test-get-id testdat) " to " (db:test-get-id new-testdat)) - (sqlite3:execute + (dbi:exec db (conc "INSERT OR REPLACE INTO test_data (test_id,category,variable,value,expected,tol,units,comment) " "SELECT " (db:test-get-id new-testdat) ",category,variable,value,expected,tol,units,comment FROM test_data WHERE test_id=?;") (db:test-get-id testdat)))) )) prev-tests))) Index: sdb.scm ================================================================== --- sdb.scm +++ sdb.scm @@ -16,10 +16,12 @@ (require-extension (srfi 18) extras) (use sqlite3 srfi-1 posix regex regex-case srfi-69 csv-xml s11n md5 message-digest base64) (import (prefix sqlite3 sqlite3:)) (import (prefix base64 base64:)) +(include "/nfs/site/disks/icf_fdk_cw_gwa002/srehman/fossil/dbi/dbi.scm") +(import (prefix dbi dbi:)) (declare (unit sdb)) ;; (define (sdb:open fname) @@ -28,47 +30,47 @@ (if fe fe (begin (create-directory dbpath #t) #f)))) - (sdb (sqlite3:open-database fname)) + (sdb (dbi:open 'sqlite3 (cons (cons ('dbname fname) '())))) (handler (make-busy-timeout 136000))) - (sqlite3:set-busy-handler! sdb handler) + ;;(sqlite3:set-busy-handler! sdb handler) (if (not dbexists) (sdb:initialize sdb)) - (sqlite3:execute sdb "PRAGMA synchronous = 1;") + (dbi:exec sdb "PRAGMA synchronous = 1;") sdb)) (define (sdb:initialize sdb) - (sqlite3:execute sdb "CREATE TABLE IF NOT EXISTS strs + (dbi:exec sdb "CREATE TABLE IF NOT EXISTS strs (id INTEGER PRIMARY KEY, str TEXT, CONSTRAINT str UNIQUE (str));") - (sqlite3:execute sdb "CREATE INDEX IF NOT EXISTS strindx ON strs (str);")) + (dbi:exec sdb "CREATE INDEX IF NOT EXISTS strindx ON strs (str);")) ;; (define sumup (let ((a 0))(lambda (x)(set! a (+ x a)) a))) (define (sdb:register-string sdb str) - (sqlite3:execute sdb "INSERT OR IGNORE INTO strs (str) VALUES (?);" str)) + (dbi:exec sdb "INSERT OR IGNORE INTO strs (str) VALUES (?);" str)) (define (sdb:string->id sdb str-cache str) (let ((id (hash-table-ref/default str-cache str #f))) (if (not id) - (sqlite3:for-each-row + (dbi:for-each-row (lambda (sid) - (set! id sid) + (set! id (vector-ref sid 0)) (hash-table-set! str-cache str id)) sdb "SELECT id FROM strs WHERE str=?;" str)) id)) (define (sdb:id->string sdb id-cache id) (let ((str (hash-table-ref/default id-cache id #f))) (if (not str) - (sqlite3:for-each-row + (dbi:for-each-row (lambda (istr) - (set! str istr) + (set! str (vector-ref istr 0)) (hash-table-set! id-cache id str)) sdb "SELECT str FROM strs WHERE id=?;" id)) str)) @@ -84,11 +86,11 @@ (sdb:open (if var var fname))))) ((setdb) (set! sdb var)) ((getdb) sdb) ((finalize) (if sdb (begin - (sqlite3:finalize! sdb) + (dbi:close sdb) (set! sdb #f)))) ((getid) (let ((id (if (or (number? var) (string->number var)) var (sdb:string->id sdb scache var)))) Index: tasks.scm ================================================================== --- tasks.scm +++ tasks.scm @@ -9,10 +9,13 @@ ;; strftime('%m/%d/%Y %H:%M:%S','now','localtime') (use sqlite3 srfi-1 posix regex regex-case srfi-69 dot-locking format) (import (prefix sqlite3 sqlite3:)) +(include "/nfs/site/disks/icf_fdk_cw_gwa002/srehman/fossil/dbi/dbi.scm") +(import (prefix dbi dbi:)) + (declare (unit tasks)) (declare (uses db)) (declare (uses rmt)) (declare (uses common)) @@ -94,29 +97,32 @@ (let* ((dbpath (tasks:get-task-db-path)) (dbfile (conc dbpath "/monitor.db")) (avail (tasks:wait-on-journal dbpath 10)) ;; wait up to about 10 seconds for the journal to go away (exists (file-exists? dbpath)) (write-access (file-write-access? dbpath)) + (dbdat '()) (mdb (cond ;; what the hek is *toppath* doing here? ((and (string? *toppath*)(file-write-access? *toppath*)) - (sqlite3:open-database dbfile)) - ((file-read-access? dbpath) (sqlite3:open-database dbfile)) - (else (sqlite3:open-database ":memory:")))) ;; (never-give-up-open-db dbpath)) - (handler (make-busy-timeout 36000))) + (set! dbdat (cons (cons 'dbname dbfile) dbdat)) + (dbi:open 'sqlite3 dbdat)) + ((file-read-access? dbpath) (dbi:open 'sqlite3 dbdat)) + (else (dbi:open 'sqlite3 '((dbname . ":memory:"))))))) ;; (never-give-up-open-db dbpath)) + ;;(handler (make-busy-timeout 36000))) + (if (and exists (not write-access)) (set! *db-write-access* write-access)) ;; only unset so other db's also can use this control - (sqlite3:set-busy-handler! mdb handler) - (db:set-sync mdb) ;; (sqlite3:execute mdb (conc "PRAGMA synchronous = 0;")) + ;;(sqlite3:set-busy-handler! mdb handler) + (db:set-sync mdb) ;; (dbi:exec mdb (conc "PRAGMA synchronous = 0;")) ;; (if (or (and (not exists) ;; (file-write-access? *toppath*)) ;; (not (file-read-access? dbpath))) ;; (begin ;; ;; TASKS QUEUE MOVED TO main.db ;; - ;; (sqlite3:execute mdb "CREATE TABLE IF NOT EXISTS tasks_queue (id INTEGER PRIMARY KEY, + ;; (dbi:exec mdb "CREATE TABLE IF NOT EXISTS tasks_queue (id INTEGER PRIMARY KEY, ;; action TEXT DEFAULT '', ;; owner TEXT, ;; state TEXT DEFAULT 'new', ;; target TEXT DEFAULT '', ;; name TEXT DEFAULT '', @@ -123,18 +129,18 @@ ;; testpatt TEXT DEFAULT '', ;; keylock TEXT, ;; params TEXT, ;; creation_time TIMESTAMP, ;; execution_time TIMESTAMP);") - (sqlite3:execute mdb "CREATE TABLE IF NOT EXISTS monitors (id INTEGER PRIMARY KEY, + (dbi:exec mdb "CREATE TABLE IF NOT EXISTS monitors (id INTEGER PRIMARY KEY, pid INTEGER, start_time TIMESTAMP, last_update TIMESTAMP, hostname TEXT, username TEXT, CONSTRAINT monitors_constraint UNIQUE (pid,hostname));") - (sqlite3:execute mdb "CREATE TABLE IF NOT EXISTS servers (id INTEGER PRIMARY KEY, + (dbi:exec mdb "CREATE TABLE IF NOT EXISTS servers (id INTEGER PRIMARY KEY, pid INTEGER, interface TEXT, hostname TEXT, port INTEGER, pubport INTEGER, @@ -144,11 +150,11 @@ mt_version TEXT, heartbeat TIMESTAMP, transport TEXT, run_id INTEGER);") ;; CONSTRAINT servers_constraint UNIQUE (pid,hostname,port));") - (sqlite3:execute mdb "CREATE TABLE IF NOT EXISTS clients (id INTEGER PRIMARY KEY, + (dbi:exec mdb "CREATE TABLE IF NOT EXISTS clients (id INTEGER PRIMARY KEY, server_id INTEGER, pid INTEGER, hostname TEXT, cmdline TEXT, login_time TIMESTAMP, @@ -181,11 +187,11 @@ (tasks:server-am-i-the-server? mdb run-id)) #f)) ;; register that this server may come online (first to register goes though with the process) (define (tasks:server-set-available mdb run-id) - (sqlite3:execute + (dbi:exec mdb "INSERT INTO servers (pid,hostname,port,pubport,start_time, priority,state,mt_version,heartbeat, interface,transport,run_id) VALUES(?, ?, ?, ?, strftime('%s','now'), ?, ?, ?,-1,?, ?, ?);" (current-process-id) ;; pid (get-host-name) ;; hostname @@ -200,64 +206,66 @@ run-id )) (define (tasks:num-in-available-state mdb run-id) (let ((res 0)) - (sqlite3:for-each-row + (dbi:for-each-row + (lambda (output) (lambda (num-in-queue) - (set! res num-in-queue)) + (set! res num-in-queue))) mdb "SELECT count(id) FROM servers WHERE run_id=? AND state = 'available' AND (strftime('%s','now') - start_time) < 30 ;" run-id) res)) (define (tasks:num-servers-non-zero-running mdb) (let ((res 0)) - (sqlite3:for-each-row + (dbi:for-each-row + (lambda (output) (lambda (num-running) - (set! res num-running)) + (set! res num-running))) mdb "SELECT count(id) FROM servers WHERE run_id != 0 AND state = 'running';") res)) (define (tasks:server-clean-out-old-records-for-run-id mdb run-id tag) - (sqlite3:execute mdb "UPDATE servers SET state=?,heartbeat=strftime('%s','now') WHERE state in ('available','dbprep','shutting-down') AND (strftime('%s','now') - start_time) > 50 AND run_id=?;" + (dbi:exec mdb "UPDATE servers SET state=?,heartbeat=strftime('%s','now') WHERE state in ('available','dbprep','shutting-down') AND (strftime('%s','now') - start_time) > 50 AND run_id=?;" (conc "defunct" tag) run-id)) (define (tasks:server-force-clean-running-records-for-run-id mdb run-id tag) - (sqlite3:execute mdb "UPDATE servers SET state=?,heartbeat=strftime('%s','now') WHERE state = 'running' AND run_id=?;" + (dbi:exec mdb "UPDATE servers SET state=?,heartbeat=strftime('%s','now') WHERE state = 'running' AND run_id=?;" (conc "defunct" tag) run-id)) (define (tasks:server-force-clean-run-record mdb run-id iface port tag) - (sqlite3:execute mdb "UPDATE servers SET state=?,heartbeat=strftime('%s','now') WHERE state = 'running' AND run_id=? AND interface=? AND port=?;" + (dbi:exec mdb "UPDATE servers SET state=?,heartbeat=strftime('%s','now') WHERE state = 'running' AND run_id=? AND interface=? AND port=?;" (conc "defunct" tag) run-id iface port)) ;; BB> adding missing func for --list-servers (define (tasks:server-deregister mdb hostname #!key (pullport #f) (pid #f) (action #f)) ;;pullport pid: pid action: 'delete)) (if (eq? action 'delete) - (sqlite3:execute mdb "DELETE FROM servers WHERE pid=? AND port=? AND hostname=?;" pid pullport hostname) - (sqlite3:execute mdb "UPDATE servers SET state='defunct', heartbeat=strftime('%s','now') WHERE hostname=? AND pid=?;" + (dbi:exec mdb "DELETE FROM servers WHERE pid=? AND port=? AND hostname=?;" pid pullport hostname) + (dbi:exec mdb "UPDATE servers SET state='defunct', heartbeat=strftime('%s','now') WHERE hostname=? AND pid=?;" hostname pid))) (define (tasks:server-delete-records-for-this-pid mdb tag) - (sqlite3:execute mdb "UPDATE servers SET state=?,heartbeat=strftime('%s','now') WHERE hostname=? AND pid=?;" + (dbi:exec mdb "UPDATE servers SET state=?,heartbeat=strftime('%s','now') WHERE hostname=? AND pid=?;" (conc "defunct" tag) (get-host-name) (current-process-id))) (define (tasks:server-delete-record mdb server-id tag) - (sqlite3:execute mdb "UPDATE servers SET state=?,heartbeat=strftime('%s','now') WHERE id=?;" + (dbi:exec mdb "UPDATE servers SET state=?,heartbeat=strftime('%s','now') WHERE id=?;" (conc "defunct" tag) server-id) ;; use this opportuntity to clean out records over one month old or over 10 minutes old with port = -1 (i.e. a never used placeholder) - (sqlite3:execute mdb "DELETE FROM servers WHERE state not in ('running','shutting-down','dbprep') AND (strftime('%s','now') - start_time) > 2628000;") - (sqlite3:execute mdb "DELETE FROM servers WHERE state like 'defunct%' AND port=-1 AND (strftime('%s','now') - start_time) > 600;") + (dbi:exec mdb "DELETE FROM servers WHERE state not in ('running','shutting-down','dbprep') AND (strftime('%s','now') - start_time) > 2628000;") + (dbi:exec mdb "DELETE FROM servers WHERE state like 'defunct%' AND port=-1 AND (strftime('%s','now') - start_time) > 600;") ) (define (tasks:server-set-state! mdb server-id state) - (sqlite3:execute mdb "UPDATE servers SET state=?,heartbeat=strftime('%s','now') WHERE id=?;" state server-id)) + (dbi:exec mdb "UPDATE servers SET state=?,heartbeat=strftime('%s','now') WHERE id=?;" state server-id)) (define (tasks:server-set-interface-port mdb server-id interface port) - (sqlite3:execute mdb "UPDATE servers SET interface=?,port=?,heartbeat=strftime('%s','now') WHERE id=?;" interface port server-id)) + (dbi:exec mdb "UPDATE servers SET interface=?,port=?,heartbeat=strftime('%s','now') WHERE id=?;" interface port server-id)) ;; Get random port not used in long time ;; (define (tasks:server-get-next-port mdb) (let* ((lownum 30000) @@ -272,13 +280,14 @@ ;; (config-port (if (and (config-lookup *configdat* "server" "port") ;; (string->number (config-lookup *configdat* "server" "port"))) ;; (string->number (config-lookup *configdat* "server" "port")) ;; #f)) ) - (sqlite3:for-each-row + (dbi:for-each-row + (lambda (output) (lambda (port) - (set! used-ports (cons port used-ports))) + (set! used-ports (cons port used-ports)))) mdb "SELECT port FROM servers;") (cond ((and port-param res) (if (> res port-param) res port-param)) (port-param port-param) @@ -319,13 +328,14 @@ ;; (define (tasks:server-get-servers-vying-for-run-id mdb run-id) (let* ((header (list "id" "hostname" "pid" "interface" "port" "pubport" "state" "run_id" "priority" "start_time")) (selstr (string-intersperse header ",")) (res '())) - (sqlite3:for-each-row + (dbi:for-each-row + (lambda (output) (lambda (a . b) - (set! res (cons (apply vector a b) res))) + (set! res (cons (apply vector a b) res)))) mdb (conc "SELECT " selstr " FROM servers WHERE run_id=? AND state in ('available','running','dbprep') ORDER BY start_time DESC;") run-id) (vector header res))) @@ -344,13 +354,14 @@ (begin (debug:print 0 *default-log-port* " trying call to tasks:get-server again in 10 seconds") (thread-sleep! 10) (tasks:get-server mdb run-id retries: (- retries 0))) (debug:print 0 *default-log-port* "10 tries of tasks:get-server all crashed and burned. Giving up and returning \"no server found\""))) - (sqlite3:for-each-row + (dbi:for-each-row + (lambda (output) (lambda (id interface port pubport transport pid hostname) - (set! res (vector id interface port pubport transport pid hostname))) + (set! res (vector id interface port pubport transport pid hostname)))) mdb ;; removed: ;; strftime('%s','now')-heartbeat < 10 AND mt_version = ? "SELECT id,interface,port,pubport,transport,pid,hostname FROM servers WHERE run_id=? AND state='running' @@ -357,22 +368,24 @@ ORDER BY start_time DESC LIMIT 1;" run-id) ;; (common:version-signature) run-id) res))) (define (tasks:server-running-or-starting? mdb run-id) (let ((res #f)) - (sqlite3:for-each-row + (dbi:for-each-row + (lambda (output) (lambda (id) - (set! res id)) + (set! res id))) mdb ;; NEEDS dbprep ADDED "SELECT id FROM servers WHERE run_id=? AND (state = 'running' OR (state = 'dbprep' AND (strftime('%s','now') - start_time) < 60));" run-id) res)) (define (tasks:server-running? mdb run-id) (let ((res #f)) - (sqlite3:for-each-row + (dbi:for-each-row + (lambda (output) (lambda (id) - (set! res id)) + (set! res id))) mdb ;; NEEDS dbprep ADDED "SELECT id FROM servers WHERE run_id=? AND state = 'running';" run-id) res)) (define (tasks:need-server run-id) @@ -412,37 +425,42 @@ #f)) #f))) (define (tasks:get-all-servers mdb) (let ((res '())) - (sqlite3:for-each-row + (dbi:for-each-row + (lambda (output) (lambda (id pid hostname interface port pubport start-time priority state mt-version last-update transport run-id) ;; 0 1 2 3 4 5 6 7 8 9 10 11 12 - (set! res (cons (vector id pid hostname interface port pubport start-time priority state mt-version last-update transport run-id) res))) + (set! res (cons (vector id pid hostname interface port pubport start-time priority state mt-version last-update transport run-id) res)))) mdb "SELECT id,pid,hostname,interface,port,pubport,start_time,priority,state,mt_version,strftime('%s','now')-heartbeat AS last_update,transport,run_id FROM servers WHERE state NOT LIKE 'defunct%' ORDER BY start_time DESC;") res)) (define (tasks:get-server-by-id mdb id) (let ((res #f)) - (sqlite3:for-each-row + (dbi:for-each-row + (lambda (output) + (lambda (id pid hostname interface port pubport start-time priority state mt-version last-update transport run-id) ;; 0 1 2 3 4 5 6 7 8 9 10 11 12 - (set! res (vector id pid hostname interface port pubport start-time priority state mt-version last-update transport run-id))) + (set! res (vector id pid hostname interface port pubport start-time priority state mt-version last-update transport run-id)))) mdb "SELECT id,pid,hostname,interface,port,pubport,start_time,priority,state,mt_version,strftime('%s','now')-heartbeat AS last_update,transport,run_id FROM servers WHERE id=?;" id) res)) (define (tasks:get-server-records mdb run-id) (let ((res '())) - (sqlite3:for-each-row + (dbi:for-each-row + (lambda (output) + (lambda (id pid hostname interface port pubport start-time priority state mt-version last-update transport run-id) ;; 0 1 2 3 4 5 6 7 8 9 10 11 12 - (set! res (cons (vector id pid hostname interface port pubport start-time priority state mt-version last-update transport run-id) res))) + (set! res (cons (vector id pid hostname interface port pubport start-time priority state mt-version last-update transport run-id) res)))) mdb "SELECT id,pid,hostname,interface,port,pubport,start_time,priority,state,mt_version,strftime('%s','now')-heartbeat AS last_update,transport,run_id FROM servers WHERE run_id=? AND state NOT LIKE 'defunct%' ORDER BY start_time DESC;" run-id) (reverse res))) @@ -477,19 +495,20 @@ ;;====================================================================== ;; M O N I T O R S ;;====================================================================== (define (tasks:remove-monitor-record mdb) - (sqlite3:execute mdb "DELETE FROM monitors WHERE pid=? AND hostname=?;" + (dbi:exec mdb "DELETE FROM monitors WHERE pid=? AND hostname=?;" (current-process-id) (get-host-name))) (define (tasks:get-monitors mdb) (let ((res '())) - (sqlite3:for-each-row + (dbi:for-each-row + (lambda (output) (lambda (a . rem) - (set! res (cons (apply vector a rem) res))) + (set! res (cons (apply vector a rem) res)))) mdb "SELECT id,pid,strftime('%m/%d/%Y %H:%M',datetime(start_time,'unixepoch'),'localtime'),strftime('%m/%d/%Y %H:%M:%S',datetime(last_update,'unixepoch'),'localtime'),hostname,username FROM monitors ORDER BY last_update ASC;") (reverse res) )) @@ -509,36 +528,38 @@ "\n")))) ;; update the last_update field with the current time and ;; if any monitors appear dead, remove them (define (tasks:monitors-update mdb) - (sqlite3:execute mdb "UPDATE monitors SET last_update=strftime('%s','now') WHERE pid=? AND hostname=?;" + (dbi:exec mdb "UPDATE monitors SET last_update=strftime('%s','now') WHERE pid=? AND hostname=?;" (current-process-id) (get-host-name)) (let ((deadlist '())) - (sqlite3:for-each-row + (dbi:for-each-row + (lambda (output) (lambda (id pid host last-update delta) (print "Going to delete stale record for monitor with pid " pid " on host " host " last updated " delta " seconds ago") - (set! deadlist (cons id deadlist))) + (set! deadlist (cons id deadlist)))) mdb "SELECT id,pid,hostname,last_update,strftime('%s','now')-last_update AS delta FROM monitors WHERE delta > 700;") - (sqlite3:execute mdb (conc "DELETE FROM monitors WHERE id IN ('" (string-intersperse (map conc deadlist) "','") "');"))) + (dbi:exec mdb (conc "DELETE FROM monitors WHERE id IN ('" (string-intersperse (map conc deadlist) "','") "');"))) ) (define (tasks:register-monitor db port) (let* ((pid (current-process-id)) (hostname (get-host-name)) (userinfo (user-information (current-user-id))) (username (car userinfo))) (print "Register monitor, pid: " pid ", hostname: " hostname ", port: " port ", username: " username) - (sqlite3:execute db "INSERT INTO monitors (pid,start_time,last_update,hostname,username) VALUES (?,strftime('%s','now'),strftime('%s','now'),?,?);" + (dbi:exec db "INSERT INTO monitors (pid,start_time,last_update,hostname,username) VALUES (?,strftime('%s','now'),strftime('%s','now'),?,?);" pid hostname username))) (define (tasks:get-num-alive-monitors mdb) (let ((res 0)) - (sqlite3:for-each-row + (dbi:for-each-row + (lambda (output) (lambda (count) - (set! res count)) + (set! res count))) mdb "SELECT count(id) FROM monitors WHERE last_update < (strftime('%s','now') - 300) AND username=?;" (car (user-information (current-user-id)))) res)) @@ -590,11 +611,11 @@ ;; register a task (define (tasks:add dbstruct action owner target runname testpatt params) (db:with-db dbstruct #f #t (lambda (db) - (sqlite3:execute db "INSERT INTO tasks_queue (action,owner,state,target,name,testpatt,params,creation_time,execution_time) + (dbi:exec db "INSERT INTO tasks_queue (action,owner,state,target,name,testpatt,params,creation_time,execution_time) VALUES (?,?,'new',?,?,?,?,strftime('%s','now'),0);" action owner target runname @@ -626,42 +647,44 @@ (keytxt (conc (current-process-id) "-" (get-host-name) "-" (car (user-information (current-user-id)))))) (db:with-db dbstruct #f #t (lambda (db) ;; first randomly set a new to pid-hostname-hostname - (sqlite3:execute + (dbi:exec db "UPDATE tasks_queue SET keylock=? WHERE id IN (SELECT id FROM tasks_queue WHERE state='new' OR (state='waiting' AND (strftime('%s','now')-execution_time) > 10) OR state='reset' ORDER BY RANDOM() LIMIT 1);" keytxt) - (sqlite3:for-each-row + (dbi:for-each-row + (lambda (output) (lambda (id . rem) - (set! res (apply vector id rem))) + (set! res (apply vector id rem)))) db "SELECT id,action,owner,state,target,name,test,item,params,creation_time,execution_time FROM tasks_queue WHERE keylock=? ORDER BY execution_time ASC LIMIT 1;" keytxt) (if res ;; yep, have work to be done (begin - (sqlite3:execute db "UPDATE tasks_queue SET state='inprogress',execution_time=strftime('%s','now') WHERE id=?;" + (dbi:exec db "UPDATE tasks_queue SET state='inprogress',execution_time=strftime('%s','now') WHERE id=?;" (tasks:task-get-id res)) res) #f))))) (define (tasks:reset-stuck-tasks dbstruct) (let ((res '())) (db:with-db dbstruct #f #t (lambda (db) - (sqlite3:for-each-row + (dbi:for-each-row + (lambda (output) (lambda (id delta) - (set! res (cons id res))) + (set! res (cons id res)))) db "SELECT id,strftime('%s','now')-execution_time AS delta FROM tasks_queue WHERE state='inprogress' AND delta>700 ORDER BY delta DESC LIMIT 2;") - (sqlite3:execute + (dbi:exec db (conc "UPDATE tasks_queue SET state='reset' WHERE id IN ('" (string-intersperse (map conc res) "','") "');") ))))) ;; return all tasks in the tasks_queue table @@ -669,13 +692,14 @@ (define (tasks:get-tasks dbstruct types states) (let ((res '())) (db:with-db dbstruct #f #f (lambda (db) - (sqlite3:for-each-row + (dbi:for-each-row + (lambda (output) (lambda (id . rem) - (set! res (cons (apply vector id rem) res))) + (set! res (cons (apply vector id rem) res)))) db (conc "SELECT id,action,owner,state,target,name,test,item,params,creation_time,execution_time FROM tasks_queue " ;; WHERE ;; state IN " statesstr " AND @@ -686,13 +710,14 @@ (define (tasks:get-last dbstruct target runname) (let ((res #f)) (db:with-db dbstruct #f #f (lambda (db) - (sqlite3:for-each-row - (lambda (id . rem) - (set! res (apply vector id rem))) + (dbi:for-each-row + (lambda (output) + (lambda (id . rem) + (set! res (apply vector id rem)))) db (conc "SELECT id,action,owner,state,target,name,testpatt,keylock,params,creation_time,execution_time FROM tasks_queue WHERE target = ? AND name =? @@ -703,11 +728,11 @@ ;; remove tasks given by a string of numbers comma separated (define (tasks:remove-queue-entries dbstruct task-ids) (db:with-db dbstruct #f #t (lambda (db) - (sqlite3:execute db (conc "DELETE FROM tasks_queue WHERE id IN (" task-ids ");"))))) + (dbi:exec db (conc "DELETE FROM tasks_queue WHERE id IN (" task-ids ");"))))) (define (tasks:process-queue dbstruct) (let* ((task (tasks:snag-a-task dbstruct)) (action (if task (tasks:task-get-action task) #f))) (if action (print "tasks:process-queue task: " task)) @@ -740,11 +765,11 @@ (define (tasks:set-state dbstruct task-id state) (db:with-db dbstruct #f #t (lambda (db) - (sqlite3:execute db "UPDATE tasks_queue SET state=? WHERE id=?;" + (dbi:exec db "UPDATE tasks_queue SET state=? WHERE id=?;" state task-id)))) ;;====================================================================== ;; Access using task key (stored in params; (hash-table->alist flags) hostname pid @@ -755,27 +780,27 @@ dbstruct #f #f (lambda (db) (handle-exceptions exn #f - (sqlite3:first-result db "SELECT id FROM tasks_queue WHERE params LIKE ?;" + (dbi:get-one db "SELECT id FROM tasks_queue WHERE params LIKE ?;" task-params))))) (define (tasks:set-state-given-param-key dbstruct param-key new-state) (db:with-db dbstruct #f #t (lambda (db) - (sqlite3:execute db "UPDATE tasks_queue SET state=? WHERE params LIKE ?;" new-state param-key)))) + (dbi:exec db "UPDATE tasks_queue SET state=? WHERE params LIKE ?;" new-state param-key)))) (define (tasks:get-records-given-param-key dbstruct param-key state-patt action-patt test-patt) (db:with-db dbstruct #f #f (lambda (db) (handle-exceptions exn '() - (sqlite3:first-row db "SELECT id,action,owner,state,target,name,testpatt,keylock,params WHERE + (dbi:get-one-row db "SELECT id,action,owner,state,target,name,testpatt,keylock,params WHERE params LIKE ? AND state LIKE ? AND action LIKE ? AND testpatt LIKE ?;" param-key state-patt action-patt test-patt))))) (define (tasks:find-task-queue-records dbstruct target run-name test-patt state-patt action-patt) ;; (handle-exceptions @@ -782,13 +807,14 @@ ;; exn ;; '() ;; (sqlite3:first-row (let ((db (db:delay-if-busy (db:get-db dbstruct #f))) (res '())) - (sqlite3:for-each-row + (dbi:for-each-row + (lambda (output) (lambda (a . b) - (set! res (cons (cons a b) res))) + (set! res (cons (cons a b) res)))) db "SELECT id,action,owner,state,target,name,testpatt,keylock,params FROM tasks_queue WHERE target = ? AND name = ? AND state LIKE ? AND action LIKE ? AND testpatt LIKE ?;" target run-name state-patt action-patt test-patt) res)) ;; ) Index: tdb.scm ================================================================== --- tdb.scm +++ tdb.scm @@ -15,10 +15,12 @@ (require-extension (srfi 18) extras tcp) (use sqlite3 srfi-1 posix regex regex-case srfi-69 csv-xml s11n md5 message-digest base64) (import (prefix sqlite3 sqlite3:)) (import (prefix base64 base64:)) +(include "/nfs/site/disks/icf_fdk_cw_gwa002/srehman/fossil/dbi/dbi.scm") +(import (prefix dbi dbi:)) (declare (unit tdb)) (declare (uses common)) (declare (uses keys)) (declare (uses ods)) @@ -52,31 +54,33 @@ (directory? work-area) (file-read-access? work-area)) (let* ((dbpath (conc work-area "/testdat.db")) (dbexists (file-exists? dbpath)) (work-area-writeable (file-write-access? work-area)) + (dbdat '()) (db (handle-exceptions ;; open the db if area writeable or db pre-existing. open in-mem otherwise. if exception, open in-mem exn (begin (print-call-chain (current-error-port)) (debug:print 2 *default-log-port* "ERROR: problem accessing test db " work-area ", you probably should clean and re-run this test" ((condition-property-accessor 'exn 'message) exn)) (set! dbexists #f) ;; must force re-creation of tables, more tom-foolery - (sqlite3:open-database ":memory:")) ;; open an in-memory db to allow readonly access + (set! dbdat (cons (cons 'dbname ":memory:") dbdat)) + (dbi:open 'sqlite3 dbdat)) ;; open an in-memory db to allow readonly access (if (or work-area-writeable dbexists) - (sqlite3:open-database dbpath) - (sqlite3:open-database ":memory:")))) + (set! dbdat (cons (cons 'dbname dbpath) dbdat)) + (set! dbdat (cons (cons 'dbname ":memory:") dbdat))))) (tdb-writeable (and (file-write-access? work-area) (file-write-access? dbpath))) (handler (make-busy-timeout (if (args:get-arg "-override-timeout") (string->number (args:get-arg "-override-timeout")) 136000)))) - (if (and tdb-writeable - *db-write-access*) - (sqlite3:set-busy-handler! db handler)) + ;;(if (and tdb-writeable + ;; *db-write-access*) + ;; (sqlite3:set-busy-handler! db handler)) (if (not dbexists) (begin (db:set-sync db) ;; (sqlite3:execute db "PRAGMA synchronous = FULL;") (debug:print-info 11 *default-log-port* "Initialized test database " dbpath) (tdb:testdb-initialize db))) @@ -91,14 +95,14 @@ dbpath ".\n " ((condition-property-accessor 'exn 'message) exn)) #f) ;; Is there a cheaper single line operation that will check for existance of a table ;; and raise an exception ? - (sqlite3:execute db "SELECT id FROM test_data LIMIT 1;")) + (dbi:exec db "SELECT id FROM test_data LIMIT 1;")) db) ;; no work-area or not readable - create a placeholder to fake rest of world out - (let ((baddb (sqlite3:open-database ":memory:"))) + (let ((baddb (dbi:open 'sqlite3 '((dbname . ":memory:"))))) (debug:print-info 11 *default-log-port* "open-test-db END (unsucessful)" work-area) ;; provide an in-mem db (this is dangerous!) (tdb:testdb-initialize baddb) baddb))) @@ -126,16 +130,16 @@ (tdb (open-test-db test-path))) (apply proc tdb params))) (define (tdb:testdb-initialize db) (debug:print 11 *default-log-port* "db:testdb-initialize START") - (sqlite3:with-transaction + (dbi:with-transaction db (lambda () (for-each (lambda (sqlcmd) - (sqlite3:execute db sqlcmd)) + (dbi:exec db sqlcmd)) (list "CREATE TABLE IF NOT EXISTS test_rundat ( id INTEGER PRIMARY KEY, update_time TIMESTAMP, cpuload INTEGER DEFAULT -1, diskfree INTEGER DEFAULT -1, @@ -177,16 +181,16 @@ ;; This routine moved to db:read-test-data ;; (define (tdb:read-test-data tdb test-id categorypatt) (let ((res '())) - (sqlite3:for-each-row + (dbi:for-each-row (lambda (id test_id category variable value expected tol units comment status type) (set! res (cons (vector id test_id category variable value expected tol units comment status type) res))) tdb "SELECT id,test_id,category,variable,value,expected,tol,units,comment,status,type FROM test_data WHERE test_id=? AND category LIKE ? ORDER BY category,variable;" test-id categorypatt) - (sqlite3:finalize! tdb) + (dbi:close tdb) (reverse res))) ;;====================================================================== ;; T E S T D A T A ;;====================================================================== @@ -394,12 +398,12 @@ (string