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, @@ -144,45 +146,45 @@ 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=?;")) (next-iteration 0)) - (sqlite3:with-transaction + (dbi:with-transaction db (lambda () - (sqlite3:for-each-row + (dbi:for-each-row (lambda (iteration) (if (and (number? iteration) (>= iteration next-iteration)) (set! next-iteration (+ iteration 1)))) 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)) 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 + (dbi:for-each-row (lambda (a . b) (set! res (apply vector a b))) db "SELECT * FROM pkgs WHERE area=? AND version_name=? AND iteration=?;" area @@ -206,15 +208,15 @@ ;; 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)) db "SELECT count(id) FROM refs WHERE pkg_id=?;" pkg-id) @@ -234,12 +236,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,25 +266,25 @@ (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 ... + (dbi:for-each-row ;; replace with fold ... (lambda (a . b) (set! res (cons (list->vector (cons a b)) 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 ";") @@ -290,11 +292,11 @@ (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 ... + (dbi:for-each-row ;; replace with fold ... (lambda (a . b) (set! dat (cons (list->vector (cons a b)) 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;") @@ -313,11 +315,11 @@ (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 (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))) 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;" @@ -341,18 +343,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 +379,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 +609,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 +741,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 +783,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 @@ -271,10 +271,11 @@ ;; db)) ;; This routine creates the db if not already present. It is only called if the db is not already opened ;; (define (db:open-db dbstruct #!key (areapath #f)) + (print (db:open-megatest-db path: (db:dbfile-path))) (let ((tmpdb (dbr:dbstruct-tmpdb dbstruct))) ;; RA => Returns the first reference in dbstruct (if tmpdb tmpdb ;; (mutex-lock! *rundb-mutex*) (let* ((dbpath (db:dbfile-path)) ;; 0)) @@ -635,11 +636,11 @@ ;; 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) (dbi:with-transaction db @@ -1592,14 +1593,14 @@ ;; 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';" @@ -1633,14 +1634,14 @@ ;; 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';" @@ -1675,16 +1676,17 @@ ;; returns number if string->number is successful, string otherwise ;; also updates *global-delta* ;; (define (db:get-var dbstruct var) + (print dbstruct var) (let* ((res #f) (dbdat (db:get-db dbstruct #f)) (db (db:dbdat-get-db dbdat))) (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))) @@ -1720,17 +1722,18 @@ ;; why get the keys from the db? why not get from the *configdat* ;; using keys:config-get-fields? (define (db:get-keys dbstruct) + (print dbstruct) (if *db-keys* *db-keys* (let ((res '())) (db:with-db dbstruct #f #f (lambda (db) (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))) @@ -1761,10 +1764,11 @@ #f ;; does not modify db (lambda (db) (let ((res #f)) (dbi:for-each-row (lambda (runname) + (print runname) (set! res runname)) db "SELECT runname FROM runs WHERE id=?;" run-id) res)))) @@ -1776,10 +1780,11 @@ #f (lambda (db) (let ((res #f)) (dbi:for-each-row (lambda (val) + (print val) (set! res val)) db (conc "SELECT " key " FROM runs WHERE id=?;") run-id) res)))) @@ -1952,11 +1957,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;;" @@ -1970,12 +1975,12 @@ 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 (dbi:with-transaction db (lambda () (for-each @@ -1991,11 +1996,11 @@ (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'));" @@ -2101,11 +2106,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 @@ -2694,11 +2699,11 @@ (define (db:replace-test-records dbstruct run-id testrecs) (db:with-db dbstruct run-id #t (lambda (db) (let* ((qmarks (string-intersperse (make-list (length db:test-record-fields) "?") ",")) (qrystr (conc "INSERT OR REPLACE INTO tests (" db:test-record-qry-selector ") VALUES (" qmarks ");")) - (qry (sqlite3:prepare db qrystr))) + (qry (dbi:prepare db qrystr))) (debug:print 0 *default-log-port* "INFO: migrating test records for run with id " run-id) (dbi:with-transaction db (lambda () (for-each @@ -3057,11 +3062,11 @@ (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) (dbi:for-each-row (lambda (rid) (set! row-ids (cons rid row-ids))) runsqry) 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=?;")) (id-num #f)) - (sqlite3:for-each-row + (dbi:for-each-row (lambda (num) (set! id-num num)) stmt path) - (sqlite3:finalize! stmt) + (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=?;")) (id-num #f)) - (sqlite3:for-each-row + (dbi:for-each-row (lambda (num) (set! id-num num)) stmt path parent) - (sqlite3:finalize! stmt) + (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))) + (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))) @@ -175,34 +177,34 @@ (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 ?;")) (result '())) - (sqlite3:for-each-row + (dbi:for-each-row (lambda (num) (action num) (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=?;")) (result #f)) - (sqlite3:for-each-row + (dbi:for-each-row (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,11 +213,11 @@ ;; 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 (id path parent-id) (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) 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,11 +102,11 @@ (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 (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))) (lock-queue:db-dat-get-db dbdat) @@ -127,26 +129,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) + (dbi:for-each-row (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 +158,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 +169,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 +184,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 +205,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 +216,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 +237,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 )) 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,34 +30,34 @@ (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) (hash-table-set! str-cache str id)) sdb "SELECT id FROM strs WHERE str=?;" str)) @@ -62,11 +64,11 @@ 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) (hash-table-set! id-cache id str)) sdb "SELECT str FROM strs WHERE id=?;" id)) @@ -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,11 +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)) @@ -108,19 +110,19 @@ (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;")) + (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 '', @@ -185,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 @@ -204,64 +206,64 @@ run-id )) (define (tasks:num-in-available-state mdb run-id) (let ((res 0)) - (sqlite3:for-each-row + (dbi:for-each-row (lambda (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 (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) @@ -276,11 +278,11 @@ ;; (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 (port) (set! used-ports (cons port used-ports))) mdb "SELECT port FROM servers;") (cond @@ -323,11 +325,11 @@ ;; (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 (a . b) (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) @@ -348,11 +350,11 @@ (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 (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 = ? @@ -361,20 +363,20 @@ 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 (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 (id) (set! res id)) mdb ;; NEEDS dbprep ADDED "SELECT id FROM servers WHERE run_id=? AND state = 'running';" run-id) res)) @@ -416,11 +418,11 @@ #f)) #f))) (define (tasks:get-all-servers mdb) (let ((res '())) - (sqlite3:for-each-row + (dbi:for-each-row (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))) mdb "SELECT id,pid,hostname,interface,port,pubport,start_time,priority,state,mt_version,strftime('%s','now')-heartbeat AS last_update,transport,run_id @@ -427,11 +429,11 @@ 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 (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))) mdb "SELECT id,pid,hostname,interface,port,pubport,start_time,priority,state,mt_version,strftime('%s','now')-heartbeat AS last_update,transport,run_id @@ -439,11 +441,11 @@ id) res)) (define (tasks:get-server-records mdb run-id) (let ((res '())) - (sqlite3:for-each-row + (dbi:for-each-row (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))) mdb "SELECT id,pid,hostname,interface,port,pubport,start_time,priority,state,mt_version,strftime('%s','now')-heartbeat AS last_update,transport,run_id @@ -481,17 +483,17 @@ ;;====================================================================== ;; 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 (a . rem) (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) @@ -513,34 +515,34 @@ "\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 (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))) 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 (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)))) @@ -594,11 +596,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 @@ -630,42 +632,42 @@ (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 (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 (id delta) (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 @@ -673,11 +675,11 @@ (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 (id . rem) (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 " @@ -690,11 +692,11 @@ (define (tasks:get-last dbstruct target runname) (let ((res #f)) (db:with-db dbstruct #f #f (lambda (db) - (sqlite3:for-each-row + (dbi:for-each-row (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 @@ -707,11 +709,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)) @@ -744,11 +746,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 @@ -759,27 +761,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 @@ -786,11 +788,11 @@ ;; 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 (a . b) (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 ?;" Index: tdb.scm ================================================================== --- tdb.scm +++ tdb.scm @@ -15,10 +15,11 @@ (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)) @@ -73,13 +74,13 @@ (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))) @@ -94,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))) @@ -129,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, @@ -180,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 ;;====================================================================== @@ -397,12 +398,12 @@ (string