Index: db.scm ================================================================== --- db.scm +++ db.scm @@ -3968,17 +3968,133 @@ ;; (db:set-state-status-and-roll-up-items dbstruct run-id test-id #f state status msg) ;; ;; process the test_data table ;; (if (and test-id state status (equal? status "AUTO")) ;; (db:test-data-rollup dbstruct run-id test-id status)) ;; (mt:process-triggers dbstruct run-id test-id state status))) + +;; NOT FINISHED +(define (db:calc-state-status-toplevel state status tl-state tl-status) + `(,state ,status)) + +;; (match state +;; (("COMPLETED") +;; (match `(,tl-state ,tl-status) +;; (("COMPLETED" "PASS") `(,state ,status)) +;; (("COMPLETED" thestatus) +;; (case (string->symbol thestatus) +;; ((ABORT CHECK DEAD) +;; (if `("COMPLETED" ,thestatus)) +;; (match `(,thestatus ,status) +;; (("FAIL" "ABORT") '("COMPLETED" "ABORT")) +;; (("FAIL" "CHECK") '("COMPLETED" "CHECK")) +;; (("FAIL" "DEAD") '("COMPLETED" "DEAD")) +;; (("WARN" "FAIL") '("COMPLETED" "FAIL")) +;; (("WARN" "CHECK") '("COMPLETED" "CHECK")) +;; (("WARN" "DEAD") + +(define (db:set-state-status-and-roll-up-items dbstruct run-id test-name item-path state status comment) + ;; establish info on incoming test followed by info on top level test + ;; BBnote - for mode itemwait, linkage between upstream test & matching item status is propagated to run queue in db:prereqs-not-met + ;; (mutex-lock! *db-transaction-mutex*) ;; why do we need a mutex? + (let* ((testdat (if (number? test-name) + (db:get-test-info-by-id dbstruct run-id test-name) ;; test-name is actually a test-id + (db:get-test-info dbstruct run-id test-name item-path))) + (test-id (db:test-get-id testdat)) + (test-name (if (number? test-name) + (db:test-get-testname testdat) + test-name)) + (no-sync-db (db:no-sync-db #f)) + (rollup-flag #f) + (wait-flag #f) + (rollup-lock-key (conc run-id "-rollup-" test-name)) + (waiting-lock-key (conc run-id "-waiting-" test-name))) + (db:test-set-state-status dbstruct run-id test-id state status #f) + (if (and test-id state status (equal? status "AUTO")) + (db:test-data-rollup dbstruct run-id test-id status)) + (if (member state '("LAUNCHED" "REMOTEHOSTSTART")) + (db:general-call dbstruct 'set-test-start-time (list test-id))) + + (if (not (equal? item-path "")) ;; only roll up IF incoming test is an item + (begin + ;; is there a rollup lock? If not, take it + (sqlite3:with-transaction + no-sync-db + (lambda () + ;; (debug:print 0 *default-log-port* "EXCEPTION: exn="exn) + (let* ((rollup-lock-time (db:no-sync-get/default no-sync-db rollup-lock-key #f)) + (waiting-lock-time (db:no-sync-get/default no-sync-db waiting-lock-key #f))) + (if rollup-lock-time ;; someone is doing a rollup + (if (not waiting-lock-time) ;; no one is waiting + (begin + (set! wait-flag #t) + (set! rollup-flag #t) + (db:no-sync-set no-sync-db waiting-lock-key (current-seconds)))) ;; we are going to wait + (begin + (set! rollup-flag #t) + (db:no-sync-set no-sync-db rollup-lock-key (current-seconds))))))) + (if wait-flag + (let loop ((count 10)) ;; about 20 seconds + (thread-sleep! 2) + (if (and (not (db:no-sync-get/default no-sync-db waiting-lock-key #f)) + (> count 0)) + (loop (+ count 1)) + (sqlite3:with-transaction + no-sync-db + (lambda () + (db:no-sync-set no-sync-db rollup-lock-key (current-seconds)) + (db:no-sync-del! no-sync-db waiting-lock-key)))))) + ;; now the rollup + (if rollup-flag ;; put this into a thread + (begin + ;; (thread-start! (make-thread + ;; (lambda () + (db:roll-up-test-state-status dbstruct run-id test-name state status) + (db:no-sync-del! no-sync-db rollup-lock-key)) + ;; (conc "thread for run-id: " run-id " test-name: " test-name)))))))) + ))))) + +;; I'd like to remove the need for item-path - it is logically not needed here +;; for now we pass in state and status - NOTE: There is a possible race if a test +;; is rapidly re-run while an earlier run is waiting to rollup. +;; +(define (db:roll-up-test-state-status dbstruct run-id test-name state status) + (let* ((testdat (if (number? test-name) + (db:get-test-info-by-id dbstruct run-id test-name) ;; test-name is actually a test-id + (db:get-test-info dbstruct run-id test-name ""))) + (test-id (db:test-get-id testdat)) + (test-name (if (number? test-name) + (db:test-get-testname testdat) + test-name)) + (tl-testdat (db:get-test-info dbstruct run-id test-name "")) + (tl-test-id (db:test-get-id tl-testdat))) + (db:with-db + dbstruct #f #f + (lambda (db) + ;; NB// Pass the db so it is part fo the transaction + ;; item-path is used in get-all-state-status counts to exclude current state/status of THIS test + ;; but with the state/status being set earlier this is not needed any longer + (let* ((state-status-counts (db:get-all-state-status-counts-for-testname dbstruct run-id test-name)) + (state-statuses (if (null? state-status-counts) + '() + (db:roll-up-rules state-status-counts state status))) + (newstate (if (null? state-statuses) + state + (car state-statuses))) + (newstatus (if (null? state-statuses) + status + (cadr state-statuses)))) + (if tl-test-id + (db:test-set-state-status db run-id tl-test-id newstate newstatus #f)) + ))) + #t)) ;; state is the priority rollup of all states ;; status is the priority rollup of all completed statesfu ;; ;; if test-name is an integer work off that instead of test-name test-path ;; -(define (db:set-state-status-and-roll-up-items dbstruct run-id test-name item-path state status comment) +(define (db:set-state-status-and-roll-up-items-orig dbstruct run-id test-name item-path state status comment) ;; establish info on incoming test followed by info on top level test ;; BBnote - for mode itemwait, linkage between upstream test & matching item status is propagated to run queue in db:prereqs-not-met (let* ((testdat (if (number? test-name) (db:get-test-info-by-id dbstruct run-id test-name) ;; test-name is actually a test-id (db:get-test-info dbstruct run-id test-name item-path))) @@ -3999,17 +4115,17 @@ (lambda (db) (let ((tr-res (sqlite3:with-transaction db (lambda () - ;; NB// Pass the db so it is part fo the transaction + ;; NB// Pass the db so it is part of the transaction (db:test-set-state-status db run-id test-id state status comment) ;; this call sets the item state/status (if (not (equal? item-path "")) ;; only roll up IF incoming test is an item (let* ((state-status-counts (db:get-all-state-status-counts-for-test dbstruct run-id test-name item-path state status)) ;; item-path is used to exclude current state/status of THIS test - (state-stauses (db:roll-up-rules state-status-counts state status)) - (newstate (car state-stauses)) - (newstatus (cadr state-stauses))) + (state-statuses (db:roll-up-rules state-status-counts state status)) + (newstate (car state-statuses)) + (newstatus (cadr state-statuses))) (debug:print 4 *default-log-port* "BB> tl-test-id="tl-test-id" ; "test-name":"item-path" newstate="newstate" newstatus="newstatus" len(sscs)="(length state-status-counts) " state-status-counts: " (apply conc (map (lambda (x) (conc (with-output-to-string (lambda () (pp (dbr:counts->alist x)))) " | ")) @@ -4022,81 +4138,84 @@ (if (and test-id state status (equal? status "AUTO")) (db:test-data-rollup dbstruct run-id test-id status)) tr-res))))) (define (db:roll-up-rules state-status-counts state status) - (let* ((running (length (filter (lambda (x) - (member (dbr:counts-state x) *common:running-states*)) - state-status-counts))) - (bad-not-started (length (filter (lambda (x) - (and (equal? (dbr:counts-state x) "NOT_STARTED") - (not (member (dbr:counts-status x) *common:not-started-ok-statuses*)))) - state-status-counts))) - (all-curr-states (common:special-sort ;; worst -> best (sort of) - (delete-duplicates - (if (and state (not (member state *common:dont-roll-up-states*))) - (cons state (map dbr:counts-state state-status-counts)) - (map dbr:counts-state state-status-counts))) - *common:std-states* >)) - (all-curr-statuses (common:special-sort ;; worst -> best - (delete-duplicates - (if (and state status (not (member state *common:dont-roll-up-states*))) - (cons status (map dbr:counts-status state-status-counts)) - (map dbr:counts-status state-status-counts))) - *common:std-statuses* >)) - (non-completes (filter (lambda (x) - (not (member x (cons "COMPLETED" *common:dont-roll-up-states*)))) - all-curr-states)) - (preq-fails (filter (lambda (x) - (equal? x "PREQ_FAIL")) - all-curr-statuses)) - (num-non-completes (length non-completes)) - (newstate (cond - ((> running 0) "RUNNING") ;; anything running, call the situation running - ((> (length preq-fails) 0) "NOT_STARTED") - ((> bad-not-started 0) "COMPLETED") ;; we have an ugly situation, it is completed in the sense we cannot do more. - ((> num-non-completes 0) (car non-completes)) ;; (remove (lambda (x)(equal? "COMPLETED" x)) all-curr-states))) ;; only rollup DELETED if all DELETED - (else (car all-curr-states)))) - (newstatus (cond - ((> (length preq-fails) 0) "PREQ_FAIL") - ((or (> bad-not-started 0) - (and (equal? newstate "NOT_STARTED") - (> num-non-completes 0))) - "STARTED") - (else (car all-curr-statuses))))) - (debug:print-info 2 *default-log-port* - "\n--> probe db:set-state-status-and-roll-up-items: " - "\n--> state-status-counts: "(map dbr:counts->alist state-status-counts) - "\n--> running: "running - "\n--> bad-not-started: "bad-not-started - "\n--> non-non-completes: "num-non-completes - "\n--> non-completes: "non-completes - "\n--> all-curr-states: "all-curr-states + (let* ((running (length (filter (lambda (x) + (member (dbr:counts-state x) *common:running-states*)) + state-status-counts))) + (bad-not-started (length (filter (lambda (x) + (and (equal? (dbr:counts-state x) "NOT_STARTED") + (not (member (dbr:counts-status x) *common:not-started-ok-statuses*)))) + state-status-counts))) + (all-curr-states (common:special-sort ;; worst -> best (sort of) + (delete-duplicates + (if (and state (not (member state *common:dont-roll-up-states*))) + (cons state (map dbr:counts-state state-status-counts)) + (map dbr:counts-state state-status-counts))) + *common:std-states* >)) + (all-curr-statuses (common:special-sort ;; worst -> best + (delete-duplicates + (if (and state status (not (member state *common:dont-roll-up-states*))) + (cons status (map dbr:counts-status state-status-counts)) + (map dbr:counts-status state-status-counts))) + *common:std-statuses* >)) + (non-completes (filter (lambda (x) + (not (member x (cons "COMPLETED" *common:dont-roll-up-states*)))) + all-curr-states)) + (preq-fails (filter (lambda (x) + (equal? x "PREQ_FAIL")) + all-curr-statuses)) + (num-non-completes (length non-completes)) + (newstate (cond + ((> running 0) "RUNNING") ;; anything running, call the situation running + ((> (length preq-fails) 0) "NOT_STARTED") + ((> bad-not-started 0) "COMPLETED") ;; we have an ugly situation, it is completed in the sense we cannot do more. + ((> num-non-completes 0) (car non-completes)) ;; (remove (lambda (x)(equal? "COMPLETED" x)) all-curr-states))) ;; only rollup DELETED if all DELETED + (else (car all-curr-states)))) + (newstatus (cond + ((> (length preq-fails) 0) "PREQ_FAIL") + ((or (> bad-not-started 0) + (and (equal? newstate "NOT_STARTED") + (> num-non-completes 0))) + "STARTED") + (else (car all-curr-statuses))))) + (debug:print-info 2 *default-log-port* + "\n--> probe db:set-state-status-and-roll-up-items: " + "\n--> state-status-counts: "(map dbr:counts->alist state-status-counts) + "\n--> running: "running + "\n--> bad-not-started: "bad-not-started + "\n--> non-non-completes: "num-non-completes + "\n--> non-completes: "non-completes + "\n--> all-curr-states: "all-curr-states "\n--> all-curr-statuses: "all-curr-statuses "\n--> newstate "newstate "\n--> newstatus "newstatus "\n\n") - - ;; NB// Pass the db so it is part of the transaction - (list newstate newstatus))) + ;; NB// Pass the db so it is part of the transaction + (list newstate newstatus))) (define (db:set-state-status-and-roll-up-run dbstruct run-id curr-state curr-status) - (mutex-lock! *db-transaction-mutex*) + ;; (mutex-lock! *db-transaction-mutex*) (db:with-db dbstruct #f #f (lambda (db) (let ((tr-res (sqlite3:with-transaction db (lambda () (let* ((state-status-counts (db:get-all-state-status-counts-for-run dbstruct run-id)) - (state-stauses (db:roll-up-rules state-status-counts #f #f )) - (newstate (car state-stauses)) - (newstatus (cadr state-stauses))) + (state-statuses (db:roll-up-rules state-status-counts #f #f )) + (newstate (if (null? state-statuses) + curr-state + (car state-statuses))) + (newstatus (if (null? state-statuses) + curr-status + (cadr state-statuses)))) (if (or (not (eq? newstate curr-state)) (not (eq? newstatus curr-status))) (db:set-run-state-status dbstruct run-id newstate newstatus ))))))) - (mutex-unlock! *db-transaction-mutex*) + ;; (mutex-unlock! *db-transaction-mutex*) tr-res)))) (define (db:get-all-state-status-counts-for-run dbstruct run-id) (let* ((test-count-recs (db:with-db @@ -4148,10 +4267,25 @@ (unrelated-rec-list (filter nonmatch-countrec-lambda other-items-count-recs))) (cons updated-count-rec unrelated-rec-list))) + +;; full count not including toplevel +;; +(define (db:get-all-state-status-counts-for-testname dbstruct run-id test-name) + (let* ((test-count-recs (db:with-db + dbstruct #f #f + (lambda (db) + (sqlite3:map-row + (lambda (state status count) + (make-dbr:counts state: state status: status count: count)) + db + "SELECT state,status,count(id) FROM tests WHERE run_id=? AND testname=? AND item_path != '' GROUP BY state,status;" + run-id test-name))))) + test-count-recs)) + ;; (define (db:get-all-item-states db run-id test-name) ;; (sqlite3:map-row ;; (lambda (a) a) ;; db