87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
|
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
|
-
+
|
(if (> retrynum 0)
(begin
(debug:print 0 *default-log-port* "WARNING: Failed to connect to server (self) on host " hostn ":" start-port ", trying again.")
(tasks:server-delete-record (db:delay-if-busy tdbdat) server-id "failed to start, never received server alive signature")
(portlogger:open-run-close portlogger:set-failed start-port)
(nmsg-transport:run dbstruct hostn run-id server-id))
(begin
(debug:print 0 *default-log-port* "ERROR: could not find an open port to start server on. Giving up")
(debug:print-error 0 *default-log-port* "could not find an open port to start server on. Giving up")
(exit 1))))))
(define (nmsg-transport:try-start-server dbstruct run-id portnum server-id)
(let ((repsoc (nn-socket 'rep)))
(nn-bind repsoc (conc "tcp://*:" portnum))
(let loop ((msg-in (nn-recv repsoc)))
(let* ((dat (db:string->obj msg-in transport: 'nmsg)))
|
238
239
240
241
242
243
244
245
246
247
248
249
250
251
252
|
238
239
240
241
242
243
244
245
246
247
248
249
250
251
252
|
-
+
|
(if success (thread-terminate! timeout)))
;; raise timeout error if timed out
(if success
(if (and (vector? result)
(vector-ref result 0)) ;; did it fail at the server?
result ;; nope, all good
(begin
(debug:print 0 *default-log-port* "ERROR: error occured at server, info=" (vector-ref result 2))
(debug:print-error 0 *default-log-port* "error occured at server, info=" (vector-ref result 2))
(debug:print 0 *default-log-port* " client call chain:")
(print-call-chain (current-error-port))
(debug:print 0 *default-log-port* " server call chain:")
(pp (vector-ref result 1) (current-error-port))
(signal (vector-ref result 0))))
(signal (make-composite-condition
(make-property-condition 'timeout 'message "nmsg-transport:client-api-send-receive-raw timed out talking to server"))))))
|
343
344
345
346
347
348
349
350
351
352
353
354
355
356
357
358
|
343
344
345
346
347
348
349
350
351
352
353
354
355
356
357
358
|
-
+
|
exn
(debug:print 0 *default-log-port* " ... exiting ...")
(let ((th1 (make-thread (lambda ()
(if (not *received-response*)
(receive-message* *runremote*))) ;; flush out last call if applicable
"eat response"))
(th2 (make-thread (lambda ()
(debug:print 0 *default-log-port* "ERROR: Received ^C, attempting clean exit. Please be patient and wait a few seconds before hitting ^C again.")
(debug:print-error 0 *default-log-port* "Received ^C, attempting clean exit. Please be patient and wait a few seconds before hitting ^C again.")
(thread-sleep! 3) ;; give the flush three seconds to do it's stuff
(debug:print 0 *default-log-port* " Done.")
(exit 4))
"exit on ^C timer")))
(thread-start! th2)
(thread-start! th1)
(thread-join! th2))))
|