Index: db.scm ================================================================== --- db.scm +++ db.scm @@ -479,12 +479,11 @@ ;; else return dbdat ;; (define (db:repair-db dbdat #!key (numtries 1)) (let* ((dbpath (db:dbdat-get-path dbdat)) (dbdir (pathname-directory dbpath)) - (fname (pathname-strip-directory dbpath)) - (dbdat '())) + (fname (pathname-strip-directory dbpath))) (debug:print-info 0 *default-log-port* "Checking db " dbpath " for errors.") (cond ((not (file-write-access? dbdir)) (debug:print 0 *default-log-port* "WARNING: can't write to " dbdir ", can't fix " fname) #f) @@ -607,12 +606,12 @@ (set! count (+ count 1))) fields) ;; read the source table (dbi:for-each-row - (lambda (a . b) - (set! fromdat (cons (apply vector a b) fromdat)) + (lambda (output) + (set! fromdat (cons output fromdat)) (if (> (length fromdat) batch-len) (begin (set! fromdats (cons fromdat fromdats)) (set! fromdat '()) (set! totrecords (+ totrecords 1))))) @@ -626,11 +625,11 @@ (if (common:low-noise-print 120 "sync-records") (debug:print-info 4 *default-log-port* "found " totrecords " records to sync")) ;; read the target table (dbi:for-each-row - (lambda (a . b) + (lambda (output) (hash-table-set! todat a (apply vector a b))) (db:dbdat-get-db todb) full-sel) ;; first pass implementation, just insert all changed rows @@ -1226,23 +1225,25 @@ (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 (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) '() (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 @@ -1256,12 +1257,13 @@ (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)) (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 @@ -1285,12 +1287,13 @@ (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 (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 @@ -1324,13 +1327,14 @@ #f #f (lambda (db) (let ((res #f)) (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)))) @@ -1400,33 +1404,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) - (dbi: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) (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.") @@ -1464,33 +1470,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) - (dbi: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) (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.") @@ -1545,42 +1553,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 (dbi:get-one db "SELECT (SELECT count(id) FROM tests)+(SELECT count(id) FROM runs);")) - (statements - (map (lambda (stmt) - (dbi:exec 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) (dbi:with-transaction db (lambda () (dbi:for-each-row (lambda (tot) - (debug:print-info 0 *default-log-port* "Records count before clean: " tot)) - count-stmt) + (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))) + (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) (dbi:exec db "VACUUM;"))) + ;; Clean out old junk and vacuum the database ;; ;; Ultimately do something like this: ;; @@ -1645,12 +1654,13 @@ ;; delete all tests that are 'DELETED' "DELETE FROM runs WHERE state='deleted';" ))) (dead-runs '())) (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) (dbi:with-transaction db @@ -1761,11 +1771,11 @@ #f ;; does not modify db (lambda (db) (let ((res #f)) (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)))) @@ -1776,11 +1786,11 @@ #f (lambda (db) (let ((res #f)) (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)))) @@ -1827,11 +1837,11 @@ (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 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) @@ -1875,12 +1885,12 @@ "")))) (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) (dbi:for-each-row - (lambda (a . x) - (set! res (cons (apply vector a x) res))) + (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))) @@ -1916,12 +1926,12 @@ dbstruct #f #f (lambda (db) (dbi:for-each-row - (lambda (a . x) - (let ((targ (cons a x))) + (lambda (output) + (let ((targ (cons 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 @@ -2027,12 +2037,13 @@ (res '()) (runs-info '())) ;; First get all the runname/run-ids ;; (db:delay-if-busy dbdat) (dbi:for-each-row - (lambda (run-id runname) - (set! runs-info (cons (list run-id runname) runs-info))) + (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) @@ -2043,16 +2054,17 @@ dbstruct run-id #f (lambda (db) (dbi: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)))))) + (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))) @@ -2124,12 +2136,15 @@ (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) (dbi:for-each-row - (lambda (a . x) - (set! res (apply vector a x))) + (lambda (output) + ;;(print "Output: " output) + ;;(print "A: " a) + ;;(print "X: " x) + (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))) @@ -2199,12 +2214,13 @@ dbstruct #f #f (lambda (db) (dbi:for-each-row - (lambda (status) - (set! res status)) + (lambda (output) + (lambda (status) + (set! res status))) db "SELECT status FROM runs WHERE id=?;" run-id) res)))) @@ -2222,12 +2238,13 @@ (for-each (lambda (key) (let ((qry (conc "SELECT " key " FROM runs WHERE id=?;"))) ;; (db:delay-if-busy dbdat) (dbi:for-each-row - (lambda (key-val) - (set! res (cons (list key key-val) res))) + (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 @@ -2238,13 +2255,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) - (dbi: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))) @@ -2264,12 +2282,13 @@ (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 dbi:for-each-row - (lambda (id) - (set! prev-run-ids (cons id prev-run-ids))) + (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))) ;;====================================================================== @@ -2360,13 +2379,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) - (dbi: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 @@ -2393,13 +2412,14 @@ (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) (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)) @@ -2406,13 +2426,14 @@ (define (db:get-testinfo-state-status dbstruct run-id test-id) (let ((res #f)) (db:with-db dbstruct run-id #f (lambda (db) (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)) @@ -2577,12 +2598,13 @@ 0 ;; (let ((testnames '())) ;; get the testnames ;; (db:delay-if-busy dbdat) (dbi:for-each-row + (lambda (output) (lambda (testname) - (set! testnames (cons testname testnames))) + (set! testnames (cons testname testnames)))) db "SELECT testname FROM test_meta WHERE jobgroup=?" jobgroup) ;; get the jobcount NB// EXTEND THIS TO OPPERATE OVER ALL RUNS? (if (not (null? testnames)) @@ -2680,14 +2702,15 @@ dbstruct)) ;; still settling on when to use dbstruct or dbdat (db (db:dbdat-get-db dbdat)) (res '())) ;; (db:delay-if-busy dbdat) (dbi:for-each-row + (lambda (output) (lambda (id run-id testname state status event-time host cpuload diskfree uname rundir item-path run-duration final-logf comment shortdir attemptnum archived) ;; 0 1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 (set! res (cons (vector id run-id testname state status event-time host cpuload diskfree uname rundir item-path run-duration final-logf comment shortdir attemptnum archived) - res))) + res)))) db (conc "SELECT " db:test-record-qry-selector " FROM tests WHERE state != 'DELETED' AND run_id=?;") run-id) res)) @@ -2713,13 +2736,14 @@ (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)) - (dbi: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 @@ -2757,13 +2781,14 @@ run-id #f (lambda (db) (let ((res #f)) (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)))) @@ -2776,13 +2801,13 @@ run-id #f (lambda (db) (let ((res '())) (dbi:for-each-row - (lambda (a . b) + (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)))) @@ -2792,12 +2817,12 @@ run-id #f (lambda (db) (let ((res #f)) (dbi:for-each-row - (lambda (a . b) - (set! res (apply vector a b))) + (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)))) @@ -2837,12 +2862,13 @@ run-id #f (lambda (db) (let* ((res '())) (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))))) @@ -2852,12 +2878,13 @@ run-id #f (lambda (db) (let ((res '())) (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))))) @@ -2875,13 +2902,14 @@ (db (db:dbdat-get-db dbdat)) (fail-count 0) (pass-count 0)) ;; (db:delay-if-busy dbdat) (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 @@ -3036,12 +3064,13 @@ (let* ((dbdat (db:get-db dbstruct run-id)) (db (db:dbdat-get-db dbdat)) (res '())) ;; (db:delay-if-busy dbdat) (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))) ;;====================================================================== @@ -3077,12 +3106,13 @@ dbstruct run-id #f (lambda (db) (dbi:for-each-row + (lambda (output) (lambda (p) - (set! res (cons p res))) + (set! res (cons p res)))) db tstsqry run-id) res)))) @@ -3092,12 +3122,13 @@ run-id #f (lambda (db) (let ((res 0)) (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)))) @@ -3276,18 +3307,19 @@ run-id #f (lambda (db) (let ((res #f)) (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)))) @@ -3474,12 +3506,13 @@ ;; NOTE: takes a db, not a dbstruct ;; (define (db:get-state-status-summary db run-id testname) (let ((res '())) (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)) @@ -3522,21 +3555,22 @@ (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) - (dbi:for-each-row - (lambda (a . b) - (set! keyvals (cons a b))) + (dbi:for-each-row + (lambda (output) + (set! keyvals (cons output))) db (conc "SELECT " selstr " FROM runs WHERE id=? ORDER BY event_time DESC;") run-id) (if (not keyvals) '() (let ((prev-run-ids '())) (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 @@ -3609,13 +3643,14 @@ (db:with-db dbstruct run-id #f (lambda (db) - (dbi: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)))) @@ -3630,12 +3665,13 @@ dbstruct #f #f (lambda (db) (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)))) @@ -3658,12 +3694,12 @@ (define (db:testmeta-get-all dbstruct) (db:with-db dbstruct #f #f (lambda (db) (let ((res '())) (dbi:for-each-row - (lambda (a . b) - (set! res (cons (apply vector a b) res))) + (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)))) ;;====================================================================== @@ -3853,10 +3889,11 @@ "\n mainqry: " mainqry) ;; "Expected Value" ;; "Value Found" ;; "Tolerance" (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 @@ -3885,11 +3922,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))) @@ -3897,13 +3934,14 @@ (for-each (lambda (test-id) (let ((test-data (list testdata-header)) (curr-test-name #f)) (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: 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: tasks.scm ================================================================== --- tasks.scm +++ tasks.scm @@ -207,22 +207,24 @@ )) (define (tasks:num-in-available-state mdb run-id) (let ((res 0)) (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)) (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) @@ -279,12 +281,13 @@ ;; (string->number (config-lookup *configdat* "server" "port"))) ;; (string->number (config-lookup *configdat* "server" "port")) ;; #f)) ) (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) @@ -326,12 +329,13 @@ (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 '())) (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))) @@ -351,12 +355,13 @@ (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\""))) (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' @@ -364,21 +369,23 @@ res))) (define (tasks:server-running-or-starting? mdb run-id) (let ((res #f)) (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)) (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) @@ -419,36 +426,41 @@ #f))) (define (tasks:get-all-servers mdb) (let ((res '())) (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)) (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 '())) (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))) @@ -490,12 +502,13 @@ (get-host-name))) (define (tasks:get-monitors mdb) (let ((res '())) (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) )) @@ -520,13 +533,14 @@ (dbi:exec mdb "UPDATE monitors SET last_update=strftime('%s','now') WHERE pid=? AND hostname=?;" (current-process-id) (get-host-name)) (let ((deadlist '())) (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;") (dbi:exec mdb (conc "DELETE FROM monitors WHERE id IN ('" (string-intersperse (map conc deadlist) "','") "');"))) ) (define (tasks:register-monitor db port) @@ -539,12 +553,13 @@ pid hostname username))) (define (tasks:get-num-alive-monitors mdb) (let ((res 0)) (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)) @@ -642,12 +657,13 @@ (state='waiting' AND (strftime('%s','now')-execution_time) > 10) OR state='reset' ORDER BY RANDOM() LIMIT 1);" keytxt) (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 (dbi:exec db "UPDATE tasks_queue SET state='inprogress',execution_time=strftime('%s','now') WHERE id=?;" @@ -659,12 +675,13 @@ (let ((res '())) (db:with-db dbstruct #f #t (lambda (db) (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;") (dbi:exec db (conc "UPDATE tasks_queue SET state='reset' WHERE id IN ('" (string-intersperse (map conc res) "','") "');") @@ -676,12 +693,13 @@ (let ((res '())) (db:with-db dbstruct #f #f (lambda (db) (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 @@ -693,12 +711,13 @@ (let ((res #f)) (db:with-db dbstruct #f #f (lambda (db) (dbi:for-each-row - (lambda (id . rem) - (set! res (apply vector id rem))) + (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 =? @@ -788,13 +807,14 @@ ;; exn ;; '() ;; (sqlite3:first-row (let ((db (db:delay-if-busy (db:get-db dbstruct #f))) (res '())) - (dbi: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)) ;; )