Megatest

Check-in [4579b102a3]
Login
☰Home Timeline Files Branches Tags Tickets Wiki Login
Overview
Comment:Check for sync in progress before even launching megatest -db2db
Downloads: Tarball | ZIP archive | SQL archive
Timelines: family | ancestors | descendants | both | v1.80
Files: files | file ages | folders
SHA1: 4579b102a3de00b92a59488d0b3b53ee850b9713
User & Date: matt on 2023-05-21 20:44:08
Other Links: branch diff | manifest | tags
Context
2023-05-22
05:04
Removed attempt to exit server on handler failure. It did not seem to be working. check-in: 47cfd09de7 user: matt tags: v1.80
2023-05-21
20:44
Check for sync in progress before even launching megatest -db2db check-in: 4579b102a3 user: matt tags: v1.80
07:44
Added timed ping but not used yet for throttling. check-in: 99d5a8b353 user: matt tags: v1.80
Changes
Hide Diffs Unified Diffs Ignore Whitespace Patch

Modified dbmod.scm from [a718e7bdcb] to [6d9a7a8b67].

︙︙
206
207
208
209
210
211
212
213
214
215
216
217
218


219

220
221
222
223

224
225
226
227
228
229
230












231
232
233
234
235
236
237
238

    (dbr:dbstruct-dbtmpname-set! dbstruct tmpdb)
    (dbr:dbstruct-dbfname-set!   dbstruct dbfname)
    (dbr:dbstruct-sync-proc-set! dbstruct
				 (lambda (last-update)
				   (if *sync-in-progress*
				       (debug:print 3 *default-log-port* "WARNING: overlapping calls to sync to disk")
				       (let* ((sync-cmd (conc "megatest -db2db -from "tmpdb" -to "dbfullname"&"))
					      (synclock-file (conc dbfullname".sync-lock")))
					 ;; (mutex-lock! *db-with-db-mutex*) ;; this mutex is used when overloaded or during a query that modifies the db
					 ;; (if (eq? (dbfile:cache-method) 'cachedb)
					 ;;     (dbmod:sync-gasket tables last-update cachedb db
					 ;; 			dbfullname syncdir keys)
					 (if (< (file-modification-time tmpdb)


						(file-modification-time dbfullname))

					     (debug:print 0 *default-log-port* "Skipping sync, "tmpdb" older than "dbfullname)
					     (if (file-exists? synclock-file)
						 (debug:print 0 *default-log-port* "Skipping sync, lockfile "synclock-file" found.")
						 (thread-start! (make-thread

								 (lambda ()
								   (set! *sync-in-progress* #t)
								   (debug:print-info "Running "sync-cmd)
								   (system sync-cmd)
								   ;; (mutex-unlock! *db-with-db-mutex*)
								   ;; (thread-sleep! 0.5) ;; ensure at least 1/2 second down time between sync calls
								   (set! *sync-in-progress* #f))))))












					 ))))
    ;; (dbmod:sync-tables tables #f db cachedb)
    ;; (if db
    (dbmod:sync-gasket tables #f cachedb db dbfullname 'fromdest keys) ;; ) ;; load into cachedb
    (dbr:dbstruct-last-update-set! dbstruct (current-seconds)) ;; should this be offset back in time by one second?
    dbstruct))

;;    (if (eq? syncdir 'todisk) ;; sync to disk normally, sync from in dashboard








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








206
207
208
209
210
211
212
213

214


215
216
217
218
219
220


221
222
223
224
225
226


227
228
229
230
231
232
233
234
235
236
237
238
239
240
241
242
243
244
245
246
247

    (dbr:dbstruct-dbtmpname-set! dbstruct tmpdb)
    (dbr:dbstruct-dbfname-set!   dbstruct dbfname)
    (dbr:dbstruct-sync-proc-set! dbstruct
				 (lambda (last-update)
				   (if *sync-in-progress*
				       (debug:print 3 *default-log-port* "WARNING: overlapping calls to sync to disk")
				       (let* ((sync-cmd (conc "megatest -db2db -from "tmpdb" -to "dbfullname"&"))
					      (synclock-file     (conc dbfullname".sync-lock"))

					      (synclock-mod-time (if (file-exists? synclock-file)


								     (handle-exceptions
									 exn
								       #f
								       (file-modification-time synclock-file))
								     #f))
					      (thethread         (lambda ()


								   (thread-start!
								    (make-thread
								     (lambda ()
								       (set! *sync-in-progress* #t)
								       (debug:print-info "Running "sync-cmd)
								       (system sync-cmd)


								       (set! *sync-in-progress* #f)))))))
					 (if (< (file-modification-time tmpdb)
						(file-modification-time dbfullname))
					     (debug:print 0 *default-log-port* "Skipping sync, "tmpdb" older than "dbfullname)
					     (if synclock-mod-time
						 (if (< (- (current-seconds) synclock-mod-time) 20) ;; something wrong with sync, remove file
						     (begin
						       (handle-exceptions
							   exn
							 #f
							 (delete-file synclock-file))
						       (thethread))
						     (debug:print 0 *default-log-port* "Skipping sync, lockfile "synclock-file" found."))
						 (thethread)))))))
    ;; (dbmod:sync-tables tables #f db cachedb)
    ;; (if db
    (dbmod:sync-gasket tables #f cachedb db dbfullname 'fromdest keys) ;; ) ;; load into cachedb
    (dbr:dbstruct-last-update-set! dbstruct (current-seconds)) ;; should this be offset back in time by one second?
    dbstruct))

;;    (if (eq? syncdir 'todisk) ;; sync to disk normally, sync from in dashboard
︙︙

Modified tcp-transportmod.scm from [e72475ef7d] to [02829c3b33].

︙︙
160
161
162
163
164
165
166
167
168
169
170
171
172
173
174

			   server-id: server-id
			   server-start: start-time
			   pid: pid)))
	       ;; verify we can talk to this server
	       (let* ((result   (tt:timed-ping host port server-id))
		      (ping-res (car result))
		      (ping     (cdr result)))
                 (debug:print-info 0 *default-log-port* "ping time:" ping)
		 (case ping-res
		   ((running)
		    (hash-table-set! (tt-conns ttdat) dbfname conn) ;;; is this ok to save before validating that the connection is good?
		    conn)
		   ((starting)
		    (thread-sleep! 0.5)
		    (tt:client-connect-to-server ttdat dbfname run-id testsuite))








|








160
161
162
163
164
165
166
167
168
169
170
171
172
173
174

			   server-id: server-id
			   server-start: start-time
			   pid: pid)))
	       ;; verify we can talk to this server
	       (let* ((result   (tt:timed-ping host port server-id))
		      (ping-res (car result))
		      (ping     (cdr result)))
                 (debug:print-info 0 *default-log-port* "ping time: " ping)
		 (case ping-res
		   ((running)
		    (hash-table-set! (tt-conns ttdat) dbfname conn) ;;; is this ok to save before validating that the connection is good?
		    conn)
		   ((starting)
		    (thread-sleep! 0.5)
		    (tt:client-connect-to-server ttdat dbfname run-id testsuite))
︙︙
732
733
734
735
736
737
738

739
740
741
742
743
744
745
746



747
748
749
750
751
752
753

(define  (tt:server-process-run areapath testsuite mtexe run-id #!key (profile-mode "")) ;; areapath is *toppath* for a given testsuite area
  (assert areapath  "FATAL: tt:server-process-run called without areapath defined.")
  (assert testsuite "FATAL: tt:server-process-run called without testsuite defined.")
  (assert mtexe     "FATAL: tt:server-process-run called without mtexe defined.")
  ;; mtest -server - -m testsuite:ext-tests -db 6.db
  (let* ((dbfname  (dbmod:run-id->dbfname run-id))
	 (load     (get-normalized-cpu-load))

	 (nrun     (number-of-processes-running (conc "mtest.*server.*"testsuite".*"dbfname))))
    (cond
     ((> load 2.0)
      (debug:print 0 *default-log-port* "Normalized load "load" on " (get-host-name) " is over the limit of 2.0. Not starting a server.")
      (thread-sleep! 1))
     ((> nrun 100)
      (debug:print 0 *default-log-port* nrun" servers running on " (get-host-name) ", not starting another.")
      (thread-sleep! 1))



     (else
      (if (not (file-exists? (conc areapath"/logs")))
	      (create-directory (conc areapath"/logs") #t))
	  (let* ((logfile   (conc areapath "/logs/server-"dbfname"-"(current-process-id)".log")) ;; -" curr-pid "-" target-host ".log"))
		 (cmdln     (conc
			     mtexe
			     " -server - ";; (or target-host "-")








>








>
>
>








732
733
734
735
736
737
738
739
740
741
742
743
744
745
746
747
748
749
750
751
752
753
754
755
756
757

(define  (tt:server-process-run areapath testsuite mtexe run-id #!key (profile-mode "")) ;; areapath is *toppath* for a given testsuite area
  (assert areapath  "FATAL: tt:server-process-run called without areapath defined.")
  (assert testsuite "FATAL: tt:server-process-run called without testsuite defined.")
  (assert mtexe     "FATAL: tt:server-process-run called without mtexe defined.")
  ;; mtest -server - -m testsuite:ext-tests -db 6.db
  (let* ((dbfname  (dbmod:run-id->dbfname run-id))
	 (load     (get-normalized-cpu-load))
	 (trying   (length (tt:find-server areapath dbfname)))
	 (nrun     (number-of-processes-running (conc "mtest.*server.*"testsuite".*"dbfname))))
    (cond
     ((> load 2.0)
      (debug:print 0 *default-log-port* "Normalized load "load" on " (get-host-name) " is over the limit of 2.0. Not starting a server.")
      (thread-sleep! 1))
     ((> nrun 100)
      (debug:print 0 *default-log-port* nrun" servers running on " (get-host-name) ", not starting another.")
      (thread-sleep! 1))
     ((> trying 4)
      (debug:print 0 *default-log-port* trying" servers registered in .servinfo dir. not starting another.")
      (thread-sleep! 1))
     (else
      (if (not (file-exists? (conc areapath"/logs")))
	      (create-directory (conc areapath"/logs") #t))
	  (let* ((logfile   (conc areapath "/logs/server-"dbfname"-"(current-process-id)".log")) ;; -" curr-pid "-" target-host ".log"))
		 (cmdln     (conc
			     mtexe
			     " -server - ";; (or target-host "-")
︙︙

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