140
141
142
143
144
145
146
147
148
149
150
151
152
153
154
|
140
141
142
143
144
145
146
147
148
149
150
151
152
153
154
|
-
+
|
(mutex-lock! *heartbeat-mutex*)
(set! server-loop-heartbeat *server-loop-heart-beat*)
(set! server-info *server-info*)
(mutex-unlock! *heartbeat-mutex*)
;; The logic here is that if the server loop gets stuck blocked in working
;; we don't want to update our heartbeat
(set! pulse (- (current-seconds) server-loop-heartbeat))
(debug:print-info 1 "Heartbeat period is " pulse " seconds on " (cadr server-info) ":" (caddr server-info) ", last db access is " (- (current-seconds) *last-db-access*) " seconds ago")
(debug:print-info 2 "Heartbeat period is " pulse " seconds on " (cadr server-info) ":" (caddr server-info) ", last db access is " (- (current-seconds) *last-db-access*) " seconds ago")
(if (> pulse 15) ;; must stay less than 10 seconds
(begin
(open-run-close tasks:server-deregister tasks:open-db (cadr server-info) port: (caddr server-info))
(debug:print 0 "ERROR: Heartbeat failed, committing servercide")
(exit))
(open-run-close tasks:server-update-heartbeat tasks:open-db (car server-info)))
;; (if ;; (or (> numrunning 0) ;; stay alive for two days after last access
|
208
209
210
211
212
213
214
215
216
217
218
219
220
221
222
|
208
209
210
211
212
213
214
215
216
217
218
219
220
221
222
|
-
+
|
(if *my-client-signature* *my-client-signature*
(let ((sig (server:mk-signature)))
(set! *my-client-signature* sig)
*my-client-signature*)))
;;
(define (server:client-connect iface port #!key (context #f))
(debug:print 3 "client-connect " iface ":" port)
(debug:print-info 3 "client-connect " iface ":" port)
(let ((connect-ok #f)
(zmq-socket (if context
(make-socket 'req context)
(make-socket 'req)))
(conurl (server:make-server-url (list iface port))))
(if (socket? zmq-socket)
(begin
|
284
285
286
287
288
289
290
291
292
293
294
295
296
297
298
|
284
285
286
287
288
289
290
291
292
293
294
295
296
297
298
|
-
+
|
;; all routes though here end in exit ...
(define (server:launch)
(if (not *toppath*)
(if (not (setup-for-run))
(begin
(debug:print 0 "ERROR: cannot find megatest.config, exiting")
(exit))))
(debug:print-info 0 "Starting the standalone server")
(debug:print-info 1 "Starting the standalone server")
(let ((hostinfo (open-run-close tasks:get-best-server tasks:open-db)))
(if hostinfo
(debug:print-info 1 "NOT starting new server, one is already running on " (car hostinfo) ":" (cadr hostinfo))
(if *toppath*
(let* ((th1 (make-thread (lambda ()
(let ((server-info #f))
;; wait for the server to be online and available
|