67
68
69
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
95
96
97
98
99
100
101
102
103
104
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
|
(debug:print 2 "Attempting to start the server ...")
(let* ((start-port (portlogger:open-run-close portlogger:find-port))
(server-thread (make-thread (lambda ()
(nmsg-transport:try-start-server dbstruct run-id start-port server-id))
"server thread"))
(tdbdat (tasks:open-db)))
(thread-start! server-thread)
(if (nmsg-transport:ping hostn start-port timeout: 2 expected-key: (current-process-id))
(let ((interface (if (equal? hostn "-")(get-host-name) hostn)))
(tasks:server-set-interface-port (db:delay-if-busy tdbdat) server-id interface start-port)
(tasks:server-set-state! (db:delay-if-busy tdbdat) server-id "dbprep")
(set! *server-info* (list hostn start-port)) ;; probably not needed anymore? currently used by keep-running
(thread-sleep! 3) ;; give some margin for queries to complete before switching from file based access to server based access
(set! *inmemdb* dbstruct)
(tasks:server-set-state! (db:delay-if-busy tdbdat) server-id "running")
(thread-start! (make-thread
(lambda ()(nmsg-transport:keep-running server-id run-id))
"keep running"))
(thread-join! server-thread))
(if (> retrynum 0)
(begin
(debug:print 0 "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 "ERROR: 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)))
(cond
((equal? msg-in "quit")
(nn-send repsoc "Ok, quitting"))
((and (>= (string-length msg-in) 4)
(equal? (substring msg-in 0 4) "ping"))
(nn-send repsoc (conc (current-process-id)))
(loop (nn-recv repsoc)))
(else
(let* ((dat (db:string->obj msg-in transport: 'nmsg))
(cmd (vector-ref dat 0))
(params (vector-ref dat 1))
(result (api:execute-requests dbstruct cmd params))
(newdat (db:obj->string result transport: 'nmsg)))
(nn-send repsoc newdat)
(loop (nn-recv repsoc))))))))
;; all routes though here end in exit ...
;;
(define (nmsg-transport:launch run-id)
(let* ((tdbdat (tasks:open-db))
(dbstruct (db:setup run-id))
(hostn (or (args:get-arg "-server") "-")))
(set! *run-id* run-id)
;; with nbfake daemonize isn't really needed
;;
;; (if (args:get-arg "-daemonize")
;; (begin
;; (daemon:ize)
;; (if *alt-log-file* ;; we should re-connect to this port, I think daemon:ize disrupts it
;; (begin
|
>
|
<
<
<
<
<
<
<
<
|
<
<
>
|
<
>
|
|
<
>
|
67
68
69
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
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
|
(debug:print 2 "Attempting to start the server ...")
(let* ((start-port (portlogger:open-run-close portlogger:find-port))
(server-thread (make-thread (lambda ()
(nmsg-transport:try-start-server dbstruct run-id start-port server-id))
"server thread"))
(tdbdat (tasks:open-db)))
(thread-start! server-thread)
(thread-sleep! 0.1)
(if (nmsg-transport:ping hostn start-port timeout: 2 expected-key: (current-process-id))
(let ((interface (if (equal? hostn "-")(get-host-name) hostn)))
(tasks:server-set-interface-port (db:delay-if-busy tdbdat) server-id interface start-port)
(tasks:server-set-state! (db:delay-if-busy tdbdat) server-id "dbprep")
(set! *server-info* (list hostn start-port)) ;; probably not needed anymore? currently used by keep-running
(thread-sleep! 3) ;; give some margin for queries to complete before switching from file based access to server based access
;; (set! *inmemdb* dbstruct)
(tasks:server-set-state! (db:delay-if-busy tdbdat) server-id "running")
(thread-start! (make-thread
(lambda ()(nmsg-transport:keep-running server-id run-id))
"keep running"))
(thread-join! server-thread))
(if (> retrynum 0)
(begin
(debug:print 0 "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 "ERROR: 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)))
(debug:print 0 "server, received: " dat)
(let ((result (api:execute-requests dbstruct dat)))
(debug:print 0 "server, sending: " result)
(nn-send repsoc (db:obj->string result transport: 'nmsg)))
(loop (nn-recv repsoc))))))
;; all routes though here end in exit ...
;;
(define (nmsg-transport:launch run-id)
(let* ((tdbdat (tasks:open-db))
(dbstruct (db:setup run-id))
(hostn (or (args:get-arg "-server") "-")))
(set! *run-id* run-id)
(set! *inmemdb* dbstruct)
;; with nbfake daemonize isn't really needed
;;
;; (if (args:get-arg "-daemonize")
;; (begin
;; (daemon:ize)
;; (if *alt-log-file* ;; we should re-connect to this port, I think daemon:ize disrupts it
;; (begin
|
182
183
184
185
186
187
188
189
190
191
192
193
194
195
196
197
198
199
200
201
202
203
204
205
206
207
208
209
210
211
212
213
214
215
216
217
218
219
220
221
222
223
224
225
226
227
228
229
230
231
232
233
234
235
236
237
238
239
240
241
242
243
244
245
246
247
248
|
(equal? hostn "-")) ;; use localhost
(get-host-name)
hostn))
(req (or socket
(let ((soc (nn-socket 'req)))
(nn-connect soc (conc "tcp://" host ":" port))
soc)))
(dat (db:obj->string (vector "ping" our-key) transport: 'nmsg))
(result (nmsg-transport:client-api-send-receive-raw req dat timeout: timeout))
(success (vector-ref result 0))
(key (if success
(vector-ref (db:string->obj (vector-ref result 1) transport: 'nmsg) 1)
#f)))
(debug:print 0 "success=" success ", key=" key ", expected-key=" expected-key ", equal? " (equal? key expected-key))
(if (and success
(or (not expected-key) ;; just getting a reply is good enough then
(equal? key expected-key)))
(if return-socket
req
(begin
(if (not socket)(nn-close req)) ;; don't want a side effect of closing socket if handed it
#t))
(begin
(if (not socket)(nn-close req)) ;; failed to ping, close socket as side effect
#f))))
;; send data to server, wait max of timeout seconds for a response.
;; return #( success/fail result )
;;
(define (nmsg-transport:client-api-send-receive-raw socreq dat #!key (timeout 5))
(let* ((success #f)
(result #f)
(keepwaiting #t)
(send-recv (make-thread
(lambda ()
(nn-send socreq dat)
(let* ((res (nn-recv socreq)))
(set! success #t)
(set! result res)))
"send-recv"))
(timeout (make-thread
(lambda ()
(let loop ((count 0))
(thread-sleep! 1)
(debug:print-info 1 "send-receive-raw, still waiting after " count " seconds...")
(if (and keepwaiting (< count timeout)) ;; yes, this is very aproximate
(loop (+ count 1))))
(if keepwaiting
(begin
(print "timeout waiting for ping")
(thread-terminate! send-recv))))
"timeout")))
(handle-exceptions
exn
(set! result "timeout")
(thread-start! timeout)
(thread-start! send-recv)
(thread-join! send-recv)
(if success (thread-terminate! timeout)))
(vector success result)))
;; run nmsg-transport:keep-running in a parallel thread to monitor that the db is being
;; used and to shutdown after sometime if it is not.
;;
(define (nmsg-transport:keep-running server-id run-id)
;; if none running or if > 20 seconds since
;; server last used then start shutdown
|
>
|
>
|
|
|
>
>
|
>
|
>
>
|
>
>
>
>
>
>
>
>
>
>
>
>
|
174
175
176
177
178
179
180
181
182
183
184
185
186
187
188
189
190
191
192
193
194
195
196
197
198
199
200
201
202
203
204
205
206
207
208
209
210
211
212
213
214
215
216
217
218
219
220
221
222
223
224
225
226
227
228
229
230
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
|
(equal? hostn "-")) ;; use localhost
(get-host-name)
hostn))
(req (or socket
(let ((soc (nn-socket 'req)))
(nn-connect soc (conc "tcp://" host ":" port))
soc)))
(success #t)
(dat (vector "ping" our-key))
(result (condition-case
(nmsg-transport:client-api-send-receive-raw req dat timeout: timeout)
((timeout)(set! success #f) #f)))
(key (if success
(vector-ref result 1)
#f)))
(debug:print 0 "success=" success ", key=" key ", expected-key=" expected-key ", equal? " (equal? key expected-key))
(if (and success
(or (not expected-key) ;; just getting a reply is good enough then
(equal? key expected-key)))
(if return-socket
req
(begin
(if (not socket)(nn-close req)) ;; don't want a side effect of closing socket if handed it
#t))
(begin
(if (not socket)(nn-close req)) ;; failed to ping, close socket as side effect
#f))))
;; send data to server, wait max of timeout seconds for a response.
;; return #( success/fail result )
;;
;; for effiency it is easier to do the obj->string and string->obj here.
;;
(define (nmsg-transport:client-api-send-receive-raw socreq indat #!key (enable-send #t)(timeout 5))
(let* ((success #f)
(result #f)
(keepwaiting #t)
(dat (db:obj->string indat transport: 'nmsg))
(send-recv (make-thread
(lambda ()
(nn-send socreq dat)
(let* ((res (nn-recv socreq)))
(set! success #t)
(set! result (db:string->obj res transport: 'nmsg))))
"send-recv"))
(timeout (make-thread
(lambda ()
(let loop ((count 0))
(thread-sleep! 1)
(debug:print-info 1 "send-receive-raw, still waiting after " count " seconds...")
(if (and keepwaiting (< count timeout)) ;; yes, this is very aproximate
(loop (+ count 1))))
(if keepwaiting
(begin
(print "timeout waiting for ping")
(thread-terminate! send-recv))))
"timeout")))
;; replace with condition-case?
(handle-exceptions
exn
(set! result "timeout")
(thread-start! timeout)
(thread-start! send-recv)
(thread-join! send-recv)
(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 "ERROR: error occured at server, info=" (vector-ref result 2))
(debug:print 0 " client call chain:")
(print-call-chain (current-error-port))
(debug:print 0 " 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"))))))
;; run nmsg-transport:keep-running in a parallel thread to monitor that the db is being
;; used and to shutdown after sometime if it is not.
;;
(define (nmsg-transport:keep-running server-id run-id)
;; if none running or if > 20 seconds since
;; server last used then start shutdown
|
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
318
319
320
321
322
323
324
325
326
|
(current-seconds)))
(begin
(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.")
(set! *time-to-exit* #t)
(tasks:server-delete-record (db:delay-if-busy tdbdat) server-id " http-transport:keep-running")
(debug:print-info 0 "Server shutdown complete. Exiting")
(exit)
))))))
;;======================================================================
;; C L I E N T S
;;======================================================================
(define (nmsg-transport:client-connect iface portnum)
(let* ((reqsoc (nmsg-transport:ping iface portnum return-socket: #t)))
(vector iface portnum #f #f #f (current-seconds) reqsoc)))
;; return #( success result )
;;
(define (nmsg-transport:client-api-send-receive run-id connection-info cmd param #!key (remtries 5))
(mutex-lock! *http-mutex*)
(let* ((packet (db:obj->string (vector cmd param) transport: 'nmsg))
(reqsoc (http-transport:server-dat-get-socket connection-info))
(rawres (nmsg-transport:client-api-send-receive-raw reqsoc packet))
(status (vector-ref rawres 0))
(result (vector-ref rawres 1)))
(mutex-unlock! *http-mutex*)
(vector status (if status (db:string->obj result transport: 'nmsg) result))))
;;======================================================================
;; J U N K
;;======================================================================
;; DO NOT USE
;;
|
>
|
|
|
|
|
|
300
301
302
303
304
305
306
307
308
309
310
311
312
313
314
315
316
317
318
319
320
321
322
323
324
325
326
327
328
329
330
331
332
333
334
335
336
337
338
|
(current-seconds)))
(begin
(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.")
(set! *time-to-exit* #t)
(db:sync-touched *inmemdb* run-id force-sync: #t)
(tasks:server-delete-record (db:delay-if-busy tdbdat) server-id " http-transport:keep-running")
(debug:print-info 0 "Server shutdown complete. Exiting")
(exit)
))))))
;;======================================================================
;; C L I E N T S
;;======================================================================
(define (nmsg-transport:client-connect iface portnum)
(let* ((reqsoc (nmsg-transport:ping iface portnum return-socket: #t)))
(vector iface portnum #f #f #f (current-seconds) reqsoc)))
;; return #( success result )
;;
(define (nmsg-transport:client-api-send-receive run-id connection-info cmd param #!key (remtries 5))
(mutex-lock! *http-mutex*)
(let* ((packet (vector cmd param))
(reqsoc (http-transport:server-dat-get-socket connection-info))
(res (nmsg-transport:client-api-send-receive-raw reqsoc packet)))
;; (status (vector-ref rawres 0))
;; (result (vector-ref rawres 1)))
(mutex-unlock! *http-mutex*)
res)) ;; (vector status (if status (db:string->obj result transport: 'nmsg) result))))
;;======================================================================
;; J U N K
;;======================================================================
;; DO NOT USE
;;
|