42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
|
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
|
-
+
|
(debug:print 4 "server:self-ping - I'm alive on " iface ":" port "!")
(mutex-lock! *heartbeat-mutex*)
(set! *server-loop-heart-beat* (current-seconds))
(mutex-unlock! *heartbeat-mutex*)
(loop))))
(define (server:run hostn)
(debug:print 0 "Attempting to start the server ...")
(debug:print 2 "Attempting to start the server ...")
(if (not *toppath*)
(if (not (setup-for-run))
(begin
(debug:print 0 "ERROR: cannot find megatest.config, cannot start server, exiting")
(exit))))
(let* ((zmq-socket #f)
(zmq-socket-dat #f)
|
123
124
125
126
127
128
129
130
131
132
133
134
135
136
|
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
|
+
+
+
|
;; run server:keep-running in a parallel thread to monitor that the db is being
;; used and to shutdown after sometime if it is not.
;;
(define (server:keep-running)
;; if none running or if > 20 seconds since
;; server last used then start shutdown
;; (let ((die-timeout (
(let loop ((count 0))
(thread-sleep! 4) ;; no need to do this very often
(db:write-cached-data)
;; (print "Server running, count is " count)
(if (< count 1) ;; 3x3 = 9 secs aprox
(loop (+ count 1))
(let (;; (numrunning (open-run-close db:get-count-tests-running #f))
|
151
152
153
154
155
156
157
158
159
160
161
162
163
164
165
166
167
|
154
155
156
157
158
159
160
161
162
163
164
165
166
167
168
169
170
|
-
+
-
+
|
(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
(if (> (+ *last-db-access*
;; (* 48 60 60) ;; 48 hrs
(* 70 60 60) ;; 70 hrs is enough that the server will still be available after the weekend
;; 60 ;; one minute
(* 60 60) ;; one hour
;; (* 60 60) ;; one hour
)
(current-seconds))
(begin
;; (debug:print-info 2 "Server continuing, tests running: " numrunning ", seconds since last db access: " (- (current-seconds) *last-db-access*))
(debug:print-info 2 "Server continuing, seconds since last db access: " (- (current-seconds) *last-db-access*))
(loop 0))
(begin
|
186
187
188
189
190
191
192
193
194
195
196
197
198
199
200
201
202
203
|
189
190
191
192
193
194
195
196
197
198
199
200
201
202
203
204
205
206
|
-
+
-
+
|
;; (old-handler)
;; (print-call-chain)
(if (> trynum 0)
(server:find-free-port-and-open iface s (+ p 1) trynum: (- trynum 1))
(debug:print-info 0 "Tried ports up to " p
" but all were in use. Please try a different port range by starting the server with parameter \" -port N\" where N is the starting port number to use")))
(let ((zmq-url (conc "tcp://" iface ":" p)))
(print "Trying to start server on " zmq-url)
(debug:print 2 "Trying to start server on " zmq-url)
(bind-socket s zmq-url)
(set! *runremote* #f)
(debug:print 0 "Server started on " zmq-url)
(debug:print 2 "Server started on " zmq-url)
(mutex-lock! *heartbeat-mutex*)
(set! *server-info* (open-run-close tasks:server-register tasks:open-db (current-process-id) iface p 0 'live))
(mutex-unlock! *heartbeat-mutex*)
(list iface s port)))))
(define (server:mk-signature)
(message-digest-string (md5-primitive)
|
271
272
273
274
275
276
277
278
279
280
281
282
283
284
285
286
287
288
289
290
291
292
293
294
295
296
297
298
299
300
301
302
303
304
305
306
307
308
309
310
311
312
313
314
315
|
274
275
276
277
278
279
280
281
282
283
284
285
286
287
288
289
290
291
292
293
294
295
296
297
298
299
300
301
302
303
304
305
306
307
308
309
310
311
312
313
314
315
316
317
318
319
320
321
322
|
-
+
+
+
+
+
-
+
-
+
-
+
-
+
|
#t)
(begin
(debug:print-info 2 "Failed to login or connect to " conurl)
(set! *runremote* #f)
#f)))))
(if (> numtries 0)
(let ((exe (car (argv))))
(debug:print-info 1 "No server available, attempting to start one...")
(debug:print-info 2 "No server available, attempting to start one...")
(process-run exe (list "-server" "-" "-debug" (conc *verbosity*)))
;; (process-fork (lambda ()
;; (server:launch)
;; (exit) ;; should never get here ....
;; ))
(sleep 5) ;; give server time to start
;; we are starting a server, do not try again! That can lead to
;; recursively starting many processes!!!
(server:client-setup numtries: 0))
(debug:print-info 1 "Too many attempts, giving up")))))
;; 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 1 "Starting the standalone server")
(debug:print-info 2 "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))
(debug:print-info 2 "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
(let loop ()
(debug:print-info 1 "Waiting for the server to come online before starting heartbeat")
(debug:print-info 2 "Waiting for the server to come online before starting heartbeat")
(thread-sleep! 2)
(mutex-lock! *heartbeat-mutex*)
(set! server-info *server-info* )
(mutex-unlock! *heartbeat-mutex*)
(if (not server-info)(loop)))
(debug:print 1 "Server alive, starting self-ping")
(debug:print 2 "Server alive, starting self-ping")
(server:self-ping (cadr server-info)(caddr server-info)))) "Self ping"))
(th2 (make-thread (lambda ()
(server:run (args:get-arg "-server"))) "Server run"))
(th3 (make-thread (lambda ()
(server:keep-running)) "Keep running")))
(set! *client-non-blocking-mode* #t)
(thread-start! th1)
|