34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
|
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
|
+
-
+
|
(declare (uses tests))
(declare (uses tasks)) ;; tasks are where stuff is maintained about what is running.
(declare (uses server))
;; (declare (uses daemon))
(declare (uses portlogger))
(declare (uses rmt))
(declare (uses dbfile))
(declare (uses commonmod))
(include "common_records.scm")
(include "db_records.scm")
(include "js-path.scm")
(import dbfile)
(import dbfile commonmod)
(require-library stml)
(define (http-transport:make-server-url hostport)
(if (not hostport)
#f
(conc "http://" (car hostport) ":" (cadr hostport))))
|
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
|
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
|
+
+
-
-
+
+
-
-
-
+
+
+
-
-
-
-
-
-
+
+
+
+
+
+
-
+
-
+
|
(if (debug:debug-mode 1)
(debug:print-info 0 *default-log-port* "couldn't talk to server, trying again ...")
(begin
(debug:print 0 *default-log-port* "WARNING: failure in with-input-from-request to " fullurl ".")
(debug:print 0 *default-log-port* " message: " msg ", exn=" exn)
(debug:print 0 *default-log-port* " cmd: " cmd " params: " params " key:" (or server-id "thekey"))
(debug:print 0 *default-log-port* " call-chain: " call-chain)))
(set! *runremote* #f)
(set! runremote #f)
(if runremote
(remote-conndat-set! runremote #f))
;;; (signal (make-composite-condition
;;; (make-property-condition 'commfail 'message "failed to connect to server")))
;;; "communications failed"
;; (signal (make-composite-condition
;; (make-property-condition 'commfail 'message "failed to connect to server")))
;; "communications failed"
(db:obj->string #f))
(with-input-from-request ;; was dat
fullurl
(list (cons 'key (or server-id "thekey"))
(cons 'cmd cmd)
(cons 'params sparams))
read-string))
(with-input-from-request ;; was dat
fullurl
(list (cons 'key (or server-id "thekey"))
(cons 'cmd cmd)
(cons 'params sparams))
read-string))
transport: 'http)
0)) ;; added this speculatively
(close-all-connections!)
(close-all-connections!) ;; BUG? WHY IS THIS HERE? Are we failing to reuse connections?
(mutex-unlock! *http-mutex*)
))
(time-out (lambda ()
(thread-sleep! 45)
(debug:print 0 *default-log-port* "WARNING: send-receive took more than 45 seconds!!")
#f))
(th1 (make-thread send-recieve "with-input-from-request"))
|
550
551
552
553
554
555
556
557
558
559
560
561
562
563
564
565
|
553
554
555
556
557
558
559
560
561
562
563
564
565
566
567
568
569
570
571
572
|
+
-
-
+
+
+
+
+
|
(current-seconds)))
(if (common:low-noise-print 120 "server continuing")
(debug:print-info 0 *default-log-port* "Server continuing, seconds since last db access: " (- (current-seconds) last-access))
(let ((curr-time (current-seconds)))
(handle-exceptions
exn
(debug:print 0 *default-log-port* "ERROR: Failed to change timestamp on log file " server-log-file ". Are you out of space on that disk? exn=" exn)
(if (and (< (- (current-seconds) server-start-time) 600) ;; run for ten minutes for experiment, 3600 thereafter
(if (not *server-overloaded*)
(change-file-times server-log-file curr-time curr-time)))))
(not *server-overloaded*))
(change-file-times server-log-file curr-time curr-time)
(if (common:low-noise-print 120 "start new server")
(server:kind-run *toppath*) ;; server:kind-run uses [servers] numservers
)))))
(loop 0 server-state bad-sync-count (current-milliseconds)))
(else
(debug:print-info 0 *default-log-port* "Server timed out. seconds since last db access: " (- (current-seconds) last-access))
(http-transport:server-shutdown port)))))))
(define (http-transport:server-shutdown port)
(begin
|