Megatest

Changes On Branch b5f1f35f262c1301
Login

Changes In Branch v1.80-processes Through [b5f1f35f26] Excluding Merge-Ins

This is equivalent to a diff from 72065b6c5e to b5f1f35f26

2023-11-10
19:49
Last seemingly good commit on all platforms. check-in: 1d9da3b7a0 user: matt tags: v1.80-revolution
2023-10-09
19:51
Merged v1.80 in check-in: 38506ffe03 user: matt tags: v1.80
19:38
fix port setting Leaf check-in: b5f1f35f26 user: matt tags: v1.80-processes
10:59
Added force-init to db open proc. check-in: b1a043e49f user: mrwellan tags: v1.80-processes
2023-10-06
16:56
Fixed dbmod:attach-sync so that it works for the non-id rows. Adjusted some log messages. Removed old lock files check-in: 1e29e5e90e user: mmgraham tags: v1.80
2023-09-29
08:17
Merged fork check-in: 35feb6b8db user: mrwellan tags: v1.80-processes
2023-09-25
19:04
Added sync file age checking to -db2db check-in: 72065b6c5e user: mmgraham tags: v1.80
19:02
Corrected 20 second age check for sync lock file. Added exception handler for a sqlite3:with-transaction. check-in: 8f8169ac4d user: mmgraham tags: v1.80

Modified api.scm from [c477d1f287] to [5fa313076b].

401
402
403
404
405
406
407






408
409
410
411
412
413
414
401
402
403
404
405
406
407
408
409
410
411
412
413
414
415
416
417
418
419
420







+
+
+
+
+
+







    ((tasks-get-last)            (apply tasks:get-last dbstruct params))

    ;; NO SYNC DB
    ((no-sync-set)               (apply db:no-sync-set         *no-sync-db* params))
    ((no-sync-get/default)       (apply db:no-sync-get/default *no-sync-db* params))
    ((no-sync-del!)              (apply db:no-sync-del!        *no-sync-db* params))
    ((no-sync-get-lock)          (apply db:no-sync-get-lock    *no-sync-db* params))

    ;; NO SYNC DB PROCESSES
    ((register-process)          (apply dbfile:register-process *no-sync-db* params))
    ((set-process-done)          (apply dbfile:set-process-done *no-sync-db* params))
    ((set-process-status)        (apply dbfile:set-process-status *no-sync-db* params))
    ((get-process-options)       (apply dbfile:get-process-options *no-sync-db* params))
    
    ;; ARCHIVES
    ;; ((archive-get-allocations)   
    ((archive-register-disk)     (apply db:archive-register-disk dbstruct params))
    ((archive-register-block-name)(apply db:archive-register-block-name dbstruct params))
    ;; ((archive-allocate-testsuite/area-to-block)(apply db:archive-allocate-testsuite/area-to-block dbstruct block-id testsuite-name areakey))

Modified dbfile.scm from [1a2e6b4c5e] to [4b315f3788].

14
15
16
17
18
19
20
21

22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37

38
39
40
41
42
43
44

45
46
47
48
49
50
51
14
15
16
17
18
19
20

21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36

37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52







-
+















-
+







+







;;     GNU General Public License for more details.
;; 
;;     You should have received a copy of the GNU General Public License
;;     along with Megatest.  If not, see <http://www.gnu.org/licenses/>.

;;======================================================================

(use srfi-18)
(use srfi-18 posix hostinfo)

(declare (unit dbfile))
(declare (uses debugprint))
(declare (uses commonmod))

(module dbfile
	*
	
  (import scheme
	  chicken
	  data-structures
	  extras
	  matchable
  
	  (prefix sqlite3 sqlite3:)
	  posix typed-records
	  posix posix-extras typed-records

	  srfi-18
	  srfi-1
	  srfi-69
	  stack
	  files
	  ports
	  hostinfo
	  
	  commonmod
	  debugprint
	  )

;; parameters
;;
119
120
121
122
123
124
125








































126
127
128
129
130
131
132
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
140
141
142
143
144
145
146
147
148
149
150
151
152
153
154
155
156
157
158
159
160
161
162
163
164
165
166
167
168
169
170
171
172
173







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








;; used in simple-get-runs (thanks Brandon!)
(define-record simple-run target id runname state status owner event_time)
(define-record-printer (simple-run x out)
  (fprintf out "#,(simple-run ~S ~S ~S ~S)"
	   (simple-run-target x) (simple-run-id x) (simple-run-runname x) (time->string (seconds->local-time (simple-run-event_time x) ))))

;; args is hash table of string to value
;;
(define (get-purpose args)
  (let* ((get-arg    (lambda (key)
		       (hash-table-ref/default args key #f)))
	 (get-switch (lambda keys
		       (fold
			(lambda (key res)
			  (if (hash-table-ref/default args key #f)
			      (or key res)
			      res))
			#f
			keys)))
	 (action     (get-switch "-server" "-execute" "-run" "-rerun")))
    (cond
     (action
      (substring action 1 (string-length action)))
     (else
      "nopurpose"))))

;; megatest process tracking

(defstruct procinf
  (start      (current-seconds))
  (end        -1)
  (host       (get-host-name)) ;; why is this not being recognised?
  (pid        (current-process-id))
  (port       -1)
  (cwd        (current-directory))
  (load       #f)
  (purpose    #f) ;; get-purpose needed to be run in megatest.scm
  (dbname     #f)
  (mtbin      (car (argv)))
  (mtversion  #f)
  (status     "running")
  
  
  )

(define *procinf* (make-procinf))
(define *dbstruct-dbs* #f)
(define *db-open-mutex* (make-mutex))
(define *db-access-mutex* (make-mutex)) ;; used in common.scm
(define *no-sync-db*   #f)
(define *db-sync-in-progress* #f)
(define *db-with-db-mutex*    (make-mutex))
(define *max-api-process-requests* 0)
360
361
362
363
364
365
366
367


368
369
370
371
372
373
374
375
376
377

378
379
380
381
382
383
384
385
386
387
388
389
390
391

392
393
394
395
396
397
398
399
400
401
402
403
404
405


406
407
408
409
410
411
412
401
402
403
404
405
406
407

408
409
410
411
412
413
414
415
416
417
418

419
420
421
422
423
424
425
426
427
428
429
430
431
432

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

447
448
449
450
451
452
453
454
455







-
+
+









-
+













-
+













-
+
+







    
(define (dbfile:print-err . params)
  (with-output-to-port
      (current-error-port)
    (lambda ()
      (apply print params))))

(define (dbfile:cautious-open-database fname init-proc sync-mode journal-mode #!optional (tries-left 500))
(define (dbfile:cautious-open-database fname init-proc sync-mode journal-mode
				       #!key (tries-left 500)(force-init #f))
  (let* ((busy-file  (conc fname "-journal"))
	 (delay-time (* (- 51 tries-left) 1.1))
      	 (write-access (file-write-access? fname))
         (dir-access (file-write-access? (pathname-directory fname)))
         (retry      (lambda ()
		       (thread-sleep! delay-time)
		       (if (> tries-left 0)
			   (dbfile:cautious-open-database fname init-proc
							  sync-mode journal-mode
							  (- tries-left 1))))))
							  tries-left: (- tries-left 1))))))
    (assert (>= tries-left 0) (conc "FATAL: too many attempts in dbfile:cautious-open-database of "fname", giving up."))
    
    (if (and (file-write-access? fname)
	     (file-exists? busy-file))
	(begin
	  (if (common:low-noise-print 120 busy-file)
	      (dbfile:print-err "INFO: dbfile:cautious-open-database: journal file "
				busy-file" exists, trying again in few seconds."))
	  (thread-sleep! 1)
	  (if (eq? tries-left 2)
	      (begin
	  	(dbfile:print-err "INFO: forcing journal rollup "busy-file)
	  	(dbfile:brute-force-salvage-db fname)))
	  (dbfile:cautious-open-database fname init-proc sync-mode journal-mode (- tries-left 1)))
	  (dbfile:cautious-open-database fname init-proc sync-mode journal-mode tries-left: (- tries-left 1)))
	
	(let* ((result (condition-case
		        (if dir-access
			    (dbfile:with-simple-file-lock
			     (conc fname ".lock")
			     (lambda ()
			       (let* ((db-exists (file-exists? fname))
				      (db        (sqlite3:open-database fname))) ;; creates an empty db if it did not already exist.
                                 (sqlite3:set-busy-handler! db (sqlite3:make-busy-timeout 30000))
				 (if sync-mode
				     (sqlite3:execute db (conc "PRAGMA synchronous = "sync-mode";")))
				 (if journal-mode
				     (sqlite3:execute db (conc "PRAGMA journal_mode = "journal-mode";")))
				 (if (and init-proc (not db-exists))
				 (if (and init-proc (or force-init
							(not db-exists)))
				     (init-proc db))
				 db)))
                            (begin
			      (if (file-exists? fname )
                                  (let ((db (sqlite3:open-database fname)))
				    ;; pragmas synchronous not needed because this db is used read-only
				    ;; (sqlite3:execute db (conc "PRAGMA synchronous = "mode";")
463
464
465
466
467
468
469
470















471
472
473
474


475
476
477
478
479
480
481













































































482
483
484
485
486
487
488
506
507
508
509
510
511
512

513
514
515
516
517
518
519
520
521
522
523
524
525
526
527
528
529


530
531
532
533
534
535
536
537
538
539
540
541
542
543
544
545
546
547
548
549
550
551
552
553
554
555
556
557
558
559
560
561
562
563
564
565
566
567
568
569
570
571
572
573
574
575
576
577
578
579
580
581
582
583
584
585
586
587
588
589
590
591
592
593
594
595
596
597
598
599
600
601
602
603
604
605
606
607
608
609
610
611
612
613
614
615
616
617
618
619
620
621
622







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


-
-
+
+







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







			    "CREATE TABLE IF NOT EXISTS no_sync_metadat
                                (var TEXT,
                                 val TEXT,
                                   CONSTRAINT no_sync_metadat_constraint UNIQUE (var));"
			    "CREATE TABLE IF NOT EXISTS no_sync_locks 
                                (key TEXT,
                                 val TEXT,
                                   CONSTRAINT no_sync_metadat_constraint UNIQUE (key));"))))))
                                   CONSTRAINT no_sync_metadat_constraint UNIQUE (key));"
			    "CREATE TABLE IF NOT EXISTS processes
                                (id INTEGER PRIMARY KEY,
                                 host TEXT,
                                 port INTEGER,
                                 pid INTEGER,
                                 starttime INTEGER,
                                 endtime INTEGER,
                                 status TEXT,
                                 purpose TEXT,
                                 dbname TEXT,
                                 mtversion TEXT,
                                 reason TEXT DEFAULT 'none',
                                   CONSTRAINT no_sync_processes UNIQUE (host,pid));"
			    ))))))
	 (on-tmp      (equal? (car (string-split dbpath "/")) "tmp"))
	 (db        (if on-tmp
			(dbfile:cautious-open-database dbname init-proc 0 "WAL")
			(dbfile:cautious-open-database dbname init-proc 0 #f)
			(dbfile:cautious-open-database dbname init-proc 0 "WAL" force-init: #t)
			(dbfile:cautious-open-database dbname init-proc 0 #f    force-init: #t)
			;; (sqlite3:open-database dbname)
			)))
    (if on-tmp	      ;; done in cautious-open-database
	(begin
	  (sqlite3:execute db "PRAGMA synchronous = 0;")
	  (sqlite3:set-busy-handler! db (sqlite3:make-busy-timeout 136000))))
    db))

;; mtest processes registry calls

(define (dbfile:insert-or-update-process nsdb dat)
  (let* ((host      (procinf-host dat))
	 (pid       (procinf-pid  dat))
	 (curr-info (dbfile:get-process-info nsdb host pid)))
    (if curr-info ;; record exists, do update
	(match curr-info
	  ((host port pid starttime endtime status purpose dbname mtversion)
	   (sqlite3:execute
	    nsdb
	    "UPDATE processes SET port=?,starttime=?,endtime=?,status=?,
                                  purpose=?,dbname=?,mtversion=?
              WHERE host=? AND pid=?;"
	    (or (procinf-port      dat) port)
	    (or (procinf-start     dat) starttime)
	    (or (procinf-end       dat) endtime)
	    (or (procinf-status    dat) status)
	    (or (procinf-purpose   dat) purpose)
	    (or (procinf-dbname    dat) dbname)
	    (or (procinf-mtversion dat) mtversion)
	    host pid))
	  (else
	   #f ;; what to do?
	   ))
	(dbfile:register-process
	 nsdb
	 (procinf-host      dat)
	 (procinf-port      dat)
	 (procinf-pid       dat)
	 (procinf-start     dat)
	 (procinf-end       dat)
	 (procinf-status    dat)
	 (procinf-purpose   dat)
	 (procinf-dbname    dat)
	 (procinf-mtversion dat)))))
	  

(define (dbfile:register-process nsdb host port pid starttime endtime status purpose dbname mtversion)
  (sqlite3:execute nsdb "INSERT INTO processes (host,port,pid,starttime,endtime,status,purpose,dbname,mtversion) VALUES (?,?,?,?,?,?,?,?,?);"
		   host port pid starttime endtime status purpose dbname mtversion))

(define (dbfile:set-process-status nsdb host pid newstatus)
  (sqlite3:execute nsdb "UPDATE processes SET status=? WHERE host=? AND pid=?;" newstatus host pid))

(define (dbfile:get-process-options nsdb purpose dbname)
  (sqlite3:fold-row
   ;; host port pid starttime status mtversion
   (lambda (res . row)
     (cons row res))
   '()
   nsdb
   "SELECT host,port,pid,starttime,endtime,status,mtversion FROM processes WHERE purpose=? AND dbname LIKE ? AND status='alive';"
   purpose dbname))

(define (dbfile:get-process-info nsdb host pid)
  (let ((res (sqlite3:fold-row
	      ;; host port pid starttime status mtversion
	      (lambda (res . row)
		(cons row res))
	      '()
	      nsdb
	      "SELECT host,port,pid,starttime,endtime,status,purpose,dbname,mtversion FROM processes WHERE host=? AND pid=?;"
	      host pid)))
    (if (null? res)
	#f
	(car res))))

(define (dbfile:set-process-done nsdb host pid reason)
  (sqlite3:execute nsdb "UPDATE processes SET status='ended',endtime=?,reason=? WHERE host=? AND pid=?;" (current-seconds) reason host pid)
  (dbfile:cleanup-old-entries nsdb))

(define (dbfile:cleanup-old-entries nsdb)
  (sqlite3:execute nsdb "DELETE FROM process WHERE status='ended' AND endtime<?;" (- (current-seconds) (* 3600 48))))

;; other no-sync functions

(define (dbfile:with-no-sync-db dbpath proc)
  (mutex-lock! *no-sync-db-mutex*)
  (let* ((already-open *no-sync-db*)
	 (db  (or already-open (dbfile:raw-open-no-sync-db dbpath)))
	 (res (proc db)))
    (if (not already-open)

Modified launch.scm from [9d838959e9] to [470997d4b0].

30
31
32
33
34
35
36
37
38
39



40
41
42
43
44
45
46
30
31
32
33
34
35
36



37
38
39
40
41
42
43
44
45
46







-
-
-
+
+
+







(declare (uses db))
(declare (uses rmtmod))
(declare (uses ezsteps))
;; (declare (uses dbmod))
(declare (uses dbfile))
(declare (uses mtargs))

(use regex regex-case base64 sqlite3 srfi-18 directory-utils posix-extras z3
     call-with-environment-variables csv)
(use typed-records pathname-expand matchable)
(use regex regex-case base64 sqlite3 srfi-18 directory-utils posix posix-extras z3
     call-with-environment-variables csv hostinfo 
     typed-records pathname-expand matchable)

(import (prefix base64 base64:)
	(prefix sqlite3 sqlite3:)
	(prefix mtargs args:)
)

(include "common_records.scm")

Modified megatest.scm from [429d7d2934] to [f7c0fef20e].

539
540
541
542
543
544
545





546
547
548
549
550
551
552
539
540
541
542
543
544
545
546
547
548
549
550
551
552
553
554
555
556
557







+
+
+
+
+







	  (exit 1))))

;; immediately set MT_TARGET if -reqtarg or -target are available
;;
(let ((targ (or (args:get-arg "-reqtarg")(args:get-arg "-target"))))
  (if targ (setenv "MT_TARGET" targ)))

;; set the purpose field in procinf

(procinf-purpose-set! *procinf* (get-purpose args:arg-hash))
(procinf-mtversion-set! *procinf* megatest-version)

;; The watchdog is to keep an eye on things like db sync etc.
;;

;; TODO: for multiple areas, we will have multiple watchdogs; and multiple threads to manage
;;(define *watchdog* (make-thread
;;		    (lambda ()
;;		      (handle-exceptions

Modified rmt.scm from [6ddef022d0] to [64f3d622e8].

724
725
726
727
728
729
730














731
732
733
734
735
736
737
724
725
726
727
728
729
730
731
732
733
734
735
736
737
738
739
740
741
742
743
744
745
746
747
748
749
750
751







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








(define (rmt:no-sync-del! var)
  (rmt:send-receive 'no-sync-del! #f `(,var)))

(define (rmt:no-sync-get-lock keyname)
  (rmt:send-receive 'no-sync-get-lock #f `(,keyname)))

;; process registration

(define (rmt:register-process host port pid starttime status purpose dbname mtversion)
  (rmt:send-receive 'register-process #f (list host port pid starttime status purpose dbname mtversion)))

(define (rmt:set-process-done host pid reason)
  (rmt:send-receive 'set-process-done #f (list host pid reason)))

(define (rmt:set-process-status host pid newstatus)
  (rmt:send-receive 'set-process-status #f (list host pid newstatus)))

(define (rmt:get-process-options purpose dbname)
  (rmt:get-process-options 'get-process-options #f (list purpose dbname)))

;;======================================================================
;; A R C H I V E S
;;======================================================================

(define (rmt:archive-get-allocations  testname itempath dneeded)
  (rmt:send-receive 'archive-get-allocations #f (list testname itempath dneeded)))

Modified tcp-transportmod.scm from [c1e45ba013] to [a1fcad65c5].

480
481
482
483
484
485
486



















487
488
489










490
491
492
493
494
495
496
480
481
482
483
484
485
486
487
488
489
490
491
492
493
494
495
496
497
498
499
500
501
502
503
504
505



506
507
508
509
510
511
512
513
514
515
516
517
518
519
520
521
522







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







				(tt:start-tcp-server ttdat)) ;; start the tcp-server which applies handler to incoming data
			      "tcp-server-thread"))
		 (run-thread (make-thread
			      (lambda ()
				(tt:keep-running ttdat dbfname dbstruct)))))
	    (thread-start! tcp-thread)
	    (thread-start! run-thread)

	    (let* ((areapath     (tt-areapath ttdat))
		   (nosyncdbpath (conc areapath"/.mtdb")))
	      ;; this didn't seem to work, is port not available yet?
	      (let loop ((count 0))
		(if (tt-port ttdat)
		    (begin
		      (procinf-port-set! *procinf* (tt-port ttdat))
		      (procinf-dbname-set! *procinf* dbfname)
		      (dbfile:with-no-sync-db
		       nosyncdbpath
		       (lambda (nsdb)
			 (dbfile:insert-or-update-process nsdb *procinf*))))
		    (if (< count 5)
			(begin
			  (thread-sleep! 0.5)
			  (loop (+ count 1)))
			(debug:print 0 *default-log-port* "ERROR: (tt-port ttdat) no port set!"))))
	    
	    (thread-join! run-thread) ;; run thread will exit on timeout or other conditions
            (debug:print 0 *default-log-port* "Exiting now.")
	    (exit))))))
	      (thread-join! run-thread) ;; run thread will exit on timeout or other conditions
	      ;; replace with call to (dbfile:set-process-done nsdb host pid reason)
	      (procinf-status-set! *procinf* "done")
	      (procinf-end-set! *procinf* (current-seconds))
	      (dbfile:with-no-sync-db
	       nosyncdbpath
	       (lambda (nsdb)
		 (dbfile:insert-or-update-process nsdb *procinf*)))
              (debug:print 0 *default-log-port* "Exiting now.")
	      (exit)))))))

(define (tt:keep-running ttdat dbfname dbstruct)
  ;; verfiy conn for ready
  ;; listener socket has been started by this stage
  ;; wait for a port before creating the registration file
  ;;
  (let* ((db-locked-in #f)