Megatest

Check-in [c6c921401e]
Login
☰Home Timeline Files Branches Tags Tickets Wiki Login
Overview
Comment:Merging in v1.60-zero-local-access to v1.60
Downloads: Tarball | ZIP archive | SQL archive
Timelines: family | ancestors | v1.60-zero-local-access
Files: files | file ages | folders
SHA1: c6c921401ea6c363e3316865c685bed7398ab1e6
User & Date: matt on 2015-11-11 23:00:14
Other Links: branch diff | manifest | tags
Context
2015-11-11
23:00
Merging in v1.60-zero-local-access to v1.60 Closed-Leaf check-in: c6c921401e user: matt tags: v1.60-zero-local-access
22:58
Added simple lock to on-exit call of sync to megatest.db. Set lots of vars when triggers are called. check-in: 2bae638e0f user: matt tags: v1.60-zero-local-access
20:47
All states supported now check-in: ab348d3b46 user: matt tags: v1.60
Changes
Hide Diffs Side-by-Side Diffs Ignore Whitespace Patch

Modified api.scm from [7425d00411] to [d2df3c2dd1].

︙
214
215
216
217
218
219
220

221
222
223
224
225
226
227

214
215
216
217
218
219
220
221
222
223
224
225
226
227
228








+








	    ((get-runs)                     (apply db:get-runs dbstruct params))
	    ((get-num-runs)                 (apply db:get-num-runs dbstruct params))
	    ((get-all-run-ids)              (db:get-all-run-ids dbstruct))
	    ((get-prev-run-ids)             (apply db:get-prev-run-ids dbstruct params))
	    ((get-run-ids-matching-target)  (apply db:get-run-ids-matching-target dbstruct params))
	    ((get-runs-by-patt)             (apply db:get-runs-by-patt dbstruct params))
	    ((get-run-name-from-id)         (apply db:get-run-name-from-id dbstruct params))
	    ((get-run-stats)                (apply db:get-run-stats dbstruct params))

	    ;; STEPS
	    ((get-steps-data)               (apply db:get-steps-data dbstruct params))
	    ((get-steps-for-test)           (apply db:get-steps-for-test dbstruct params))

	    ;; MISC
	    ((have-incompletes?)            (apply db:have-incompletes? dbstruct params))
︙

Modified common.scm from [2955bbfc6b] to [2d3a0413db].

︙
266
267
268
269
270
271
272

273
274
275
276
277
278
279
280
281
282







283
284


285
286
287
288
289
290
291
292
293
294

295





296
297
298
299
300
301
302

266
267
268
269
270
271
272
273
274
275
276
277
278
279
280
281
282
283
284
285
286
287
288
289
290


291
292
293
294
295
296
297
298
299
300
301
302
303

304
305
306
307
308
309
310
311
312
313
314
315








+










+
+
+
+
+
+
+
-
-
+
+










+
-
+
+
+
+
+









;;======================================================================
;; E X I T   H A N D L I N G
;;======================================================================

(define (common:legacy-sync-recommended)
  (or (args:get-arg "-runtests")
      (args:get-arg "-run")
      (args:get-arg "-server")
      (args:get-arg "-set-run-status")
      (args:get-arg "-remove-runs")
      (args:get-arg "-get-run-status")
      ))

(define (common:legacy-sync-required)
  (configf:lookup *configdat* "setup" "megatest-db"))

(define (std-exit-procedure)
  ;; (let ((dbpath      (db:dbfile-path run-id))
  ;; 	(lockf       (conc dbpath "/." run-id ".lck")))
  ;;   (common:simple-file-lock lockf)
  ;;   (db:multi-db-sync (list run-id) 'new2old)
  ;;   (common:simple-file-release-lock lockf))
  (let* ((dbpath      (db:dbfile-path #f))
	 (lockf       (conc dbpath "/.megatest.lck"))
  (let ((no-hurry  (if *time-to-exit* ;; hurry up
		       #f
	 (no-hurry  (if *time-to-exit* ;; hurry up
			#f
		       (begin
			 (set! *time-to-exit* #t)
			 #t))))
    (debug:print-info 4 "starting exit process, finalizing databases.")
    (if (and no-hurry (debug:debug-mode 18))
	(rmt:print-db-stats))
    (let ((th1 (make-thread (lambda () ;; thread for cleaning up, give it five seconds
			      (let ((run-ids (hash-table-keys *db-local-sync*)))
				(if (and (not (null? run-ids))
					 (configf:lookup *configdat* "setup" "megatest-db"))
				    ;; was if no-hurry but I always want it sync'd I think ...
				    (if no-hurry (db:multi-db-sync run-ids 'new2old))))
				    ;; (if no-hurry (db:multi-db-sync run-ids 'new2old))))
				    (begin
				      (common:simple-file-lock lockf)
				      (db:multi-db-sync run-ids 'new2old)
				      (common:simple-file-release-lock lockf))))
			      (if *dbstruct-db* (db:close-all *dbstruct-db*))
			      (if *inmemdb*     (db:close-all *inmemdb*))
			      (if (and *megatest-db*
				       (sqlite3:database? *megatest-db*))
				  (begin
				    (sqlite3:interrupt! *megatest-db*)
				    (sqlite3:finalize! *megatest-db* #t)
︙

Modified dashboard.scm from [3d081ca889] to [7bcb6b3970].

︙
88
89
90
91
92
93
94
95
96




97
98
99
100
101
102
103

88
89
90
91
92
93
94


95
96
97
98
99
100
101
102
103
104
105








-
-
+
+
+
+








      (print "Failed to find megatest.config, exiting") 
      (exit 1)))

(define *useserver* (or(not (args:get-arg "-use-local"))
			(configf:lookup *configdat* "dashboard" "use-server")))

(define *dbdir* (db:dbfile-path #f)) ;; (conc (configf:lookup *configdat* "setup" "linktree") "/.db"))
(define *dbstruct-local*  (make-dbr:dbstruct path:  *dbdir*
					     local: #t))
(define *dbstruct-local*  (if *useserver*
			      #f
			      (make-dbr:dbstruct path:  *dbdir*
						 local: #t)))
(define *db-file-path* (db:dbfile-path 0))

;; HACK ALERT: this is a hack, please fix.
(define *read-only* (not (file-read-access? *db-file-path*)))

(define toplevel #f)
(define dlg      #f)
︙

Modified db.scm from [3b21c0f4f0] to [d10bf78e86].

︙
136
137
138
139
140
141
142

143
144








145
146
147
148
149
150
151

136
137
138
139
140
141
142
143


144
145
146
147
148
149
150
151
152
153
154
155
156
157
158








+
-
-
+
+
+
+
+
+
+
+








;;   (let ((fdb (db:get-filedb dbstruct)))
;;     (filedb:get-path db id)))

;; NB// #f => return dbdir only
;;      (was planned to be;  zeroth db with name=main.db)
;;
(define (db:dbfile-path run-id)
  (let* ((dbdirs           (filter string?
  (let* ((dbdir           (or (configf:lookup *configdat* "setup" "dbdir")
			      (conc (configf:lookup *configdat* "setup" "linktree") "/.db")))
				   (list (configf:lookup *configdat* "setup" "dbdir")
					 (conc *toppath* "/.db")
					 (conc (configf:lookup *configdat* "setup" "linktree") "/.db"))))
	 (existing-dirs   (filter file-exists? dbdirs))
	 (dbdir           (if (null? existing-dirs)
			      (or  (configf:lookup *configdat* "setup" "dbdir")
				   (conc *toppath* "/.db"))
			      (car existing-dirs)))
	 (fname           (if run-id
			      (if (eq? run-id 0) "main.db" (conc run-id ".db"))
			      #f)))
    (handle-exceptions
     exn
     (begin
       (debug:print 0 "ERROR: Couldn't create path to " dbdir)
︙
1820
1821
1822
1823
1824
1825
1826
1827
1828


1829
1830
1831
1832
1833
1834
1835

1836
1837
1838
1839
1840
1841
1842
1843
1844
1845
1846
1847
1848
1849
1850
1851
1852
1853
1854
1855
1856
1857
1858
1859
1860
1861
1862
1863
1864
1865



















1866
1867
1868
1869
1870
1871
1872
1873

1827
1828
1829
1830
1831
1832
1833


1834
1835
1836
1837
1838
1839
1840
1841

1842






























1843
1844
1845
1846
1847
1848
1849
1850
1851
1852
1853
1854
1855
1856
1857
1858
1859
1860
1861

1862
1863
1864
1865
1866
1867
1868








-
-
+
+






-
+
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
-








	"SELECT id FROM runs WHERE state != 'deleted' ORDER BY event_time DESC;")
    (reverse run-ids)))))

;; get some basic run stats
;;
;; ( (runname (( state  count ) ... ))
;;   (   ...  
(define (db:get-run-stats dbstruct)
  (let* ((dbdat        (db:get-db dbstruct #f))
(define (db:get-run-stats dbstruct run-id run-name)
  (let* ((dbdat        (db:get-db dbstruct run-id))
	 (db           (db:dbdat-get-db dbdat))
	 (totals       (make-hash-table))
	 (curr         (make-hash-table))
	 (res          '())
	 (runs-info    '()))
    ;; First get all the runname/run-ids
    (db:delay-if-busy dbdat)
    ;; (db:delay-if-busy dbdat)
    (sqlite3:for-each-row
     (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)
       ;; get the net state/status counts for this run
       (let* ((run-id   (car  run-info))
	      (run-name (cadr run-info)))
	 (db:with-db
	  dbstruct
	  run-id
	  #f
	  (lambda (db)
	    (sqlite3: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))))))
	     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)))
		      (sort (hash-table-keys curr) string>=))
	    (set! curr (make-hash-table))))))
    (db:with-db
     dbstruct
     run-id
     #f
     (lambda (db)
       (sqlite3: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))))))
	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)))
		 (sort (hash-table-keys curr) string>=))
       (set! curr (make-hash-table))))
     runs-info)
    (for-each (lambda (state)
		(set! res (cons (list "Totals" state (hash-table-ref totals state)) res)))
	      (sort (hash-table-keys totals) string>=))
    res))

;; db:get-runs-by-patt
;; get runs by list of criteria
︙
3160
3161
3162
3163
3164
3165
3166
3167

3168
3169
3170
3171
3172
3173
3174

3155
3156
3157
3158
3159
3160
3161

3162
3163
3164
3165
3166
3167
3168
3169








-
+








			   (hash-table-set! tests-hash full-testname testdat))))
		   results)
		  (if (null? tal)
		      (map cdr (hash-table->alist tests-hash)) ;; return a list of the most recent tests
		      (loop (car tal)(cdr tal))))))))))

(define (db:delay-if-busy dbdat #!key (count 6))
  (if (not (configf:lookup *configdat* "server" "delay-on-busy"))
  (if #f ;; (not (configf:lookup *configdat* "server" "delay-on-busy"))
      (and dbdat (db:dbdat-get-db dbdat))
      (if dbdat
	  (let* ((dbpath (db:dbdat-get-path dbdat))
		 (db     (db:dbdat-get-db   dbdat)) ;; we'll return this so (db:delay--if-busy can be called inline
		 (dbfj   (conc dbpath "-journal")))
	    (if (handle-exceptions
		 exn
︙

Modified dcommon.scm from [5d1caffec5] to [f2eb55f8d3].

︙
398
399
400
401
402
403
404
405



406
407
408
409
410
411
412

398
399
400
401
402
403
404

405
406
407
408
409
410
411
412
413
414








-
+
+
+









    general-matrix))

(define (dcommon:run-stats dbstruct)
  (let* ((stats-matrix (iup:matrix expand: "YES"))
	 (changed      #f)
	 (updater      (lambda ()
			 (let* ((run-stats    (db:get-run-stats dbstruct))
			 (let* ((run-stats    (if dbstruct
						  (db:get-run-stats dbstruct)
						  (rmt:get-all-run-stats)))
				(indices      (common:sparse-list-generate-index run-stats)) ;;  proc: set-cell))
				(row-indices  (car indices))
				(col-indices  (cadr indices))
				(max-row      (if (null? row-indices) 1 (apply max (map cadr row-indices))))
				(max-col      (if (null? col-indices) 1 
						  (apply max (map cadr col-indices))))
				(max-visible  (max (- *num-tests* 15) 3))
︙

Modified megatest.scm from [47f4506230] to [c312c4165d].

︙
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
351
352

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
351
352
353
354
355
356
357








-
-
-
-
+
+
+
+
+
+
+












+

+








;; The watchdog is to keep an eye on things like db sync etc.
;;
(define *time-zero* (current-seconds))
(define *watchdog*
  (make-thread 
   (lambda ()
     (thread-sleep! 0.05) ;; delay for startup
     (let ((legacy-sync (common:legacy-sync-required))
	   (debug-mode  (debug:debug-mode 1))
	   (last-time   (current-seconds)))
       (if (common:legacy-sync-recommended)
     (let* ((legacy-sync (common:legacy-sync-required))
	    (debug-mode  (debug:debug-mode 1))
	    (last-time   (current-seconds))
	    (dbpath      (db:dbfile-path #f))
	    (lockf       (conc dbpath "/.megatest.lck")))
       (if (or legacy-sync
	       (common:legacy-sync-recommended)) ;; for now do *some* syncing to megatest.db for backup purposes
	   (let loop ()
	     ;; sync for filesystem local db writes
	     ;;
	     (let ((start-time      (current-seconds))
		   (servers-started (make-hash-table)))
	       (for-each 
		(lambda (run-id)
		  (mutex-lock! *db-multi-sync-mutex*)
		  (if (and legacy-sync 
			   (hash-table-ref/default *db-local-sync* run-id #f))
		      ;; (if (> (- start-time last-write) 5) ;; every five seconds
		      (begin ;; let ((sync-time (- (current-seconds) start-time)))
			(common:simple-file-lock lockf)
			(db:multi-db-sync (list run-id) 'new2old)
			(common:simple-file-release-lock lockf)
			(if (common:low-noise-print 30 "sync new to old")
			    (let ((sync-time (- (current-seconds) start-time)))
			      (debug:print-info 0 "Sync of newdb to olddb for run-id " run-id " completed in " sync-time " seconds")))
			;; (if (> sync-time 10) ;; took more than ten seconds, start a server for this run
			;;     (begin
			;;       (debug:print-info 0 "Sync is taking a long time, start up a server to assist for run " run-id)
			;;       (server:kind-run run-id)))))
︙
360
361
362
363
364
365
366
367

368
369
370
371
372
373
374

365
366
367
368
369
370
371

372
373
374
375
376
377
378
379








-
+








		     (debug:print-info 4 "timestamp -> " (seconds->time-string (current-seconds)) ", time since start -> " (seconds->hr-min-sec (- (current-seconds) *time-zero*))))))
	     
	     ;; keep going unless time to exit
	     ;;
	     (if (not *time-to-exit*)
		 (let delay-loop ((count 0))
		   (if (and (not *time-to-exit*)
			    (< count 11)) ;; aprox 5-6 seconds
			    (< count 40)) ;; aprox 30-40 seconds
		       (begin
			 (thread-sleep! 1)
			 (delay-loop (+ count 1))))
		   (loop)))
	     (if (common:low-noise-print 30)
		 (debug:print-info 0 "Exiting watchdog timer, *time-to-exit* = " *time-to-exit*)))))
     "Watchdog thread")))
︙

Modified mt.scm from [d7eb2f40fc] to [3fc7d68694].

︙
143
144
145
146
147
148
149

150
151
152
153
154
155
156

143
144
145
146
147
148
149
150
151
152
153
154
155
156
157








+








		   (file-exists? test-rundir)
		   (directory? test-rundir))
	      (call-with-environment-variables
	       (list (cons "MT_TEST_NAME" test-name)
		     (cons "MT_TEST_RUN_DIR" test-rundir)
		     (cons "MT_ITEMPATH"     (db:test-get-item-path test-dat)))
	       (lambda ()
		 (runs:set-megatest-env-vars run-id) ;;; WARNING: This sets a lot of vars!!!!
		 (push-directory test-rundir)
		 (set! tconfig (mt:lazy-read-test-config test-name))
		 (for-each (lambda (trigger)
			     (let ((cmd  (configf:lookup tconfig "triggers" trigger))
				   (logf (conc  test-rundir "/last-trigger.log")))
			       (if cmd
				   ;; Putting the commandline into ( )'s means no control over the shell.
︙

Modified rmt.scm from [58033889c8] to [1253a2efe8].

︙
620
621
622
623
624
625
626




















627
628
629
630
631
632
633

620
621
622
623
624
625
626
627
628
629
630
631
632
633
634
635
636
637
638
639
640
641
642
643
644
645
646
647
648
649
650
651
652
653








+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+








		  (debug:print 4 "Got tests for run-id " run-id ", test-name " test-name ", item-path " item-path ": " results)
		  (if (and (null? results)
			   (not (null? tal)))
		      (loop (car tal)(cdr tal))
		      (if (null? results) #f
			  (car results))))))))))

;; call with run-id #f
;;
(define (rmt:get-all-run-stats)
  (let* ((runs-dat (rmt:get-runs "%" #f #f '()))
	 (header   (db:get-header runs-dat))
	 (runs     (db:get-rows   runs-dat)))
    (fold (lambda (run currdat)
	    (let* ((run-id   (db:get-value-by-header run header "id"))
		   (run-name (db:get-value-by-header run header "runname")))
	      (if (and run-id run-name)
		  (append (rmt:get-run-stats run-id run-name) currdat)
		  (begin
		    (debug:print 0 "ERROR: Bad run-id or run-name in " run)
		    currdat))))
	  '()
	  runs)))

(define (rmt:get-run-stats run-id run-name)
  (rmt:send-receive 'get-run-stats run-id (list run-id run-name)))

;;======================================================================
;;  S T E P S
;;======================================================================

;; Getting steps is more complicated.
;;
;; If given work area
︙

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