164
165
166
167
168
169
170
171
172
173
174
175
176
177
178
179
180
181
182
183
184
185
186
187
188
189
190
191
|
164
165
166
167
168
169
170
171
172
173
174
175
176
177
178
179
180
181
182
183
184
185
186
187
188
189
190
191
192
193
194
195
196
197
|
+
+
+
-
-
-
-
+
+
+
+
+
+
+
-
-
-
-
-
-
-
+
+
+
+
+
+
+
|
;; (if (eq? run-id 0)
;; (server:run run-id)
;; (rmt:start-server run-id)))
(define server:try-running server:run) ;; there is no more per-run servers ;; REMOVE ME. BUG.
(define (server:start-attempted? areapath)
(let ((flagfile (conc areapath "/.starting-server")))
(handle-exceptions
exn
#f ;; if things go wrong pretend we can't see the file
(and (file-exists? flagfile)
(< (- (current-seconds)
(file-modification-time flagfile))
15)))) ;; exists and less than 15 seconds old
(and (file-exists? flagfile)
(< (- (current-seconds)
(file-modification-time flagfile))
15))))) ;; exists and less than 15 seconds old
(define (server:read-dotserver areapath)
(let ((dotfile (conc areapath "/.server")))
(handle-exceptions
exn
#f ;; if things go wrong pretend we can't see the file
(if (and (file-exists? dotfile)
(file-read-access? dotfile))
(with-input-from-file
dotfile
(lambda ()
(read-line)))
#f)))
(if (and (file-exists? dotfile)
(file-read-access? dotfile))
(with-input-from-file
dotfile
(lambda ()
(read-line)))
#f))))
;; write a .server file in *toppath* with hostport
;; return #t on success, #f otherwise
;;
(define (server:write-dotserver areapath hostport)
(let ((lock-file (conc areapath "/.server.lock"))
(server-file (conc areapath "/.server")))
|
231
232
233
234
235
236
237
238
239
240
241
242
243
244
245
246
247
248
249
250
251
252
253
254
255
256
257
258
259
260
261
262
263
264
265
266
267
|
237
238
239
240
241
242
243
244
245
246
247
248
249
250
251
252
253
254
255
256
257
258
259
260
261
262
263
264
265
266
267
268
269
270
271
272
273
274
275
276
277
278
279
280
|
-
-
+
+
+
+
+
+
+
+
+
-
-
-
-
+
+
+
+
-
+
-
+
|
#f)))
;; called in megatest.scm, host-port is string hostname:port
;;
;; NOTE: This is NOT called directly from clients as not all transports support a client running
;; in the same process as the server.
;;
(define (server:ping host:port)
(let ((tdbdat (tasks:open-db)))
(define (server:ping host-port-in #!key (do-exit #f))
(let ((host:port (if (number? host-port-in) ;; we were handed a server-id
(let ((srec (tasks:get-server-by-id (db:delay-if-busy (tasks:open-db)) host-port-in)))
;; (print "srec: " srec " host-port-in: " host-port-in)
(if srec
(conc (vector-ref srec 3) ":" (vector-ref srec 4))
(conc "no such server-id " host-port-in)))
host-port-in)))
(let* ((host-port (let ((slst (string-split host:port ":")))
(if (eq? (length slst) 2)
(list (car slst)(string->number (cadr slst)))
#f)))
(toppath (launch:setup)))
;; (print "host-port=" host-port)
(if (not host-port)
(begin
(print "ERROR: bad host:port")
(exit 1))
(let* ((iface (if host-port (car host-port) (tasks:hostinfo-get-interface server-db-dat)))
(port (if host-port (cadr host-port)(tasks:hostinfo-get-port server-db-dat)))
(debug:print 0 *default-log-port* "ERROR: bad host:port")
(if do-exit (exit 1)))
(let* ((iface (car host-port))
(port (cadr host-port))
(server-dat (http-transport:client-connect iface port))
(login-res (rmt:login-no-auto-client-setup server-dat)))
(if (and (list? login-res)
(car login-res))
(begin
(print "LOGIN_OK")
(exit 0))
(if do-exit (exit 0)))
(begin
(print "LOGIN_FAILED")
(exit 1))))))))
(if do-exit (exit 1)))))))))
;; run ping in separate process, safest way in some cases
;;
(define (server:ping-server ifaceport)
(with-input-from-pipe
(conc (common:get-megatest-exe) " -ping " ifaceport)
(lambda ()
|