Index: api.scm ================================================================== --- api.scm +++ api.scm @@ -95,10 +95,13 @@ login tasks-get-last testmeta-get-record have-incompletes? get-changed-record-ids + get-all-runids + get-changed-record-test-ids + get-changed-record-run-ids get-run-record-ids get-not-completed-cnt)) (define api:write-queries '( @@ -491,11 +494,14 @@ (realparams (cddr params))) (db:general-call dbstruct run-id stmtname realparams))) ((sdb-qry) (apply sdb:qry params)) ((ping) (current-process-id)) ((get-changed-record-ids) (apply db:get-changed-record-ids dbstruct params)) - ((get-run-record-ids) (apply db:get-run-record-ids dbstruct params)) + ((get-changed-record-test-ids) (apply db:get-changed-record-test-ids dbstruct params)) + ((get-changed-record-run-ids) (apply db:get-changed-record-run-ids dbstruct params)) + ((get-run-record-ids) (apply db:get-run-record-ids dbstruct params)) + ((get-all-runids) (apply db:get-all-runids dbstruct)) ;; TESTMETA ((testmeta-get-record) (apply db:testmeta-get-record dbstruct params)) ;; TASKS ((find-task-queue-records) (apply tasks:find-task-queue-records dbstruct params)) Index: cgisetup/models/pgdb.scm ================================================================== --- cgisetup/models/pgdb.scm +++ cgisetup/models/pgdb.scm @@ -18,10 +18,11 @@ ;;====================================================================== (declare (unit pgdb)) (declare (uses configf)) +(declare (uses mtargs)) ;; I don't know how to mix compilation units and modules, so no module here. ;; ;; (module pgdb ;; ( @@ -31,10 +32,11 @@ ;; (import scheme) ;; (import data-structures) ;; (import chicken) (use typed-records (prefix dbi dbi:)) +(import (prefix mtargs args:)) ;; given a configdat lookup the connection info and open the db ;; (define (pgdb:open configdat #!key (dbname #f)(dbispec #f)) (let ((pgconf (or dbispec Index: db.scm ================================================================== --- db.scm +++ db.scm @@ -1580,17 +1580,17 @@ ;; ;; NOTE: This DOESN'T (necessarily) get the real run ids, but the number of the .db!! (define (db:get-changed-run-ids since-time) (let* ((dbdir (db:dbfile-path)) ;; (configf:lookup *configdat* "setup" "dbdir")) - (alldbs (glob (conc dbdir "/.mtdb/[0-9]*.db*"))) + (alldbs (glob (conc *toppath* "/.mtdb/[0-9]*.db*"))) (changed (filter (lambda (dbfile) (> (file-modification-time dbfile) since-time)) alldbs))) (delete-duplicates (map (lambda (dbfile) - (let* ((res (string-match ".*\\/(\\d\\d)\\.db*" dbfile))) + (let* ((res (string-match ".*\\/(\\d+)\\.db*" dbfile))) (if res (string->number (cadr res)) (begin (debug:print 2 *default-log-port* "WARNING: Failed to process " dbfile " for run-id") 0)))) @@ -4012,11 +4012,11 @@ (delete-duplicates result))))) ;;====================================================================== ;; To sync individual run ;;====================================================================== -(define (db:get-run-record-ids dbstruct target run keynames test-patt) +(define (db:get-run-record-ids dbstruct target run keynames) (let* ((backcons (lambda (lst item)(cons item lst))) (all_tests '()) (keystr (string-intersperse (map (lambda (key val) (conc key " like '" val "'")) @@ -4023,39 +4023,19 @@ keynames (string-split target "/")) " AND ") ) (run-qry (conc "SELECT id FROM runs WHERE " keystr " and runname='" run"'")) - (test-qry (conc "SELECT id FROM tests WHERE run_id in (" run-qry ") and testname like '" test-patt "'")) + ; (test-qry (conc "SELECT id FROM tests WHERE run_id in (" run-qry ") and testname like '" test-patt "'")) (run_ids (db:with-db dbstruct #f #f (lambda (dbdat db) (sqlite3:fold-row backcons '() db run-qry)) ) ) - ) - (for-each - (lambda (run_id) - (set! all_tests - (append - (map (lambda (x) (cons x run_id)) - (db:with-db dbstruct run_id #f - (lambda (dbdat db) - (sqlite3:fold-row backcons '() db (conc "SELECT id FROM tests WHERE run_id in (" run_id ") and testname like '" test-patt "'")) - ) - ) - ) all_tests - ) - ) - ) - run_ids - ) - `((runs . ,run_ids) - (tests . ,all_tests) - ) - - ) + ) + run_ids) ) ;;====================================================================== ;; Just for sync, procedures to make sync easy ;;====================================================================== @@ -4117,10 +4097,38 @@ (tests . ,all_tests) ) ) ) + + +(define (db:get-changed-record-test-ids dbstruct since-time run-id) + (let* ((backcons (lambda (lst item)(cons item lst))) + (all-tests (db:with-db dbstruct run-id #f + (lambda (dbdat db) + (sqlite3:fold-row backcons '() db "SELECT id FROM tests WHERE run_id=? and last_update>=?" run-id since-time))))) + + all-tests)) + +(define (db:get-changed-record-run-ids dbstruct since-time) + ;; no transaction, allow the db to be accessed between the big queries + (let* ((backcons (lambda (lst item)(cons item lst))) + (run_ids (db:with-db dbstruct #f #f + (lambda (dbdat db) + (sqlite3:fold-row backcons '() db "SELECT id FROM runs WHERE last_update>=?" since-time))))) + (debug:print 2 *default-log-port* "run_ids = " run_ids) + run_ids) +) + +(define (db:get-all-runids dbstruct) + (let* ((backcons (lambda (lst item)(cons item lst))) + (all_run_ids (db:with-db dbstruct #f #f + (lambda (dbdat db) + (sqlite3:fold-row backcons '() db "SELECT id FROM runs"))))) + +all_run_ids)) + ;;====================================================================== ;; Extract ods file from the db ;;====================================================================== ;; NOT REWRITTEN YET!!!!! Index: rmt.scm ================================================================== --- rmt.scm +++ rmt.scm @@ -250,15 +250,26 @@ ;; NOT COMPLETED (define (rmt:runtests user run-id testpatt params) (rmt:send-receive 'runtests run-id testpatt)) -(define (rmt:get-run-record-ids target run keynames test-patt) - (rmt:send-receive 'get-run-record-ids #f (list target run keynames test-patt))) +(define (rmt:get-run-record-ids target run keynames ) + (rmt:send-receive 'get-run-record-ids #f (list target run keynames ))) (define (rmt:get-changed-record-ids since-time) (rmt:send-receive 'get-changed-record-ids #f (list since-time)) ) + +(define (rmt:get-all-runids) + (rmt:send-receive 'get-all-run-ids #f '()) ) + +(define (rmt:get-changed-record-run-ids since-time) + (rmt:send-receive 'get-changed-record-run-ids #f (list since-time))) + +(define (rmt:get-changed-record-test-ids run-id since-time) + (rmt:send-receive 'get-changed-record-test-ids run-id (list since-time run-id))) + + (define (rmt:drop-all-triggers) (rmt:send-receive 'drop-all-triggers #f '())) (define (rmt:create-all-triggers) @@ -411,10 +422,12 @@ (let ((run-ids (rmt:get-run-ids-matching-target keynames target res runname testpatt statepatt statuspatt))) (apply append (map (lambda (run-id) (rmt:send-receive 'test-get-paths-matching-keynames-target-new run-id (list run-id keynames target res testpatt statepatt statuspatt runname))) run-ids)))) + + (define (rmt:get-prereqs-not-met run-id waitons ref-test-name ref-item-path #!key (mode '(normal))(itemmaps #f)) (assert (number? run-id) "FATAL: Run id required.") (rmt:send-receive 'get-prereqs-not-met run-id (list run-id waitons ref-test-name ref-item-path mode itemmaps))) Index: tasks.scm ================================================================== --- tasks.scm +++ tasks.scm @@ -769,11 +769,11 @@ (hash-table-set! smallest-last-update-time "smallest-time" last-update))) (pgdb:refresh-run-info dbh new-run-id state status owner event-time comment fail-count pass-count area-id last-update publish-time) - (debug:print-info 4 *default-log-port* "Working on run-id " run-id " pgdb-id " new-run-id ) + (debug:print-info 4 *default-log-port* (conc "Working on run-id " run-id " pgdb-id " new-run-id)) (if (not (equal? run-tag "")) (task:add-run-tag dbh new-run-id run-tag)) new-run-id) (if (or (not state) (equal? state "deleted")) @@ -927,17 +927,17 @@ (debug:print-info 1 *default-log-port* "Error: Could not get test data info for data id " test-data-id )))) ;; this is a wierd senario need to debug test-data-ids))) -(define (tasks:sync-tests-data dbh cached-info test-ids area-info smallest-last-update-time) +(define (tasks:sync-tests-data dbh cached-info test-ids area-info smallest-last-update-time main-run-id) (let ((test-ht (hash-table-ref cached-info 'tests)) - (run-id-in #f)) + (run-id-in main-run-id)) (for-each (lambda (test-id) - (set! run-id-in (cdr test-id)) - (set! test-id (car test-id)) + ; (set! run-id-in (cdr test-id)) + ; (set! test-id (car test-id)) (debug:print 0 *default-log-port* "test-id: " test-id " run-id: " run-id-in) (let* ((test-info (rmt:get-test-info-by-id run-id-in test-id)) (run-id (db:test-get-run_id test-info)) ;; look these up in db_records.scm (test-id (db:test-get-id test-info)) @@ -1014,11 +1014,10 @@ (lambda (run-id) (debug:print-info 4 *default-log-port* "Check if run with " run-id " needs to be synced" ) (tasks:run-id->mtpg-run-id dbh cached-info run-id area-info smallest-last-update-time)) run-ids)) - ;; get runs changed since last sync ;; (define (tasks:sync-test-data dbh cached-info area-info) ;; (let* (( (define (tasks:sync-to-postgres configdat dest) @@ -1049,39 +1048,43 @@ (for-each (lambda (dtype) (hash-table-set! cached-info dtype (make-hash-table))) '(runs targets tests steps data)) (hash-table-set! cached-info 'start start) ;; when done we'll set sync times to this (if area-info - (let* ((last-sync-time (if (args:get-arg "-since") (string->number (args:get-arg "-since")) (vector-ref area-info 3))) + (let* ((last-sync-time (if (and target run-name) + 0 + (if (args:get-arg "-since") + (string->number (args:get-arg "-since")) (vector-ref area-info 3)))) (smallest-last-update-time (make-hash-table)) - (changed (if (and target run-name) - (rmt:get-run-record-ids target run-name (rmt:get-keys) test-patt) - (rmt:get-changed-record-ids last-sync-time))) - (run-ids (alist-ref 'runs changed)) - (test-ids (alist-ref 'tests changed)) + (run-ids (if (and target run-name) + (rmt:get-run-record-ids target run-name (rmt:get-keys)) + (rmt:get-changed-record-run-ids last-sync-time))) + (all-run-ids (if (and target run-name) '() (rmt:get-all-runids))) + (changed-run-dbs (if (and target run-name) '() (db:get-changed-run-ids last-sync-time))) + (changed-run-ids (if (and target run-name) run-ids (filter (lambda (run) (member (modulo run 100) changed-run-dbs)) all-run-ids))) (area-tag (if (args:get-arg "-area-tag") (args:get-arg "-area-tag") (if (args:get-arg "-area") (args:get-arg "-area") "")))) (if (and (equal? area-tag "") (not (pgdb:is-area-taged dbh (vector-ref area-info 0)))) (set! area-tag *default-area-tag*)) (if (not (equal? area-tag "")) - (task:add-area-tag dbh area-info area-tag)) - (if (not (null? run-ids)) + (task:add-area-tag dbh area-info area-tag)) + (if (not (null? run-ids)) (begin (debug:print-info 0 *default-log-port* "syncing runs: " run-ids) - (tasks:sync-run-data dbh cached-info run-ids area-info smallest-last-update-time) - ) - ) - (if (not (null? test-ids)) - (begin - (debug:print-info 0 *default-log-port* "syncing tests: " test-ids) - (tasks:sync-tests-data dbh cached-info test-ids area-info smallest-last-update-time) - (debug:print-info 0 *default-log-port* "syncing test steps") - ) - ) + (tasks:sync-run-data dbh cached-info run-ids area-info smallest-last-update-time))) + (for-each + (lambda (run-id) + (let ((test-ids (rmt:get-changed-record-test-ids run-id last-sync-time))) + (print test-ids) + (if (not (null? test-ids)) + (begin + (debug:print-info 0 *default-log-port* "syncing tests: " test-ids) + (tasks:sync-tests-data dbh cached-info test-ids area-info smallest-last-update-time run-id))))) + changed-run-ids) (let* ((smallest-time (hash-table-ref/default smallest-last-update-time "smallest-time" (current-seconds)))) (debug:print-info 0 "smallest-time :" smallest-time " last-sync-time " last-sync-time) (if (not (and target run-name)) (if (or (and smallest-time (> smallest-time last-sync-time)) (and smallest-time (eq? last-sync-time 0))) (pgdb:write-sync-time dbh area-info smallest-time))))) ;;this needs to be changed Index: tcp-transportmod.scm ================================================================== --- tcp-transportmod.scm +++ tcp-transportmod.scm @@ -257,12 +257,12 @@ (if (not res) ;; tt:handler is telling us that communication failed (let* ((host (tt-conn-host conn)) (port (tt-conn-port conn)) ;; (dbfname (tt-conn-port conn)) ;; 192.168.0.127:4242-726924:4.db (pid (tt-conn-pid conn)) - (servinf (tt-conn-servinf-file conn))) - ;;(servinf (tt-servinf-file ttdat))) ;; (conc areapath"/.servinfo/"host":"port"-"pid":"dbfname))) ;; TODO, use (server:get-servinfo-dir areapath) + ;;(servinf (tt-conn-servinf-file conn))) + (servinf (tt-servinf-file ttdat))) ;; (conc areapath"/.servinfo/"host":"port"-"pid":"dbfname))) ;; TODO, use (server:get-servinfo-dir areapath) (hash-table-set! (tt-conns ttdat) dbfname #f) (if (and servinf (file-exists? servinf)) (begin (if (< attemptnum 10) (begin