Megatest

Check-in [2444b3e509]
Login
☰Home Timeline Files Branches Tags Tickets Wiki Login
Overview
Comment:Merged in 828d2
Downloads: Tarball | ZIP archive | SQL archive
Timelines: family | ancestors | descendants | both | v1.62-side
Files: files | file ages | folders
SHA1: 2444b3e509db9998fe720a13708ff26f83eaa4bf
User & Date: matt on 2016-11-04 20:02:43
Other Links: branch diff | manifest | tags
Context
2016-11-22
07:33
Merged in v1.62-side changes to get the efficient db sync check-in: ff1d02545b user: matt tags: v1.62-no-rpc
2016-11-04
20:02
Merged in 828d2 Closed-Leaf check-in: 2444b3e509 user: matt tags: v1.62-side
18:05
Merged in ba3d matt-db-sync-2 check-in: 0b35c5d875 user: matt tags: v1.62-side
2016-10-31
15:42
Added the refactored watchdog back check-in: 828d218b23 user: mrwellan tags: matt-db-sync-2, v1.62-side
Changes
Hide Diffs Side-by-Side Diffs Ignore Whitespace Patch

Modified common.scm from [87d206d15b] to [8c8d87c430].

︙
397
398
399
400
401
402
403
404
405


406
407
408
409
410

411
412
413
414
415
416
417

397
398
399
400
401
402
403


404
405
406
407
408
409

410
411
412
413
414
415
416
417








-
-
+
+




-
+








      (args:get-arg "-use-db-cache") ;; feels like a bad idea ...
      ))

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

;; run-ids
;;    if #f use *db-local-sync*
;;    if #t use timestamps
;;    if #f use *db-local-sync* : or 'local-sync-flags
;;    if #t use timestamps      : or 'timestamps
(define (common:sync-to-megatest.db run-ids) 
  (let ((start-time         (current-seconds))
        (run-ids-to-process (if (list? run-ids)
                                run-ids
                                (if run-ids
                                (if (or (eq? run-ids 'timestamps)(eq? run-ids #t))
                                    (db:get-changed-run-ids (let* ((mtdb-fpath (conc *toppath* "/megatest.db"))
                                                                   (mtdb-exists (file-exists? mtdb-fpath)))
                                                              (if mtdb-exists
                                                                  (file-modification-time mtdb-fpath)
                                                                  0)))
                                    (hash-table-keys *db-local-sync*)))))
    (debug:print-info 4 *default-log-port* "Processing run-ids: " run-ids-to-process)
︙
427
428
429
430
431
432
433
434

















435












436
437
438
439
440
441
442

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
456
457
458
459
460
461
462
463
464
465
466
467
468
469
470








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

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








               (debug:print-info 3 *default-log-port* "Sync of newdb to olddb for run-id " run-id " completed in " sync-time " seconds")
               (if (common:low-noise-print 30 "sync new to old")
                   (debug:print-info 0 *default-log-port* "Sync of newdb to olddb for run-id " run-id " completed in " sync-time " seconds")))
             (hash-table-delete! *db-local-sync* run-id)))
       (mutex-unlock! *db-multi-sync-mutex*))
     run-ids-to-process)))


(define (common:watchdog)
  (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 (or (common:legacy-sync-recommended)
	    legacy-sync)
	(let loop ()
	  ;; sync for filesystem local db writes
	  ;;
	  (let ((start-time   (current-seconds)))
	    (common:sync-to-megatest.db 'local-sync-flags)
	    (if (and debug-mode
		     (> (- start-time last-time) 60))
		(begin
		  (set! last-time start-time)
		  (debug:print-info 4 *default-log-port* "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 4)) ;; was 11, changing to 4. 
		    (begin
		      (thread-sleep! 1)
		      (delay-loop (+ count 1))))
		(loop)))
	  (if (common:low-noise-print 30)
	      (debug:print-info 0 *default-log-port* "Exiting watchdog timer, *time-to-exit* = " *time-to-exit*))))))

(define (std-exit-procedure)
  (let ((no-hurry  (if *time-to-exit* ;; hurry up
		       #f
		       (begin
			 (set! *time-to-exit* #t)
			 #t))))
︙

Modified dashboard.scm from [5cd5460f1b] to [e7351494c6].

︙
102
103
104
105
106
107
108









109
110
111
112
113
114
115

102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124








+
+
+
+
+
+
+
+
+









;; TODO: Move this inside (main)
;;
(if (not (launch:setup))
    (begin
      (print "Failed to find megatest.config, exiting") 
      (exit 1)))

;; create a watch dog to move changes from lt/.db/*.db to megatest.db
;;
(if (file-write-access? (conc *toppath* "/megatest.db"))
    (thread-start! (make-thread common:watchdog "Watchdog thread"))
    (if (not (args:get-arg "-use-db-cache"))
	(begin
	  (debug:print-info 0 *default-log-port* "Forcing db-cache mode due to read-only access to megatest.db")
	  (hash-table-set! args:arg-hash "-use-db-cache" #t))))

;; data common to all tabs goes here
;;
(defstruct dboard:commondat
  ((curr-tab-num 0) : number)
  please-update  
  tabdats
︙

Modified db.scm from [24c579194b] to [ca27c3f1d1].

︙
87
88
89
90
91
92
93


94


95
96
97
98
99
100

101
102
103
104
105
106
107

87
88
89
90
91
92
93
94
95

96
97
98
99
100
101
102

103
104
105
106
107
108
109
110








+
+
-
+
+





-
+








;;    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-db dbstruct run-id) 
  (if (sqlite3:database? dbstruct) ;; pass sqlite3 databases on through
      dbstruct
      (if (pair? dbstruct)
	  dbstruct                 ;; pass pair ( db . path ) on through
      (begin
	  (begin
	    ;; (assert (dbr:dbstruct? dbstruct)) ;; so much legacy, but by here we should have a genuine dbstruct
	(let ((dbdat (if (or (not run-id)
			     (eq? run-id 0))
			 (db:open-main dbstruct)
			 (db:open-rundb dbstruct run-id)
			 )))
	  dbdat))))
	      dbdat)))))

;; legacy handling of structure for managing db's. Refactor this into dbr:?
(define (db:dbdat-get-db dbdat)
  (if (pair? dbdat)
      (car dbdat)
      dbdat))
︙
334
335
336
337
338
339
340


341
342
343
344
345
346
347

337
338
339
340
341
342
343
344
345
346
347
348
349
350
351
352








+
+








(define (db:open-local-db-handle)
  (or *dbstruct-db*
      (let ((dbstruct (db:setup #f local: #t)))
	(set! *dbstruct-db* dbstruct)
	dbstruct)))
	  
;; Open the classic megatest.db file in toppath
;;
;;   NOTE: returns a dbdat not a dbstruct!
;;
(define (db:open-megatest-db #!key (path #f))
  (let* ((dbpath       (or path (conc *toppath* "/megatest.db")))
	 (dbexists     (file-exists? dbpath))
	 (db           (db:lock-create-open dbpath
					    (lambda (db)
					      (db:initialize-main-db db)
︙
826
827
828
829
830
831
832
833
834
835
836
837
838
839
840

831
832
833
834
835
836
837

838
839
840
841
842
843
844








-








  (if (eq? access-mode 'cached)
      (apply db:call-with-cached-db db-cmd params)
      (apply rmt-cmd params)))

;; return the target db handle so it can be used
;;
(define (db:cache-for-read-only source target #!key (use-last-update #f))
  ;; (common:sync-to-megatest.db #t) ;; BUG!! DON'T LEAVE THIS HERE!
  (if (and (hash-table-ref/default *global-db-store* target #f)
	   (>= (file-modification-time target)(file-modification-time source)))
      (hash-table-ref *global-db-store* target)
      (let* ((toppath   (launch:setup))
	     (targ-db-last-mod (if (file-exists? target)
				   (file-modification-time target)
				   0))
︙
854
855
856
857
858
859
860
861


862
863
864
865
866








867
868


869
870

871
872
873
874
875
876
877

858
859
860
861
862
863
864

865
866
867
868
869
870
871
872
873
874
875
876
877
878
879


880
881
882
883
884
885
886
887
888
889
890
891








-
+
+





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


+








(define (db:call-with-cached-db proc . params)
  ;; first cache the db in /tmp
  (let* ((cname-part (conc "megatest_cache/" (common:get-testsuite-name)))
	 (fname      (conc  (common:get-area-path-signature) ".db"))
	 (cache-dir  (common:get-create-writeable-dir
		      (list (conc "/tmp/" (current-user-name) "/" cname-part)
			    (conc "/tmp/" (current-user-name) "-" cname-part)
			    (conc "/tmp/" (current-user-name) "_" cname-part)))))
			     (conc "/tmp/" (current-user-name) "_" cname-part))))
	 (megatest-db (conc *toppath* "/megatest.db")))
    ;; (debug:print-info 0 *default-log-port* "Using cache dir " cache-dir)
    (if (not cache-dir)
	(begin
	  (debug:print 0 *default-log-port* "ERROR: Failed to find an area to write the cache db")
	  (exit 1))
	(let* ((th1      (make-thread
			  (lambda ()
			    (if (and (file-exists? megatest-db)
				     (file-write-access? megatest-db))
				(begin
				  (common:sync-to-megatest.db 'timestamps) ;; internally mutexes on *db-local-sync*
				  (debug:print-info 2 *default-log-port* "Done syncing to megatest.db"))))
			  "call-with-cached-db sync-to-megatest.db"))
	(let* ((cache-db (db:cache-for-read-only
			  (conc *toppath* "/megatest.db")
	       (cache-db (db:cache-for-read-only
			  megatest-db
			  (conc cache-dir "/" fname)
			  use-last-update: #t)))
	  (thread-start! th1)
	  (apply proc cache-db params)
	  ))))

;; options:
;;
;;  'killservers  - kills all servers
;;  'dejunk       - removes junk records
︙

Modified rmt.scm from [bc83a80b7d] to [c94a65eab6].

︙
241
242
243
244
245
246
247
248
249

250
251
252
253
254
255
256
257

241
242
243
244
245
246
247


248

249
250
251
252
253
254
255








-
-
+
-








	 (resdat         (if (not (and read-only qry-is-write))
			     (api:execute-requests dbstruct-local (vector (symbol->string cmd) params))
			     (vector #t '())))
	 (success        (vector-ref resdat 0))
	 (res            (vector-ref resdat 1))
	 (duration       (- (current-milliseconds) start)))
    (if (and read-only qry-is-write)
	(begin
	  (debug:print 0 *default-log-port* "ERROR: attempt to write to read-only database ignored. cmd=" cmd)
        (debug:print 0 *default-log-port* "ERROR: attempt to write to read-only database ignored. cmd=" cmd))
	  ))
    (if (not success)
	(if (> remretries 0)
	    (begin
	      (debug:print-error 0 *default-log-port* "local query failed. Trying again.")
	      (thread-sleep! (/ (random 5000) 1000)) ;; some random delay 
	      (rmt:open-qry-close-locally cmd run-id params remretries: (- remretries 1)))
	    (begin
︙

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