Megatest

Check-in [edc56c4136]
Login
☰Home Timeline Files Branches Tags Tickets Wiki Login
Overview
Comment:99.8%
Downloads: Tarball | ZIP archive | SQL archive
Timelines: family | ancestors | descendants | both | v1.60
Files: files | file ages | folders
SHA1: edc56c413631fd52f4d05c274d494f28e6311912
User & Date: matt on 2014-11-12 22:40:10
Other Links: branch diff | manifest | tags
Context
2014-11-12
23:21
Update schema creation to allow retrying to create schema check-in: 483e2bb5d3 user: matt tags: v1.60
22:40
99.8% check-in: edc56c4136 user: matt tags: v1.60
21:51
99.5% done with protecting db access with journal check check-in: 6757cdb9b3 user: matt tags: v1.60
Changes
Hide Diffs Side-by-Side Diffs Ignore Whitespace Patch

Modified db.scm from [71a8762428] to [9f448022ca].

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









179
180
181
182
183
184
185

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
174
175
176
177
178







179
180
181
182
183
184
185
186
187
188
189
190
191
192
193
194








+
-
+
-












-
+












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








      (let ((db (sqlite3:open-database fname)))
	(sqlite3:set-busy-handler! db (make-busy-timeout 136000))
	(sqlite3:execute db "PRAGMA synchronous = 0;")
	db)
      (let* ((parent-dir   (pathname-directory fname))
	     (dir-writable (file-write-access? parent-dir)))
	(if dir-writable
	    (let ((exists  (file-exists? fname))
	    (let ((lock    (obtain-dot-lock fname 1 5 10))
		  (lock    (obtain-dot-lock fname 1 5 10))
		  (exists  (file-exists? fname))
		  (db      (sqlite3:open-database fname)))
	      (sqlite3:set-busy-handler! db (make-busy-timeout 136000))
	      (sqlite3:execute db "PRAGMA synchronous = 0;")
	      (if (not exists)(initproc db))
	      (release-dot-lock fname)
	      db)
	    (begin
	      (debug:print 0 "ERROR: no such db in non-writable dir " fname)
	      (sqlite3:open-database fname))))))

;; This routine creates the db. It is only called if the db is not already opened
;; 
(define (db:open-rundb dbstruct run-id) ;;  (conc *toppath* "/megatest.db") (car *configinfo*)))
(define (db:open-rundb dbstruct run-id #!key (attemptnum 0)) ;;  (conc *toppath* "/megatest.db") (car *configinfo*)))
  (let* ((local  (dbr:dbstruct-get-local dbstruct))
	 (rdb    (if local
		     (dbr:dbstruct-get-localdb dbstruct run-id)
		     (dbr:dbstruct-get-inmem dbstruct)))) ;; (dbr:dbstruct-get-runrec dbstruct run-id 'inmem)))
    (if rdb
	rdb
	(let* ((dbpath       (db:dbfile-path run-id)) ;; (conc toppath "/db/" run-id ".db"))
	       (dbexists     (file-exists? dbpath))
	       (inmem        (if local #f (db:open-inmem-db)))
	       (refdb        (if local #f (db:open-inmem-db)))
	       (db           (db:lock-create-open dbpath 
						  (lambda (db)
						    (handle-exceptions
						     exn
						     (begin
						       (release-dot-lock dbpath)
						       (if (> attemptnum 2)
							   (debug:print 0 "ERROR: tried twice, cannot create/initialize db for run-id " run-id ", at path " dbpath)
							   (db:open-rundb dbstruct run-id attemptnum (+ attemptnum 1))))
						    (db:initialize-run-id-db db)
						    (sqlite3:execute 
						     db
						     "INSERT OR IGNORE INTO tests (id,run_id,testname,event_time,item_path,state,status) VALUES (?,?,'bogustest',strftime('%s','now'),'nowherepath','DELETED','n/a');"
						     (* run-id 30000) ;; allow for up to 30k tests per run
						     run-id)
						    ))) ;; add strings db to rundb, not in use yet
						     (db:initialize-run-id-db db)
						     (sqlite3:execute 
						      db
						      "INSERT OR IGNORE INTO tests (id,run_id,testname,event_time,item_path,state,status) VALUES (?,?,'bogustest',strftime('%s','now'),'nowherepath','DELETED','n/a');"
						      (* run-id 30000) ;; allow for up to 30k tests per run
						      run-id)
						     ;; do a dummy query to test that the table exists and the db is truly readable
						     (sqlite3:execute db "SELECT * FROM tests WHERE id=?;" (* run-id 30000))
						    )))) ;; add strings db to rundb, not in use yet
	       ;;   )) ;; (sqlite3:open-database dbpath))
	       (olddb        (if *megatest-db*
				 *megatest-db* 
				 (let ((db (db:open-megatest-db)))
				   (set! *megatest-db* db)
				   db)))
	       (write-access (file-write-access? dbpath))
︙

Modified http-transport.scm from [8d5a62d976] to [b0912eff93].

︙
274
275
276
277
278
279
280
281

282
283
284

285
286
287
288
289
290
291

274
275
276
277
278
279
280

281
282
283

284
285
286
287
288
289
290
291








-
+


-
+








       (let* ((send-recieve (lambda ()
			      (mutex-lock! *http-mutex*)
			      ;; (condition-case (with-input-from-request "http://localhost"; #f read-lines)
			      ;;					       ((exn http client-error) e (print e)))
			      (set! res (handle-exceptions
					 exn
					 (begin
					   (debug:print 0 "WARNING: failure in with-input-from-request to " fullrul ". Killing associated server to allow clean retry.")
					   (debug:print 0 "WARNING: failure in with-input-from-request to " fullurl ". Killing associated server to allow clean retry.")
					   (debug:print 0 " message: " ((condition-property-accessor 'exn 'message) exn))
					   (hash-table-delete! *runremote* run-id)
					   (tasks:kill-server-run-id run-id)
					   ;; (tasks:kill-server-run-id run-id)  ;; better to kill the server in the logic that called this routine.
					   #f)
					 (with-input-from-request ;; was dat
					  fullurl 
					  (list (cons 'key "thekey")
						(cons 'cmd cmd)
						(cons 'params params))
					  read-string)))
︙

Modified rmt.scm from [3dfb2ffd80] to [9406211371].

︙
54
55
56
57
58
59
60
61

62
63
64
65
66
67
68

54
55
56
57
58
59
60

61
62
63
64
65
66
67
68








-
+








	       (debug:print-info 1 "db write rate too high, starting a server, count=" count " start=" start " run-id=" run-id " queries-per-second=" queries-per-second)
	       #t)
	     #f))))

;; cmd is a symbol
;; vars is a json string encoding the parameters for the call
;;
(define (rmt:send-receive cmd rid params)
(define (rmt:send-receive cmd rid params #!key (attemptnum 0))
  ;; clean out old connections
  (mutex-lock! *db-multi-sync-mutex*)
  (let ((expire-time (- (current-seconds) 60)))
    (for-each 
     (lambda (run-id)
       (let ((connection (hash-table-ref/default *runremote* run-id #f)))
	 (if ;; (and connection
︙
91
92
93
94
95
96
97






98

99
100
101
102
103
104
105

91
92
93
94
95
96
97
98
99
100
101
102
103

104
105
106
107
108
109
110
111








+
+
+
+
+
+
-
+








	(let ((res             (http-transport:client-api-send-receive run-id connection-info cmd jparams)))
	  (http-transport:server-dat-update-last-access connection-info)
	  (if res
	      (db:string->obj res)
	      (let ((new-connection-info (client:setup run-id)))
		(debug:print 0 "WARNING: Communication failed, trying call to http-transport:client-api-send-receive again.")
		(hash-table-delete! *runremote* run-id) ;; don't keep using the same connection

		;; no longer killing the server in http-transport:client-api-send-receive
		;; may kill it here but what are the criteria?
		;; start with three calls then kill server
		(if (eq? attemptnum 3)(tasks:kill-server-run-id run-id))

		(rmt:send-receive cmd run-id params))))
		(rmt:send-receive cmd run-id params attemptnum: (+ attemptnum 1)))))
	(let ((max-avg-qry (string->number (or (configf:lookup *configdat* "server" "server-query-threshold") "10"))))
	  (debug:print-info 4 "no server and read-only query, bypassing normal channel")
	  ;; (if (rmt:write-frequency-over-limit? cmd run-id)(server:kind-run run-id))
	  (let ((curr-max (rmt:get-max-query-average run-id)))
	    (if (> (cdr curr-max) max-avg-qry)
		(if (common:low-noise-print 10 "start server due to max average query too long")
		      (begin
︙

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