Megatest

Check-in [a6984512c6]
Login
☰Home Timeline Files Branches Tags Tickets Wiki Login
Overview
Comment:main.db mostly opens
Downloads: Tarball | ZIP archive | SQL archive
Timelines: family | ancestors | descendants | both | v1.6584-ck5
Files: files | file ages | folders
SHA1: a6984512c6c8f413ded1c7cce724233dc16d2bf7
User & Date: matt on 2021-04-25 23:08:10
Other Links: branch diff | manifest | tags
Context
2021-04-28
23:27
wip check-in: a758074358 user: matt tags: v1.6584-ck5
2021-04-25
23:08
main.db mostly opens check-in: a6984512c6 user: matt tags: v1.6584-ck5
22:29
Trying to start main.db server check-in: ef485de0ef user: matt tags: v1.6584-ck5
Changes
Hide Diffs Side-by-Side Diffs Ignore Whitespace Patch

Modified dbmod.scm from [a51a71cf55] to [9c5f03fda2].

︙
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
174
175
176


177
178
179
180
181
182
183


184
185
186
187
188
189

190
191
192
193
194
195
196

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
174


175
176
177
178
179
180
181


182
183
184
185
186
187
188

189
190
191
192
193
194
195
196








-
+








-
-
+
+


-
-
-
+
+
+




-
-
+
+



-
-
+
+





-
-
+
+





-
+








;; iterated tests
;;
(defstruct dbr:counts
  (state #f)
  (status #f)
  (count  0)) 

;; Retrieve a dbdat given run-id, open and setup both inmemory and
;; Retrieve a dbdat given dbfile, open and setup both inmemory and
;; db file if needed
;;
;;    if run-id => get run specific db
;;    if #f     => get main.db
;;    if db already open - return inmem
;;    if db not open, open inmem, rundb and sync then return inmem
;;    inuse gets set automatically for rundb's
;;
(define (db:get-dbdat dbstruct apath run-id)
  (let ((dbdat (dbr:dbstruct-get-dbdat dbstruct run-id)))
(define (db:get-dbdat dbstruct apath dbfile)
  (let ((dbdat (dbr:dbstruct-get-dbdat dbstruct dbfile))) ;; run-id)))
    (if dbdat
	dbdat
	(let* ((dbfile   (db:run-id->path apath run-id))
	       (newdbdat (db:open-dbdat apath run-id db:initialize-db)))
	  (dbr:dbstruct-dbdat-put! dbstruct run-id newdbdat)
	(let* (;; (dbfile   (db:run-id->path apath run-id))
	       (newdbdat (db:open-dbdat apath dbfile db:initialize-db)))
	  (dbr:dbstruct-dbdat-put! dbstruct dbfile newdbdat)
	  newdbdat))))

;; get the inmem db for actual db operations
;;
(define (db:get-inmem dbstruct run-id)
  (dbr:dbdat-inmem (db:get-dbdat dbstruct run-id)))
(define (db:get-inmem dbstruct dbfile)
  (dbr:dbdat-inmem (db:get-dbdat dbstruct dbfile)))

;; get the handle for the on-disk db
;;
(define (db:get-ddb dbstruct apath run-id)
  (dbr:dbdat-db (db:get-dbdat dbstruct apath run-id)))
(define (db:get-ddb dbstruct apath dbfile)
  (dbr:dbdat-db (db:get-dbdat dbstruct apath dbfile)))

;; open or create the disk db file
;; create and fill the inmemory db
;; assemble into dbr:dbdat struct and return
;; 
(define (db:open-dbdat apath run-id dbinit-proc)
  (let* ((dbfile   (db:run-id->path apath run-id))
(define (db:open-dbdat apath dbfile dbinit-proc)
  (let* (;; (dbfile   (db:run-id->path apath run-id))
	 (db       (db:open-run-db dbfile dbinit-proc))
	 (inmem    (db:open-inmem-db dbinit-proc))
	 (dbdat    (make-dbr:dbdat
		    db:     db
		    inmem:  inmem
		    run-id: run-id
		    ;; run-id: run-id  ;; no can do, there are many run-id values that point to single db
		    fname:  dbfile)))
    ;; now sync the disk file data into the inmemory db
    (db:sync-tables (db:sync-all-tables-list) #f db inmem)
    dbdat))

;; open the disk database file
;; NOTE: May need to add locking to file create process here
︙
390
391
392
393
394
395
396
397
398


399
400
401
402
403
404

405
406
407
408
409
410
411

390
391
392
393
394
395
396


397
398
399
400
401
402
403

404
405
406
407
408
409
410
411








-
-
+
+





-
+








;; ;;     (set! *db-last-access* start-t)
;; ;;     (mutex-unlock! *db-multi-sync-mutex*)
;; ;;     (stack-push! (dbr:dbstruct-dbstack dbstruct) tmpdb)))

;; NOTE: touched logic is disabled/not done
;; sync run to disk if touched
;;
(define (db:sync-inmem->disk dbstruct run-id #!key (force-sync #f))
  (let* ((dbdat       (db:get-dbdat dbstruct run-id))
(define (db:sync-inmem->disk dbstruct dbfile #!key (force-sync #f))
  (let* ((dbdat       (db:get-dbdat dbstruct dbfile))
	 (db          (dbr:dbdat-db dbstruct))
	 (inmem       (dbr:dbdat-inmem dbstruct))
	 (start-t     (current-seconds))
	 (last-update (dbr:dbdat-last-write dbdat))
	 (last-sync   (dbr:dbdat-last-sync dbdat)))
    (debug:print-info 4 *default-log-port* "Syncing for run-id: " run-id)
    (debug:print-info 4 *default-log-port* "Syncing for dbfile: " dbfile)
    (mutex-lock! *db-multi-sync-mutex*)
    (let* ((update_info (cons (if force-sync 0 last-update) "last_update"))
    	   (need-sync   (or force-sync (>= last-update last-sync))))
      (mutex-unlock! *db-multi-sync-mutex*)
      (if need-sync
	  (db:sync-tables (db:sync-all-tables-list) update_info inmem db)
	  (debug:print 0 *default-log-port* "Skipping sync as nothing touched.")))
︙

Modified http-transportmod.scm from [96c70e902e] to [f4c57969ab].

︙
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

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








-
+




-
+



+
+
-
+

-
+


















+








;;======================================================================
;; END NEW SERVER METHOD
;;======================================================================

;; run http-transport:keep-running in a parallel thread to monitor that the db is being 
;; used and to shutdown after sometime if it is not.
;;
(define (http-transport:keep-running) 
(define (http-transport:keep-running dbname) 
  ;; if none running or if > 20 seconds since 
  ;; server last used then start shutdown
  ;; This thread waits for the server to come alive
  (debug:print-info 0 *default-log-port* "Starting the sync-back, keep alive thread in server")
  (let* ((run-id            (let ((rid (args:get-arg "-run-id")))
  (let* ((run-id            (let ((rid (args:get-arg "-run-id"))) ;; consider getting rid of the -run-id mechanism
			      (if rid
				  (string->number rid)
				  #f)))
	 (db-file           (if dbname
				(db:dbname->path *toppath* dbname)
	 (db-file           (db:run-id->path *toppath* run-id))
				(db:run-id->path *toppath* run-id)))
	 (sdat              #f)
	 (tmp-area          (common:get-db-tmp-area))
	 ;; (tmp-area          (common:get-db-tmp-area))
	 (server-start-time (current-seconds))
	 (pkts-dir          (get-pkts-dir))
	 (server-key        (server:mk-signature))
	 (server-info (let loop ((start-time (current-seconds))
				 (changed    #t)
				 (last-sdat  "not this"))
                        (begin ;; let ((sdat #f))
			  (thread-sleep! 0.01)
			  (debug:print-info 0 *default-log-port* "Waiting for server alive signature")
                          (mutex-lock! *heartbeat-mutex*)
                          (set! sdat *server-info*)
                          (mutex-unlock! *heartbeat-mutex*)
                          (if (and sdat
				   (not changed)
				   (> (- (current-seconds) start-time) 2))
			      (begin
				(debug:print-info 0 *default-log-port* "Received server alive signature, now attempting to lock in server")
				;; create a server pkt in *toppath*/.meta/srvpkts
				
				(register-server pkts-dir *srvpktspec* (get-host-name)
						 (cadr sdat) server-key (car sdat) db-file)

				;; now read pkts and see if we are a contender
				(let* ((all-pkts     (get-all-server-pkts pkts-dir *srvpktspec*))
				       (viables      (get-viable-servers all-pkts db-file))
				       (best-srv     (get-best-candidate viables db-file))
︙
641
642
643
644
645
646
647

648


649
650
651
652
653
654
655

644
645
646
647
648
649
650
651

652
653
654
655
656
657
658
659
660








+
-
+
+








	       (server-state 'available)
	       (bad-sync-count 0)
	       (start-time     (current-milliseconds)))
      ;; Use this opportunity to sync the tmp db to megatest.db
      (if (not *dbstruct-db* )
	  (let ((watchdog (bdat-watchdog *bdat*)))
	    (debug:print 0 *default-log-port* "SERVER: dbprep")
	    
	    (db:setup run-id) ;; sets *dbstruct-db* as side effect
	    (db:setup dbname) ;; sets *dbstruct-db* as side effect

	    (debug:print 0 *default-log-port* "SERVER: running, megatest version: " (common:get-full-version)) ;; NOTE: the server is NOT yet marked as running in the log. We do that in the keep-running routine.
	    (if watchdog
		(if (not (member (thread-state watchdog) '(ready running blocked sleeping dead)))
		    (begin
		      (debug:print-info 0 "Starting watchdog thread (in state "(thread-state watchdog)")")
		      (thread-start! watchdog)))
		(debug:print 0 *default-log-port* "ERROR: *watchdog* not setup, cannot start it."))))
︙
754
755
756
757
758
759
760
761
762
763
764
765
766
767
768








769
770
771
772
773
774
775
776
777
778

779
780
781
782
783
784
785
786
787
788
789
790
791

792
793
794
795
796
797
798

759
760
761
762
763
764
765








766
767
768
769
770
771
772
773
774
775
776
777
778
779
780
781
782

783
784
785
786
787
788
789
790
791
792
793
794
795

796
797
798
799
800
801
802
803








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









-
+












-
+








;; Call this to start the actual server
;;

;; all routes though here end in exit ...
;;
;; start_server? 
;;
(define (http-transport:launch)
  (let* ((tmp-area            (common:get-db-tmp-area))
	 (server-start        (conc tmp-area "/.server-start"))
	 (server-started      (conc tmp-area "/.server-started"))
	 (start-time          (common:lazy-modification-time server-start))
	 (started-time        (common:lazy-modification-time server-started))
	 (server-starting     (< start-time started-time)) ;; if start-time is less than started-time then a server is still starting
	 (start-time-old      (> (- (current-seconds) start-time) 5))
(define (http-transport:launch dbname)
  (let* (;; (tmp-area            (common:get-db-tmp-area))
	 ;; (server-start        (conc tmp-area "/.server-start"))
	 ;; (server-started      (conc tmp-area "/.server-started"))
	 ;; (start-time          (common:lazy-modification-time server-start))
	 ;; (started-time        (common:lazy-modification-time server-started))
	 ;; (server-starting     (< start-time started-time)) ;; if start-time is less than started-time then a server is still starting
	 ;; (start-time-old      (> (- (current-seconds) start-time) 5))
         (cleanup-proc        (lambda (msg)
                                (let* ((serv-fname      (conc "server-" (current-process-id) "-" (get-host-name) ".log"))
                                       (full-serv-fname (conc *toppath* "/logs/" serv-fname))
                                       (new-serv-fname  (conc *toppath* "/logs/" "defunct-" serv-fname)))
                                  (debug:print 0 *default-log-port* msg)
                                  (if (common:file-exists? full-serv-fname)
                                      (system (conc "sleep 1;mv -f " full-serv-fname " " new-serv-fname))
                                      (debug:print 0 *default-log-port* "INFO: cannot move " full-serv-fname " to " new-serv-fname))
                                  (exit)))))
    (common:save-pkt `((action . start)
    #;(common:save-pkt `((action . start)
		       (T      . server)
		       (pid    . ,(current-process-id)))
		     *configdat* #t)
    (let* ((th2 (make-thread (lambda ()
                               (debug:print-info 0 *default-log-port* "Server run thread started")
                               (http-transport:run 
                                (if (args:get-arg "-server")
                                    (args:get-arg "-server")
                                    "-")
                                )) "Server run"))
           (th3 (make-thread (lambda ()
                               (debug:print-info 0 *default-log-port* "Server monitor thread started")
                               (http-transport:keep-running)
                               (http-transport:keep-running dbname)
                               "Keep running"))))
      (thread-start! th2)
      (thread-sleep! 0.252) ;; give the server time to settle before starting the keep-running monitor.
      (thread-start! th3)
      (set! *didsomething* #t)
      (thread-join! th2)
      (exit))))
︙
854
855
856
857
858
859
860
861
862


863
864
865
866
867
868
869

859
860
861
862
863
864
865


866
867
868
869
870
871
872
873
874








-
-
+
+








;; Call this to start the actual server
;;

;; all routes though here end in exit ...
;;
;; start_server
;;
(define (server:launch run-id transport-type)
    (http-transport:launch))
(define (server:launch dbname)
    (http-transport:launch dbname))

;;======================================================================
;; S E R V E R   U T I L I T I E S 
;;======================================================================

;; NOT USED (well, ok, reference in rpc-transport but otherwise not used).
;;
︙

Modified megatest.scm from [7dbfbe85c3] to [bf020dc21f].

︙
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
623
624
625
626
627
628
629
630
631
632
633



634
635
636
637
638
639
640

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
623
624
625
626
627
628
629
630
631



632
633
634
635
636
637
638
639
640
641








-
+

-
-
-
+
+
+












-
-
+
+










-
-
+
+

-
-
+
+


+










-
-
-
+
+
+








     			":runname"
     			"-runname"
     			":state"  
     			"-state"
     			":status"
     			"-status"
     			"-list-runs"
                             "-testdata-csv"
			"-testdata-csv"
     			"-testpatt"
                             "--modepatt"
                             "-modepatt"
                             "-tagexpr"
			"--modepatt"
			"-modepatt"
			"-tagexpr"
     			"-itempatt"
     			"-setlog"
     			"-set-toplog"
     			"-runstep"
     			"-logpro"
     			"-m"
     			"-rerun"
     
     			"-days"
     			"-rename-run"
     			"-to"
     			"-dest"
                             "-source" 
                             "-time-stamp" 
			"-source" 
			"-time-stamp" 
     			;; values and messages
     			":category"
     			":variable"
     			":value"
     			":expected"
     			":tol"
     			":units"
     
     			;; misc
     			"-start-dir"
                             "-run-patt"
                             "-target-patt"   
			"-run-patt"
			"-target-patt"   
     			"-contour"
                             "-area-tag"  
                             "-area"  
			"-area-tag"  
			"-area"  
     			"-run-tag"
     			"-server"
			"-db"            ;; file name for setting up a server
     			"-adjutant"
     			"-transport"
     			"-port"
     			"-extract-ods"
     			"-pathmod"
     			"-env2file"
     			"-envcap"
     			"-envdelta"
     			"-setvars"
     			"-set-state-status"
     
                             ;; move runs stuff here
                             "-remove-keep"           
			
			;; move runs stuff here
			"-remove-keep"           
     			"-set-run-status"
     			"-age"
     
     			;; archive 
     			"-archive"
     			"-actions"
     			"-precmd"
︙
652
653
654
655
656
657
658
659

660
661
662
663
664
665
666
667
668
669
670



671
672
673
674

675
676
677
678
679
680
681

653
654
655
656
657
658
659

660
661
662
663
664
665
666
667
668



669
670
671
672
673
674

675
676
677
678
679
680
681
682








-
+








-
-
-
+
+
+



-
+








     			"-var"
     			"-dumpmode"
     			"-run-id"
     			"-ping"
     			"-refdb2dat"
     			"-o"
     			"-log"
                             "-sync-log"
			"-sync-log"
     			"-since"
     			"-fields"
     			"-recover-test" ;; run-id,test-id - used internally to recover a test stuck in RUNNING state
     			"-sort"
     			"-target-db"
     			"-source-db"
     			"-prefix-target"
     
                             "-src-target"
                             "-src-runname"
                             "-diff-email"
			"-src-target"
			"-src-runname"
			"-diff-email"
     			"-sync-to"			
     			"-pgsync"
     			"-kill-wait"    ;; wait this long before removing test (default is 10 sec)
                             "-diff-html"
			"-diff-html"
     
     			;; wizards, area capture, setup new ...
     			"-extract-skeleton"
     			)
      		 (list  "-h" "-help" "--help"
     			"-manual"
     			"-version"
︙
702
703
704
705
706
707
708
709

710
711
712
713
714
715
716

703
704
705
706
707
708
709

710
711
712
713
714
715
716
717








-
+








     
     			;; misc
     			"-repl"
     			"-lock"
     			"-unlock"
     			"-list-servers"
     			"-kill-servers"
                             "-run-wait"      ;; wait on a run to complete (i.e. no RUNNING)
			"-run-wait"      ;; wait on a run to complete (i.e. no RUNNING)
     			"-one-pass"      ;;
     			"-local"         ;; run some commands using local db access
     			"-generate-html"
     			"-generate-html-structure" 
     			"-list-run-time"
                             "-list-test-time"
︙
1137
1138
1139
1140
1141
1142
1143


1144
1145
1146
1147
1148





1149
1150
1151
1152
1153
1154
1155

1138
1139
1140
1141
1142
1143
1144
1145
1146





1147
1148
1149
1150
1151
1152
1153
1154
1155
1156
1157
1158








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








     ;; Start the server - can be done in conjunction with -runall or -runtests (one day...)
     ;;   we start the server if not running else start the client thread
     ;;======================================================================
     
     ;; Server? Start up here.
     ;;
     (if (args:get-arg "-server")
	 (if  (not (args:get-arg "-db"))
	      (debug:print 0 *default-log-port* "ERROR: -db required to start server")
         (let ((tl        (launch:setup))
               (transport-type (string->symbol (or (args:get-arg "-transport") "http"))))
           (server:launch 0 transport-type)
           (set! *didsomething* #t)))
     
	      (let ((tl        (launch:setup))
		    (dbname    (args:get-arg "-db"))) ;; transport-type (string->symbol (or (args:get-arg "-transport") "http"))))
		(server:launch dbname)
		(set! *didsomething* #t))))
	 
     ;; The adjutant is a bit different, it does NOT run (launch:setup) as it is not necessarily tied to
     ;; a specific Megatest area. Detail are being hashed out and this may change.
     ;;
     (if (args:get-arg "-adjutant")
         (begin
           (adjutant-run)
           (set! *didsomething* #t)))
︙

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