Megatest

Check-in [a1b0d55f23]
Login
Overview
Comment:Simplified triggering of sync
Downloads: Tarball | ZIP archive | SQL archive
Timelines: family | ancestors | descendants | both | v1.60
Files: files | file ages | folders
SHA1: a1b0d55f2385efd02952f6c5953a1a0f296c8918
User & Date: mrwellan on 2014-11-14 14:04:17
Other Links: branch diff | manifest | tags
Context
2014-11-14
20:54
streamline sync more check-in: 854b6c8345 user: matt tags: v1.60
14:04
Simplified triggering of sync check-in: a1b0d55f23 user: mrwellan tags: v1.60
07:50
Added removal of old tasks entries check-in: 9bebf08382 user: mrwellan tags: v1.60
Changes

Modified megatest.scm from [027a7b81ad] to [1795fd261c].

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

316
317
318
319
320
321
322
323
324
325
326
327
328
		 0))

;; The watchdog is to keep an eye on things like db sync etc.
;;
(define *watchdog*
  (make-thread 
   (lambda ()
     (thread-sleep! 0.5) ;; half second delay for startup
     (let loop ()
       ;; sync for filesystem local db writes
       ;;
       (let ((start-time      (current-seconds))
	     (servers-started (make-hash-table)))
	 (mutex-lock! *db-multi-sync-mutex*)
	 (for-each 
	  (lambda (run-id)

	    (let ((last-write (hash-table-ref/default *db-local-sync* run-id 0)))
	      (if (> (- start-time last-write) 5) ;; every five seconds
		  (let ((sync-time (- (current-seconds) start-time)))
		    (db:multi-db-sync (list run-id) 'new2old)
		    (if (common:low-noise-print 30 "sync new to old")
			(begin
			  (debug:print-info 0 "Sync of newdb to olddb for run-id " run-id " completed in " sync-time " seconds")
			  (if (and (> sync-time 10) ;; took more than ten seconds, start a server for this run
				   (hash-table-ref/default servers-started run-id #f))
			      (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)
				(hash-table-set! servers-started run-id #t)))))
		    (hash-table-delete! *db-local-sync* run-id)))))
	  (hash-table-keys *db-local-sync*))
	 (mutex-unlock! *db-multi-sync-mutex*))

       
       ;; keep going unless time to exit
       ;;
       (if (not *time-to-exit*)
	   (begin
	     (thread-sleep! 5) ;; five second resolution is only a minor burden and should be tolerable 
	     (loop)))))
   "Watchdog thread"))

(thread-start! *watchdog*)

(define (std-exit-procedure)
  (rmt:print-db-stats)







|





<


>
|
|
|
|
|
|
|
|
|
|
|
|
|
|
<
|
>
|




|







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
316
317
318
319
320
321
322
323
324
325
326
327
328
		 0))

;; The watchdog is to keep an eye on things like db sync etc.
;;
(define *watchdog*
  (make-thread 
   (lambda ()
     (thread-sleep! 0.05) ;; delay for startup
     (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 (hash-table-ref/default *db-local-sync* run-id 0)
		;; (if (> (- start-time last-write) 5) ;; every five seconds
		(let ((sync-time (- (current-seconds) start-time)))
		  (db:multi-db-sync (list run-id) 'new2old)
		  (if (common:low-noise-print 30 "sync new to old")
		      (begin
			(debug:print-info 0 "Sync of newdb to olddb for run-id " run-id " completed in " sync-time " seconds")
			(if (and (> sync-time 10) ;; took more than ten seconds, start a server for this run
				 (hash-table-ref/default servers-started run-id #f))
			    (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)
			      (hash-table-set! servers-started run-id #t)))))
		  (hash-table-delete! *db-local-sync* run-id)))

	    (mutex-unlock! *db-multi-sync-mutex*))
	  (hash-table-keys *db-local-sync*)))

       ;; keep going unless time to exit
       ;;
       (if (not *time-to-exit*)
	   (begin
	     (thread-sleep! 1) ;; wait one second before syncing again
	     (loop)))))
   "Watchdog thread"))

(thread-start! *watchdog*)

(define (std-exit-procedure)
  (rmt:print-db-stats)
1374
1375
1376
1377
1378
1379
1380
1381
1382
1383
1384
1385
1386
1387
1388
    (begin
      (db:multi-db-sync 
       #f ;; do all run-ids
       'killservers
       'dejunk
       'adj-testids
       'old2new
       'new2old
       )
      (set! *didsomething* #t)))

(if (args:get-arg "-sync-to-megatest.db")
    (begin
      (db:multi-db-sync 
       #f ;; do all run-ids







|







1374
1375
1376
1377
1378
1379
1380
1381
1382
1383
1384
1385
1386
1387
1388
    (begin
      (db:multi-db-sync 
       #f ;; do all run-ids
       'killservers
       'dejunk
       'adj-testids
       'old2new
       ;; 'new2old
       )
      (set! *didsomething* #t)))

(if (args:get-arg "-sync-to-megatest.db")
    (begin
      (db:multi-db-sync 
       #f ;; do all run-ids

Modified rmt.scm from [79ec3bfb22] to [6409627d1a].

184
185
186
187
188
189
190
191

192
193
194
195
196
197
198
199
	   (res           (api:execute-requests dbstruct-local (symbol->string cmd) params))
	   (duration      (- (current-milliseconds) start)))
      (rmt:update-db-stats run-id cmd params duration)
      ;; mark this run as dirty if this was a write
      (if (not (member cmd api:read-only-queries))
	  (let ((start-time (current-seconds)))
	    (mutex-lock! *db-multi-sync-mutex*)
	    (if (not (hash-table-ref/default *db-local-sync* run-id #f))

		(hash-table-set! *db-local-sync* run-id start-time)) ;; the oldest "write"
	    (mutex-unlock! *db-multi-sync-mutex*)))
      res)))

(define (rmt:send-receive-no-auto-client-setup connection-info cmd run-id params)
  (let* ((run-id   (if run-id run-id 0))
	 (jparams         (db:obj->string params)) ;; (rmt:dat->json-str params))
	 (res (http-transport:client-api-send-receive run-id connection-info cmd jparams)))







|
>
|







184
185
186
187
188
189
190
191
192
193
194
195
196
197
198
199
200
	   (res           (api:execute-requests dbstruct-local (symbol->string cmd) params))
	   (duration      (- (current-milliseconds) start)))
      (rmt:update-db-stats run-id cmd params duration)
      ;; mark this run as dirty if this was a write
      (if (not (member cmd api:read-only-queries))
	  (let ((start-time (current-seconds)))
	    (mutex-lock! *db-multi-sync-mutex*)
	    ;; (if (not (hash-table-ref/default *db-local-sync* run-id #f))
	    ;; just set it every time. Is a write more expensive than a read and does it matter?
	    (hash-table-set! *db-local-sync* run-id start-time) ;; the oldest "write"
	    (mutex-unlock! *db-multi-sync-mutex*)))
      res)))

(define (rmt:send-receive-no-auto-client-setup connection-info cmd run-id params)
  (let* ((run-id   (if run-id run-id 0))
	 (jparams         (db:obj->string params)) ;; (rmt:dat->json-str params))
	 (res (http-transport:client-api-send-receive run-id connection-info cmd jparams)))