Megatest

Check-in [996c305353]
Login
☰Home Timeline Files Branches Tags Tickets Wiki Login
Overview
Comment:wip, clean up
Downloads: Tarball | ZIP archive | SQL archive
Timelines: family | ancestors | descendants | both | v1.80-servload
Files: files | file ages | folders
SHA1: 996c30535341bb863229b1eabd8f4e8038a5a3ae
User & Date: matt on 2023-04-19 09:58:35
Other Links: branch diff | manifest | tags
Context
2023-04-21
02:53
Fixed fallout from moving mt:process-triggers to client side check-in: 94afafb2e7 user: matt tags: v1.80-servload
2023-04-19
09:58
wip, clean up check-in: 996c305353 user: matt tags: v1.80-servload
2023-04-18
20:52
wip check-in: 4c125c180a user: matt tags: v1.80-servload
Changes
Hide Diffs Unified Diffs Ignore Whitespace Patch

Modified api.scm from [9008afe383] to [befb5033e9].

︙︙
395
396
397
398
399
400
401

402
403
404
405
406
407
408

    ((test-toplevel-num-items)         (apply db:test-toplevel-num-items dbstruct params))
    ((get-test-info-by-id)	       (apply db:get-test-info-by-id dbstruct params))
    ((get-test-state-status-by-id)     (apply db:get-test-state-status-by-id dbstruct params))
    ((test-get-rundir-from-test-id)    (apply db:test-get-rundir-from-test-id dbstruct params))
    ((get-count-tests-running-for-testname) (apply db:get-count-tests-running-for-testname dbstruct params))
    ((get-count-tests-running)         (apply db:get-count-tests-running dbstruct params))
    ((get-count-tests-running-in-jobgroup) (apply db:get-count-tests-running-in-jobgroup dbstruct params))

    ;; ((delete-test-step-records)        (apply db:delete-test-step-records dbstruct params))
    ;; ((get-previous-test-run-record)    (apply db:get-previous-test-run-record dbstruct params))
    ((get-matching-previous-test-run-records)(apply db:get-matching-previous-test-run-records dbstruct params))
    ((test-get-logfile-info)           (apply db:test-get-logfile-info dbstruct params))
    ((test-get-records-for-index-file)  (apply db:test-get-records-for-index-file dbstruct params))
    ((get-testinfo-state-status)       (apply db:get-testinfo-state-status dbstruct params))
    ((test-get-top-process-pid)        (apply db:test-get-top-process-pid dbstruct params))








>








395
396
397
398
399
400
401
402
403
404
405
406
407
408
409

    ((test-toplevel-num-items)         (apply db:test-toplevel-num-items dbstruct params))
    ((get-test-info-by-id)	       (apply db:get-test-info-by-id dbstruct params))
    ((get-test-state-status-by-id)     (apply db:get-test-state-status-by-id dbstruct params))
    ((test-get-rundir-from-test-id)    (apply db:test-get-rundir-from-test-id dbstruct params))
    ((get-count-tests-running-for-testname) (apply db:get-count-tests-running-for-testname dbstruct params))
    ((get-count-tests-running)         (apply db:get-count-tests-running dbstruct params))
    ((get-count-tests-running-in-jobgroup) (apply db:get-count-tests-running-in-jobgroup dbstruct params))
    ((get-all-state-status-counts-for-test) (apply db:get-all-state-status-counts-for-test dbstruct params))
    ;; ((delete-test-step-records)        (apply db:delete-test-step-records dbstruct params))
    ;; ((get-previous-test-run-record)    (apply db:get-previous-test-run-record dbstruct params))
    ((get-matching-previous-test-run-records)(apply db:get-matching-previous-test-run-records dbstruct params))
    ((test-get-logfile-info)           (apply db:test-get-logfile-info dbstruct params))
    ((test-get-records-for-index-file)  (apply db:test-get-records-for-index-file dbstruct params))
    ((get-testinfo-state-status)       (apply db:get-testinfo-state-status dbstruct params))
    ((test-get-top-process-pid)        (apply db:test-get-top-process-pid dbstruct params))
︙︙

Modified common.scm from [ec316c51cd] to [708849cceb].

︙︙
168
169
170
171
172
173
174
175
176
177
178
179
180
181
182

;; (define *db-last-sync*        0)                 ;; last time the sync to megatest.db happened
(define *db-sync-in-progress* #f)                ;; if there is a sync in progress do not try to start another
;; (define *db-multi-sync-mutex* (make-mutex))      ;; protect access to *db-sync-in-progress*, *db-last-sync*
;; task db
(define *task-db*             #f) ;; (vector db path-to-db)
(define *db-access-allowed*   #t) ;; flag to allow access
;; (define *db-access-mutex*     (make-mutex)) ;; moved to dbfile
;; (define *db-transaction-mutex* (make-mutex))
(define *db-cache-path*       #f)
;; (define *db-with-db-mutex*    (make-mutex))
(define *db-api-call-time*    (make-hash-table)) ;; hash of command => (list of times)

;; SERVER
(define *transport-type*    'http)             ;; override with [server] transport http|rpc|nmsg
(define *runremote*         #f)                ;; if set up for server communication this will hold <host port>








<








168
169
170
171
172
173
174

175
176
177
178
179
180
181

;; (define *db-last-sync*        0)                 ;; last time the sync to megatest.db happened
(define *db-sync-in-progress* #f)                ;; if there is a sync in progress do not try to start another
;; (define *db-multi-sync-mutex* (make-mutex))      ;; protect access to *db-sync-in-progress*, *db-last-sync*
;; task db
(define *task-db*             #f) ;; (vector db path-to-db)
(define *db-access-allowed*   #t) ;; flag to allow access
;; (define *db-access-mutex*     (make-mutex)) ;; moved to dbfile

(define *db-cache-path*       #f)
;; (define *db-with-db-mutex*    (make-mutex))
(define *db-api-call-time*    (make-hash-table)) ;; hash of command => (list of times)

;; SERVER
(define *transport-type*    'http)             ;; override with [server] transport http|rpc|nmsg
(define *runremote*         #f)                ;; if set up for server communication this will hold <host port>
︙︙

Modified db.scm from [0a63eb3ca2] to [d4a73fb297].

︙︙
2624
2625
2626
2627
2628
2629
2630
2631
2632
2633
2634
2635
2636
2637
2638

		;;                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 last-update)))
	      db
	      ;; (db:get-cache-stmth dbdat db
	      ;; 		    (conc "SELECT " db:test-record-qry-selector " FROM tests WHERE id=? AND run_id=?;"))
	      (conc "SELECT " db:test-record-qry-selector " FROM tests WHERE id=? AND run_id=?;")
	      test-id run-id)
	     (hash-table-set! *db:get-test-info-by-id-cache* hash-key res)
	     res))))))

(define *db:get-test-state-status-by-id-cache* (make-hash-table))

;; Get test state, status using test_id
;; 
(define (db:get-test-state-status-by-id dbstruct run-id test-id)








|








2624
2625
2626
2627
2628
2629
2630
2631
2632
2633
2634
2635
2636
2637
2638

		;;                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 last-update)))
	      db
	      ;; (db:get-cache-stmth dbdat db
	      ;; 		    (conc "SELECT " db:test-record-qry-selector " FROM tests WHERE id=? AND run_id=?;"))
	      (conc "SELECT " db:test-record-qry-selector " FROM tests WHERE id=? AND run_id=?;")
	      test-id run-id)
	     (hash-table-set! *db:get-test-info-by-id-cache* hash-key (cons (current-seconds) res))
	     res))))))

(define *db:get-test-state-status-by-id-cache* (make-hash-table))

;; Get test state, status using test_id
;; 
(define (db:get-test-state-status-by-id dbstruct run-id test-id)
︙︙
3148
3149
3150
3151
3152
3153
3154
3155
3156
3157
3158
3159
3160
3161
3162

       (let ((tr-res
              (sqlite3:with-transaction
               db
               (lambda ()
                 ;; NB// Pass the db so it is part fo the transaction
                 (db:test-set-state-status-db 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 db 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)))
		       (set! new-state-eh newstate)
		       (set! new-status-eh newstatus)
                       (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: "








|








3148
3149
3150
3151
3152
3153
3154
3155
3156
3157
3158
3159
3160
3161
3162

       (let ((tr-res
              (sqlite3:with-transaction
               db
               (lambda ()
                 ;; NB// Pass the db so it is part fo the transaction
                 (db:test-set-state-status-db 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-db db 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)))
		       (set! new-state-eh newstate)
		       (set! new-status-eh newstatus)
                       (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: "
︙︙
3262
3263
3264
3265
3266
3267
3268





3269
3270
3271
3272
3273
3274
3275
3276
3277
3278
3279
3280


(define (db:get-all-state-status-counts-for-run dbstruct run-id)
  (db:with-db
   dbstruct #f #f
   (lambda (dbdat db)
     (db:get-all-state-status-counts-for-run-db dbdat db run-id))))






;; BBnote: db:get-all-state-status-counts-for-test returns dbr:counts object aggregating state and status of items of a given test, *not including rollup state/status*
;;
;; NOTE: This is called within a transaction
;;
(define (db:get-all-state-status-counts-for-test db run-id test-name item-path item-state-in item-status-in)
  (let* ((test-info   (db:get-test-info-db db run-id test-name item-path))
         (item-state  (or item-state-in (db:test-get-state test-info))) 
         (item-status (or item-status-in (db:test-get-status test-info)))
         (other-items-count-recs (sqlite3:map-row
                                  (lambda (state status count)
                                    (make-dbr:counts state: state status: status count: count))
                                  db








>
>
>
>
>
|



|








3262
3263
3264
3265
3266
3267
3268
3269
3270
3271
3272
3273
3274
3275
3276
3277
3278
3279
3280
3281
3282
3283
3284
3285


(define (db:get-all-state-status-counts-for-run dbstruct run-id)
  (db:with-db
   dbstruct #f #f
   (lambda (dbdat db)
     (db:get-all-state-status-counts-for-run-db dbdat db run-id))))

(define (db:get-all-state-status-counts-for-test dbstruct run-id test-name item-path item-state-in item-status-in)
  (db:with-db
   dbstruct run-id #f
   (lambda (dbdat db)
     (db:get-all-state-status-counts-for-test-db db run-id test-name item-path item-state-in item-status-in))))
     ;; BBnote: db:get-all-state-status-counts-for-test returns dbr:counts object aggregating state and status of items of a given test, *not including rollup state/status*
;;
;; NOTE: This is called within a transaction
;;
(define (db:get-all-state-status-counts-for-test-db db run-id test-name item-path item-state-in item-status-in)
  (let* ((test-info   (db:get-test-info-db db run-id test-name item-path))
         (item-state  (or item-state-in (db:test-get-state test-info))) 
         (item-status (or item-status-in (db:test-get-status test-info)))
         (other-items-count-recs (sqlite3:map-row
                                  (lambda (state status count)
                                    (make-dbr:counts state: state status: status count: count))
                                  db
︙︙

Modified mt.scm from [09dd853b7e] to [ef003bd249].

︙︙
301
302
303
304
305
306
307
308
309
310
311
312
313
314
315

316
317
318
319
320
321
322
323
324
325
326
327
328
329
330
331
332
333
334
335
336
337
338
339
340
341
342
343
344
345
346
347
348
349
350

  ;; 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* ((test-id      (if (number? test-name)
			   test-name
			   (db:keep-trying-until-true
			    rmt:get-test-id
			    (list run-id test-name item-path)
			   10)))
			   ;; (rmt:get-test-id run-id test-name item-path)))
	 (testdat      (rmt:get-test-info-by-id run-id test-id))
	 ;; (test-id      (db:test-get-id testdat))
	 (test-name    (if (number? test-name)
			   (db:test-get-testname testdat)
			   test-name))
	 (item-path    (db:test-get-item-path testdat))

         (tl-testdat   (rmt:get-test-info run-id test-name ""))
         (tl-test-id   (if tl-testdat
			   (db:test-get-id tl-testdat)
			   #f))
	 (new-state-eh #f)
	 (new-status-eh #f))
    (if (member state '("LAUNCHED" "REMOTEHOSTSTART")) 
	(rmt:general-call run-id 'set-test-start-time (list test-id)))
    (let* ((res (begin
		  (rmt: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 (rmt:get-all-state-status-counts-for-test 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)))
			(set! new-state-eh newstate)
			(set! new-status-eh newstatus)
			(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
			    (rmt:test-set-state-status 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")) 
	  (rmt:test-data-rollup run-id test-id status))
      (if new-state-eh ;; moved from db:test-set-state-status
	  (mt:process-triggers run-id test-id new-state-eh new-status-eh))
      res)))

;;  select end_time-now from








|







>
|
<
<
<





|

















<








301
302
303
304
305
306
307
308
309
310
311
312
313
314
315
316
317



318
319
320
321
322
323
324
325
326
327
328
329
330
331
332
333
334
335
336
337
338
339
340

341
342
343
344
345
346
347

  ;; 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* ((test-id      (if (number? test-name)
			   test-name
			   (db:keep-trying-until-true
			    rmt:get-test-id
			    (list run-id test-name item-path)
			    10)))
			   ;; (rmt:get-test-id run-id test-name item-path)))
	 (testdat      (rmt:get-test-info-by-id run-id test-id))
	 ;; (test-id      (db:test-get-id testdat))
	 (test-name    (if (number? test-name)
			   (db:test-get-testname testdat)
			   test-name))
	 (item-path    (db:test-get-item-path testdat))
	 (tl-test-id   (rmt:get-test-id run-id test-name ""))
         (tl-testdat   (rmt:get-test-info-by-id run-id test-id))



	 (new-state-eh #f)
	 (new-status-eh #f))
    (if (member state '("LAUNCHED" "REMOTEHOSTSTART")) 
	(rmt:general-call run-id 'set-test-start-time (list test-id)))
    (let* ((res (begin
		  (rmt:test-set-state-status 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 (rmt:get-all-state-status-counts-for-test 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)))
			(set! new-state-eh newstate)
			(set! new-status-eh newstatus)
			(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
			    (rmt:test-set-state-status run-id tl-test-id newstate newstatus #f)) ;; we are still in the transaction - must access the db and not the dbstruct
		       )))))

      (if (and test-id state status (equal? status "AUTO")) 
	  (rmt:test-data-rollup run-id test-id status))
      (if new-state-eh ;; moved from db:test-set-state-status
	  (mt:process-triggers run-id test-id new-state-eh new-status-eh))
      res)))

;;  select end_time-now from
︙︙

Modified rmt.scm from [5890df38f8] to [6a84bd6518].

︙︙
433
434
435
436
437
438
439


440
441
442
443
444
445
446

  (assert (number? run-id) "FATAL: Run id required.")
  (rmt:send-receive 'get-count-tests-running run-id (list run-id)))

(define (rmt:get-count-tests-running-for-testname run-id testname)
  (assert (number? run-id) "FATAL: Run id required.")
  (rmt:send-receive 'get-count-tests-running-for-testname run-id (list run-id testname)))



(define (rmt:get-count-tests-running-in-jobgroup run-id jobgroup)
  (assert (number? run-id) "FATAL: Run id required.")
  (rmt:send-receive 'get-count-tests-running-in-jobgroup run-id (list run-id jobgroup)))

(define (rmt:set-state-status-and-roll-up-run run-id state status)
  (assert (number? run-id) "FATAL: Run id required.")
  (rmt:send-receive 'set-state-status-and-roll-up-run run-id (list run-id state status)))








>
>








433
434
435
436
437
438
439
440
441
442
443
444
445
446
447
448

  (assert (number? run-id) "FATAL: Run id required.")
  (rmt:send-receive 'get-count-tests-running run-id (list run-id)))

(define (rmt:get-count-tests-running-for-testname run-id testname)
  (assert (number? run-id) "FATAL: Run id required.")
  (rmt:send-receive 'get-count-tests-running-for-testname run-id (list run-id testname)))

(define (rmt:get-all-state-status-counts-for-test run-id test-name item-path item-state-in item-status-in)
  (rmt:send-receive 'get-all-state-status-counts-for-test run-id (list run-id test-name item-path item-state-in item-status-in)))
(define (rmt:get-count-tests-running-in-jobgroup run-id jobgroup)
  (assert (number? run-id) "FATAL: Run id required.")
  (rmt:send-receive 'get-count-tests-running-in-jobgroup run-id (list run-id jobgroup)))

(define (rmt:set-state-status-and-roll-up-run run-id state status)
  (assert (number? run-id) "FATAL: Run id required.")
  (rmt:send-receive 'set-state-status-and-roll-up-run run-id (list run-id state status)))
︙︙

This page was generated in about 0.124s by Fossil 2.24 [452f8e1ffc] 2024-03-26 15:36:00