32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
|
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
|
-
+
|
(include "db_records.scm")
(define (http-transport:make-server-url hostport)
(if (not hostport)
#f
(conc "http://" (car hostport) ":" (cadr hostport))))
(define *server-loop-heart-beat* (current-seconds))
(define *server-loop-heart-beat* (current-seconds))
(define *heartbeat-mutex* (make-mutex))
;;======================================================================
;; S E R V E R
;;======================================================================
;; Call this to start the actual server
|
211
212
213
214
215
216
217
218
219
220
221
222
223
224
225
|
211
212
213
214
215
216
217
218
219
220
221
222
223
224
225
|
-
+
|
(set! res (with-input-from-request
fullurl
(list (cons 'dat msg))
read-string))
(close-all-connections!)
(mutex-unlock! *http-mutex*)))
(time-out (lambda ()
(thread-sleep! 5)
(thread-sleep! 45)
(if (not res)
(begin
(debug:print 0 "WARNING: communication with the server timed out.")
(mutex-unlock! *http-mutex*)
(http-transport:client-send-receive serverdat msg numretries: (- numretries 1))
(if (< numretries 3) ;; on last try just exit
(begin
|
313
314
315
316
317
318
319
320
321
322
323
324
325
326
327
328
329
330
|
313
314
315
316
317
318
319
320
321
322
323
324
325
326
327
328
329
330
331
|
+
-
-
+
+
-
+
|
(tasks:server-update-heartbeat tdb spid)
;; (if ;; (or (> numrunning 0) ;; stay alive for two days after last access
(mutex-lock! *heartbeat-mutex*)
(set! last-access *last-db-access*)
(mutex-unlock! *heartbeat-mutex*)
;; (debug:print 11 "last-access=" last-access ", server-timeout=" server-timeout)
(if (and *server-run*
(if (> (+ last-access server-timeout)
(current-seconds))
(debug:print-info 2 "Server continuing, seconds since last db access: " (- (current-seconds) last-access))
(debug:print-info 0 "Server continuing, seconds since last db access: " (- (current-seconds) last-access))
(loop 0))
(begin
(debug:print-info 0 "Starting to shutdown the server.")
;; need to delete only *my* server entry (future use)
(set! *time-to-exit* #t)
(open-run-close tasks:server-deregister-self tasks:open-db (get-host-name))
(thread-sleep! 1)
|