27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
|
(define (server:make-server-url hostport)
(if (not hostport)
#f
(conc "tcp://" (car hostport) ":" (cadr hostport))))
(define (server:run hostn)
(debug:print 0 "Attempting to start the server ...")
(if (not *toppath*)(setup-for-run))
(let* ((zmq-socket #f)
(hostname (if (string=? "-" hostn)
(get-host-name)
hostn))
(ipaddrstr (let ((ipstr (if (string=? "-" hostn)
(string-intersperse (map number->string (u8vector->list (hostname->ip hostname))) ".")
#f)))
(if ipstr ipstr hostname))))
(set! zmq-socket (server:find-free-port-and-open ipaddrstr zmq-socket 5555 0))
(set! *cache-on* #t)
;; what to do when we quit
;;
(on-exit (lambda ()
(open-run-close tasks:server-deregister-self tasks:open-db #f)
(let loop ()
(let ((queue-len 0))
(thread-sleep! (random 5))
(mutex-lock! *incoming-mutex*)
(set! queue-len (length *incoming-data*))
(mutex-unlock! *incoming-mutex*)
(if (> queue-len 0)
(begin
(debug:print-info 0 "Queue not flushed, waiting ...")
(loop)))))))
;; The heavy lifting
;;
(let loop ()
(let* ((rawmsg (receive-message* zmq-socket))
(params (db:string->obj rawmsg)) ;; (with-input-from-string rawmsg (lambda ()(deserialize))))
(res #f))
|
|
>
>
>
>
>
>
|
|
|
|
|
|
|
|
|
|
|
|
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
|
(define (server:make-server-url hostport)
(if (not hostport)
#f
(conc "tcp://" (car hostport) ":" (cadr hostport))))
(define (server:run hostn)
(debug:print 0 "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)
(hostname (if (string=? "-" hostn)
(get-host-name)
hostn))
(ipaddrstr (let ((ipstr (if (string=? "-" hostn)
(string-intersperse (map number->string (u8vector->list (hostname->ip hostname))) ".")
#f)))
(if ipstr ipstr hostname))))
(set! zmq-socket (server:find-free-port-and-open ipaddrstr zmq-socket 5555 0))
(set! *cache-on* #t)
;; what to do when we quit
;;
(on-exit (lambda ()
(if (and *toppath* *server-id*)
(begin
(open-run-close tasks:server-deregister-self tasks:open-db #f))
(let loop ()
(let ((queue-len 0))
(thread-sleep! (random 5))
(mutex-lock! *incoming-mutex*)
(set! queue-len (length *incoming-data*))
(mutex-unlock! *incoming-mutex*)
(if (> queue-len 0)
(begin
(debug:print-info 0 "Queue not flushed, waiting ...")
(loop))))))))
;; The heavy lifting
;;
(let loop ()
(let* ((rawmsg (receive-message* zmq-socket))
(params (db:string->obj rawmsg)) ;; (with-input-from-string rawmsg (lambda ()(deserialize))))
(res #f))
|
160
161
162
163
164
165
166
167
168
169
170
171
172
173
174
|
(let ((ok (and (socket? zmq-socket)
(cdb:logout zmq-socket *toppath* (server:get-client-signature)))))
;; (close-socket zmq-socket)
ok))
;; Do all the connection work, start a server if not already running
(define (server:client-setup #!key (numtries 10)(do-ping #f))
(if (not *toppath*)(setup-for-run))
(let ((hostinfo (open-run-close tasks:get-best-server tasks:open-db do-ping: do-ping)))
(if hostinfo
(let ((host (car hostinfo))
(port (cadr hostinfo)))
;; (zsocket (caddr hostinfo)))
;; (set! *runremote* zsocket))
(let* ((host (car hostinfo))
|
|
>
>
>
>
|
166
167
168
169
170
171
172
173
174
175
176
177
178
179
180
181
182
183
184
|
(let ((ok (and (socket? zmq-socket)
(cdb:logout zmq-socket *toppath* (server:get-client-signature)))))
;; (close-socket zmq-socket)
ok))
;; Do all the connection work, start a server if not already running
(define (server:client-setup #!key (numtries 10)(do-ping #f))
(if (not *toppath*)
(if (not (setup-for-run))
(begin
(debug:print 0 "ERROR: failed to find megatest.config, exiting")
(exit))))
(let ((hostinfo (open-run-close tasks:get-best-server tasks:open-db do-ping: do-ping)))
(if hostinfo
(let ((host (car hostinfo))
(port (cadr hostinfo)))
;; (zsocket (caddr hostinfo)))
;; (set! *runremote* zsocket))
(let* ((host (car hostinfo))
|
201
202
203
204
205
206
207
208
209
210
211
212
213
214
215
216
217
218
219
220
221
222
223
224
225
226
227
228
229
|
(process-run exe (list "-server" "-" "-debug" (conc *verbosity*)))
(sleep 2)
;; not doing ping, assume the server started and registered itself
(server:client-setup numtries: (- numtries 1) do-ping: #f))
(debug:print-info 1 "Too many retries, giving up")))))
(define (server:launch)
(let* ((toppath (setup-for-run)))
(debug:print-info 0 "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* ((th2 (make-thread (lambda ()
(server:run (args:get-arg "-server")))))
(th3 (make-thread (lambda ()
(server:keep-running)))))
(thread-start! th2)
(thread-start! th3)
(set! *didsomething* #t)
(thread-join! th3))
(debug:print 0 "ERROR: Failed to setup for megatest"))))))
|
>
|
>
>
>
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
211
212
213
214
215
216
217
218
219
220
221
222
223
224
225
226
227
228
229
230
231
232
233
234
235
236
237
238
239
240
241
242
243
|
(process-run exe (list "-server" "-" "-debug" (conc *verbosity*)))
(sleep 2)
;; not doing ping, assume the server started and registered itself
(server:client-setup numtries: (- numtries 1) do-ping: #f))
(debug:print-info 1 "Too many retries, giving up")))))
(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")
(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* ((th2 (make-thread (lambda ()
(server:run (args:get-arg "-server")))))
(th3 (make-thread (lambda ()
(server:keep-running)))))
(thread-start! th2)
(thread-start! th3)
(set! *didsomething* #t)
(thread-join! th3))
(debug:print 0 "ERROR: Failed to setup for megatest")))))
(define (server:client-launch #!key (do-ping #f))
(if (server:client-setup do-ping: do-ping)
(debug:print-info 2 "connected as client")
(begin
(debug:print 0 "ERROR: Failed to connect as client")
(exit))))
|