134
135
136
137
138
139
140
141
142
143
144
145
146
147
148
149
150
151
152
153
|
134
135
136
137
138
139
140
141
142
143
144
145
146
147
148
149
150
151
152
153
154
155
156
157
158
159
160
161
|
+
+
+
-
-
-
-
-
-
+
+
+
+
+
+
+
+
+
+
+
|
;;
(define (tt:handler ttdat cmd run-id params attemptnum area-dat areapath readonly-mode dbfname testsuite mtexe)
;; NOTE: areapath is passed in and in tt struct. We'll use passed in value for now.
(let* ((conn (tt:client-connect-to-server ttdat dbfname run-id))) ;; (hash-table-ref/default (tt-conns ttdat) dbfname #f)))
(if conn
;; have connection, call the server
(let* ((res (tt:send-receive ttdat conn cmd run-id params)))
;; res is (status errmsg result meta)
(match res
((status errmsg result meta)
(cond
((member res '(busy starting))
(thread-sleep! 1)
(tt:handler ttdat cmd run-id params attemptnum area-dat areapath readonly-mode dbfname testsuite mtexe))
(else
res)))
(case status
((busy)
(debug:print 0 *default-log-port* "WARNING: server is overloaded, will try again in few seconds.")
(thread-sleep! 2)
(tt:handler ttdat cmd run-id params attemptnum area-dat areapath readonly-mode dbfname testsuite mtexe))
((loaded)
(debug:print 0 *default-log-port* "WARNING: server is loaded, will try again in a second.")
(thread-sleep! 1)
(tt:handler ttdat cmd run-id params attemptnum area-dat areapath readonly-mode dbfname testsuite mtexe))
(else
result)))))
(begin
(thread-sleep! 1) ;; give it a rest and try again
(tt:handler ttdat cmd run-id params attemptnum area-dat areapath readonly-mode dbfname testsuite mtexe)))))
;; no conn yet, find and or start and find a server
;; (let* ((server (tt:find-server ttdat dbfname)))
;; (if server
|
254
255
256
257
258
259
260
261
262
263
264
265
266
267
|
262
263
264
265
266
267
268
269
270
271
272
273
274
275
276
277
|
+
+
|
;; now start watching the last-access, if it hasn't been touched
;; in over ten seconds we exit
(let loop ()
(if (< (- (current-seconds) (tt-last-access ttdat)) 10)
(begin
(thread-sleep! 2)
(loop))))
(if (tt-cleanup-proc ttdat)
((tt-cleanup-proc ttdat)))
(debug:print 0 *default-log-port* "INFO: Server timed out, exiting."))
;; ;; given an already set up uconn start the cmd-loop
;; ;;
;; (define (tt:cmd-loop ttdat)
;; (let* ((serv-listener (-socket uconn))
;; (listener (lambda ()
|