Overview
| Comment: | use old rollup technique |
|---|---|
| Downloads: | Tarball | ZIP archive | SQL archive |
| Timelines: | family | ancestors | descendants | both | v1.65-diet2 |
| Files: | files | file ages | folders |
| SHA1: |
195f4a1733d50ea9e6e755336c8d51dd |
| User & Date: | matt on 2021-01-24 12:11:54 |
| Other Links: | branch diff | manifest | tags |
Context
|
2021-01-24
| ||
| 15:38 | Merged in latest check-in: 14db3c2571 user: matt tags: v1.65-diet2 | |
| 12:11 | use old rollup technique check-in: 195f4a1733 user: matt tags: v1.65-diet2 | |
|
2021-01-21
| ||
| 23:10 | Sketched out possible speed up with short-circuit rollup of items check-in: 9809735c40 user: matt tags: v1.65-diet2 | |
Changes
Modified db.scm from [da93031ee4] to [fce7914eb2].
| ︙ | ︙ | |||
3987 3988 3989 3990 3991 3992 3993 |
;; (("FAIL" "ABORT") '("COMPLETED" "ABORT"))
;; (("FAIL" "CHECK") '("COMPLETED" "CHECK"))
;; (("FAIL" "DEAD") '("COMPLETED" "DEAD"))
;; (("WARN" "FAIL") '("COMPLETED" "FAIL"))
;; (("WARN" "CHECK") '("COMPLETED" "CHECK"))
;; (("WARN" "DEAD")
| < | | < < < < < < < | | | | | | | | > > > > | | | < | | | > | > > > > > > > > > > > > > > > | > > > > > | < > > > > | > > > | > > | > > > > > > > > | > | > > > > > > > > > > | > | > > | > > | < < < < < | | | | 3987 3988 3989 3990 3991 3992 3993 3994 3995 3996 3997 3998 3999 4000 4001 4002 4003 4004 4005 4006 4007 4008 4009 4010 4011 4012 4013 4014 4015 4016 4017 4018 4019 4020 4021 4022 4023 4024 4025 4026 4027 4028 4029 4030 4031 4032 4033 4034 4035 4036 4037 4038 4039 4040 4041 4042 4043 4044 4045 4046 4047 4048 4049 4050 4051 4052 4053 4054 4055 4056 4057 4058 4059 4060 4061 4062 4063 4064 4065 4066 4067 4068 4069 4070 4071 4072 4073 4074 4075 4076 4077 4078 4079 4080 4081 4082 4083 4084 4085 4086 4087 4088 4089 4090 4091 4092 4093 4094 4095 4096 4097 |
;; (("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 ()
(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 100))
(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
(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-flag))
(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 (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-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)))
(test-id (db:test-get-id testdat))
(test-name (if (number? test-name)
|
| ︙ | ︙ | |||
4065 4066 4067 4068 4069 4070 4071 |
(db:with-db
dbstruct #f #f
(lambda (db)
(let ((tr-res
(sqlite3:with-transaction
db
(lambda ()
| | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | < | | | | > > | > > | | | 4108 4109 4110 4111 4112 4113 4114 4115 4116 4117 4118 4119 4120 4121 4122 4123 4124 4125 4126 4127 4128 4129 4130 4131 4132 4133 4134 4135 4136 4137 4138 4139 4140 4141 4142 4143 4144 4145 4146 4147 4148 4149 4150 4151 4152 4153 4154 4155 4156 4157 4158 4159 4160 4161 4162 4163 4164 4165 4166 4167 4168 4169 4170 4171 4172 4173 4174 4175 4176 4177 4178 4179 4180 4181 4182 4183 4184 4185 4186 4187 4188 4189 4190 4191 4192 4193 4194 4195 4196 4197 4198 4199 4200 4201 4202 4203 4204 4205 4206 4207 4208 4209 4210 4211 4212 4213 4214 4215 4216 4217 4218 |
(db:with-db
dbstruct #f #f
(lambda (db)
(let ((tr-res
(sqlite3:with-transaction
db
(lambda ()
;; 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-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)))) " | "))
state-status-counts))); end debug:print
(if tl-test-id
(db:test-set-state-status db run-id tl-test-id newstate newstatus #f)) ;; we are still in the transaction - must access the db and not the dbstruct
))))))
(mutex-unlock! *db-transaction-mutex*)
(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
"\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)))
(define (db:set-state-status-and-roll-up-run dbstruct run-id curr-state curr-status)
;; (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-statuses (db:roll-up-rules state-status-counts #f #f ))
(newstate (if (null? state-statuses)
curr-state
(car state-statuses)))
(newstatus (if (null? state-status)
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*)
tr-res))))
(define (db:get-all-state-status-counts-for-run dbstruct run-id)
(let* ((test-count-recs (db:with-db
dbstruct #f #f
(lambda (db)
|
| ︙ | ︙ | |||
4214 4215 4216 4217 4218 4219 4220 4221 4222 4223 4224 4225 4226 4227 |
(nonmatch-countrec-lambda (lambda (countrec) (not (match-countrec-lambda countrec))))
(unrelated-rec-list
(filter nonmatch-countrec-lambda other-items-count-recs)))
(cons updated-count-rec unrelated-rec-list)))
;; (define (db:get-all-item-states db run-id test-name)
;; (sqlite3:map-row
;; (lambda (a) a)
;; db
;; "SELECT DISTINCT state FROM tests WHERE item_path != '' AND state != 'DELETED' AND run_id=? AND testname=?"
;; run-id test-name))
| > > > > > > > > > > > > > > > | 4260 4261 4262 4263 4264 4265 4266 4267 4268 4269 4270 4271 4272 4273 4274 4275 4276 4277 4278 4279 4280 4281 4282 4283 4284 4285 4286 4287 4288 |
(nonmatch-countrec-lambda (lambda (countrec) (not (match-countrec-lambda countrec))))
(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
;; "SELECT DISTINCT state FROM tests WHERE item_path != '' AND state != 'DELETED' AND run_id=? AND testname=?"
;; run-id test-name))
|
| ︙ | ︙ |