| ︙ | | | ︙ | |
25
26
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
|
(include "db_records.scm")
(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)
(iface (if (string=? "-" hostn)
"*" ;; (get-host-name)
hostn))
(hostname (get-host-name))
(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 iface zmq-socket 5555 0))
(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
|
>
>
|
>
>
>
|
25
26
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
|
(include "db_records.scm")
(define (server:make-server-url hostport)
(if (not hostport)
#f
(conc "tcp://" (car hostport) ":" (cadr hostport))))
(define *server-loop-heart-beat* (list 'start (current-seconds)))
(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)
(iface (if (string=? "-" hostn)
"*" ;; (get-host-name)
hostn))
(hostname (get-host-name))
(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 iface zmq-socket 5555 0))
(set! zmq-socket (server:find-free-port-and-open ipaddrstr zmq-socket (if (args:get-arg "-port")
(string->number (args:get-arg "-port"))
5555)
0))
(set! *cache-on* #t)
;; what to do when we quit
;;
(on-exit (lambda ()
(if (and *toppath* *server-id*)
(begin
|
| ︙ | | | ︙ | |
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
|
(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))
(debug:print-info 12 "server=> received params=" params)
(set! res (cdb:cached-access params))
(debug:print-info 12 "server=> processed res=" res)
(send-message zmq-socket (db:obj->string res))
(if (not *time-to-exit*)
(loop)
(begin
|
>
>
>
>
>
>
>
>
|
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
|
(begin
(debug:print-info 0 "Queue not flushed, waiting ...")
(loop))))))))
;; The heavy lifting
;;
(let loop ()
;; Ugly yuk.
(mutex-lock! *incoming-mutex*)
(set! *server-loop-heart-beat* (list 'waiting (current-seconds)))
(mutex-unlock! *incoming-mutex*)
(let* ((rawmsg (receive-message* zmq-socket))
(params (db:string->obj rawmsg)) ;; (with-input-from-string rawmsg (lambda ()(deserialize))))
(res #f))
;;; Ugly yuk.
(mutex-lock! *incoming-mutex*)
(set! *server-loop-heart-beat* (list 'working (current-seconds)))
(mutex-unlock! *incoming-mutex*)
(debug:print-info 12 "server=> received params=" params)
(set! res (cdb:cached-access params))
(debug:print-info 12 "server=> processed res=" res)
(send-message zmq-socket (db:obj->string res))
(if (not *time-to-exit*)
(loop)
(begin
|
| ︙ | | | ︙ | |
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
|
;; server last used then start shutdown
(let loop ((count 0))
(thread-sleep! 3) ;; no need to do this very often
(db:write-cached-data)
;; (print "Server running, count is " count)
(if (< count 2) ;; 3x3 = 9 secs aprox
(loop (+ count 1))
(let ((numrunning (open-run-close db:get-count-tests-running #f)))
(open-run-close tasks:server-update-heartbeat tasks:open-db *server-id*)
(if (or (> numrunning 0) ;; stay alive for two days after last access
(> (+ *last-db-access* (* 48 60 60))(current-seconds)))
(begin
(debug:print-info 2 "Server continuing, tests running: " numrunning ", seconds since last db access: " (- (current-seconds) *last-db-access*))
(loop 0))
(begin
(debug:print-info 0 "Starting to shutdown the server.")
|
|
>
>
>
>
>
>
>
>
>
>
>
|
>
|
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
|
;; server last used then start shutdown
(let loop ((count 0))
(thread-sleep! 3) ;; no need to do this very often
(db:write-cached-data)
;; (print "Server running, count is " count)
(if (< count 2) ;; 3x3 = 9 secs aprox
(loop (+ count 1))
(let ((numrunning (open-run-close db:get-count-tests-running #f))
(server-loop-heartbeat #f))
;;; Ugly yuk.
(mutex-lock! *incoming-mutex*)
(set! server-loop-heartbeat *server-loop-heart-beat*)
(mutex-unlock! *incoming-mutex*)
;; The logic here is that if the server loop gets stuck blocked in working
;; we don't want to update our heartbeat
(let ((server-state (car server-loop-heartbeat))
(server-update (cadr server-loop-heartbeat)))
(if (or (eq? server-state 'waiting)
(< (- (current-seconds) server-update) 10))
(open-run-close tasks:server-update-heartbeat tasks:open-db *server-id*)
(debug:print "ERROR: No heartbeat update, server appears stuck")))
(if (or (> numrunning 0) ;; stay alive for two days after last access
(> (+ *last-db-access* (* 48 60 60))(current-seconds)))
(begin
(debug:print-info 2 "Server continuing, tests running: " numrunning ", seconds since last db access: " (- (current-seconds) *last-db-access*))
(loop 0))
(begin
(debug:print-info 0 "Starting to shutdown the server.")
|
| ︙ | | | ︙ | |
170
171
172
173
174
175
176
177
178
179
180
181
182
183
184
|
(define (server:client-logout zmq-socket)
(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
|
|
|
195
196
197
198
199
200
201
202
203
204
205
206
207
208
209
|
(define (server:client-logout zmq-socket)
(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 50)(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
|
| ︙ | | | ︙ | |
210
211
212
213
214
215
216
217
218
219
220
221
222
223
224
|
(if (> numtries 0)
(let ((exe (car (argv))))
(debug:print-info 1 "No server available, attempting to start one...")
(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))))
|
|
|
235
236
237
238
239
240
241
242
243
244
245
246
247
248
249
|
(if (> numtries 0)
(let ((exe (car (argv))))
(debug:print-info 1 "No server available, attempting to start one...")
(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 attempts, giving up")))))
(define (server:launch)
(if (not *toppath*)
(if (not (setup-for-run))
(begin
(debug:print 0 "ERROR: cannot find megatest.config, exiting")
(exit))))
|
| ︙ | | | ︙ | |