| ︙ | | |
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
|
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
|
-
+
+
|
(lambda (run-id)
(let ((connection (common:get-remote remote run-id)))
(if (and (vector? connection)
(< (http-transport:server-dat-get-last-access connection) expire-time))
(begin
(debug:print-info 0 "Discarding connection to server for run-id " run-id ", too long between accesses")
;; SHOULD CLOSE THE CONNECTION HERE
(case *transport-type*
(case (megatest:area-transport area-dat)
((nmsg)(nn-close (http-transport:server-dat-get-socket
(common:get-remote remote run-id)))))
(common:del-remote! remote run-id)))))
(common:get-remote-all remote)))
(mutex-unlock! *db-multi-sync-mutex*))
(define *send-receive-mutex* (make-mutex)) ;; should have separate mutex per run-id
(define (rmt:send-receive cmd rid params area-dat #!key (attemptnum 1)(remote #f)) ;; start attemptnum at 1 so the modulo below works as expected
(rmt:discard-old-connections area-dat)
;; (mutex-lock! *send-receive-mutex*)
(let* ((run-id (if rid rid 0))
(configdat (megatest:area-configdat area-dat))
(connection-info (rmt:get-connection-info run-id area-dat)))
;; the nmsg method does the encoding under the hood (the http method should be changed to do this also)
(if connection-info
;; use the server if have connection info
(let* ((dat (case *transport-type*
((http)(condition-case
(http-transport:client-api-send-receive run-id connection-info cmd params)
|
| ︙ | | |
151
152
153
154
155
156
157
158
159
160
161
162
163
164
165
|
152
153
154
155
156
157
158
159
160
161
162
163
164
165
166
|
-
+
|
;; no connection info? try to start a server, or access locally if no
;; server and the query is read-only
;;
;; Note: The tasks db was checked for a server in starting mode in the rmt:get-connection-info call
;;
(if (and (< attemptnum 15)
(member cmd api:write-queries))
(let ((faststart (configf:lookup *configdat* "server" "faststart")))
(let ((faststart (configf:lookup configdat "server" "faststart")))
(common:del-remote! remote run-id)
;; (mutex-unlock! *send-receive-mutex*)
(if (and faststart (equal? faststart "no"))
(begin
(tasks:start-and-wait-for-server (db:delay-if-busy (tasks:open-db)) run-id 10)
(thread-sleep! (random 5)) ;; give some time to settle and minimize collison?
(rmt:send-receive cmd rid params area-dat attemptnum: (+ attemptnum 1)))
|
| ︙ | | |
189
190
191
192
193
194
195
196
197
198
199
200
201
202
203
|
190
191
192
193
194
195
196
197
198
199
200
201
202
203
204
|
-
+
|
(hash-table-set! *db-stats* cmd newvec)
(set! stat-vec newvec)))
(vector-set! stat-vec 0 (+ (vector-ref stat-vec 0) 1))
(vector-set! stat-vec 1 (+ (vector-ref stat-vec 1) duration))))
(mutex-unlock! *db-stats-mutex*))
(define (rmt:print-db-stats)
(define (rmt:print-db-stats area-dat)
(let ((fmtstr "~40a~7-d~9-d~20,2-f")) ;; "~20,2-f"
(debug:print 18 "DB Stats\n========")
(debug:print 18 (format #f "~40a~8a~10a~10a" "Cmd" "Count" "TotTime" "Avg"))
(for-each (lambda (cmd)
(let ((cmd-dat (hash-table-ref *db-stats* cmd)))
(debug:print 18 (format #f fmtstr cmd (vector-ref cmd-dat 0) (vector-ref cmd-dat 1) (/ (vector-ref cmd-dat 1)(vector-ref cmd-dat 0))))))
(sort (hash-table-keys *db-stats*)
|
| ︙ | | |
229
230
231
232
233
234
235
236
237
238
239
240
241
242
243
|
230
231
232
233
234
235
236
237
238
239
240
241
242
243
244
|
-
+
|
(loop (car tal)(cdr tal) newmax-cmd currmax)))))))
(mutex-unlock! *db-stats-mutex*)
res))
(define (rmt:open-qry-close-locally cmd run-id params #!key (remretries 5))
(let* ((dbstruct-local (if *dbstruct-db*
*dbstruct-db*
(let* ((dbdir (db:dbfile-path #f)) ;; (conc (configf:lookup *configdat* "setup" "linktree") "/.db"))
(let* ((dbdir (db:dbfile-path #f))
(db (make-dbr:dbstruct path: dbdir local: #t)))
(set! *dbstruct-db* db)
db)))
(db-file-path (db:dbfile-path 0))
;; (read-only (not (file-read-access? db-file-path)))
(start (current-milliseconds))
(resdat (api:execute-requests dbstruct-local (vector (symbol->string cmd) params)))
|
| ︙ | | |
308
309
310
311
312
313
314
315
316
317
318
319
320
321
322
323
324
325
326
327
328
329
330
331
|
309
310
311
312
313
314
315
316
317
318
319
320
321
322
323
324
325
326
327
328
329
330
331
332
333
334
|
-
-
+
+
-
-
-
-
+
+
+
+
+
+
|
(define (rmt:start-server run-id)
(rmt:send-receive 'start-server 0 (list run-id) area-dat))
;;======================================================================
;; M I S C
;;======================================================================
(define (rmt:login run-id)
(rmt:send-receive 'login run-id (list *toppath* megatest-version run-id *my-client-signature*) area-dat))
(define (rmt:login run-id area-dat)
(rmt:send-receive 'login run-id (list (megatest:area-path area-dat) megatest-version run-id *my-client-signature*) area-dat))
;; This login does no retries under the hood - it acts a bit like a ping.
;; Deprecated for nmsg-transport.
;;
(define (rmt:login-no-auto-client-setup connection-info run-id)
(case *transport-type*
((http)(rmt:send-receive-no-auto-client-setup connection-info 'login run-id (list *toppath* megatest-version run-id *my-client-signature*) area-dat))
((nmsg)(nmsg-transport:client-api-send-receive run-id connection-info 'login (list *toppath* megatest-version run-id *my-client-signature*) area-dat))))
(define (rmt:login-no-auto-client-setup connection-info run-id area-dat)
(let ((transport (megatest:area-transport area-dat))
(toppath (megatest:area-path area-dat)))
(case transport
((http)(rmt:send-receive-no-auto-client-setup connection-info 'login run-id (list toppath megatest-version run-id *my-client-signature*) area-dat))
((nmsg)(nmsg-transport:client-api-send-receive run-id connection-info 'login (list toppath megatest-version run-id *my-client-signature*) area-dat)))))
;; hand off a call to one of the db:queries statements
;; added run-id to make looking up the correct db possible
;;
(define (rmt:general-call stmtname run-id area-dat . params)
(rmt:send-receive 'general-call run-id (append (list stmtname run-id) params) area-dat))
|
| ︙ | | |