1
2
3
4
5
6
7
8
9
10
|
;; ulex: Distributed sqlite3 db
;;;
;; Copyright (C) 2018 Matt Welland
;; Redistribution and use in source and binary forms, with or without
;; modification, is permitted.
;;
;; THIS SOFTWARE IS PROVIDED BY THE AUTHOR ``AS IS'' AND ANY EXPRESS
;; OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED
;; WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE
;; ARE DISCLAIMED. IN NO EVENT SHALL THE AUTHOR OR CONTRIBUTORS BE
|
|
|
1
2
3
4
5
6
7
8
9
10
|
;; ulex: Distributed sqlite3 db
;;;
;; Copyright (C) 2018-2021 Matt Welland
;; Redistribution and use in source and binary forms, with or without
;; modification, is permitted.
;;
;; THIS SOFTWARE IS PROVIDED BY THE AUTHOR ``AS IS'' AND ANY EXPRESS
;; OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED
;; WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE
;; ARE DISCLAIMED. IN NO EVENT SHALL THE AUTHOR OR CONTRIBUTORS BE
|
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
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
|
;; See README in the distribution at https://www.kiatoa.com/fossils/ulex
;; NOTES:
;; Why sql-de-lite and not say, dbi? - performance mostly, then simplicity.
;;
;;======================================================================
(module ulex
*
queues
regex
regex-case
srfi-1
srfi-18
srfi-4
srfi-69
system-information
tcp6
typed-records
)
;; udat struct, used by both caller and callee
;; instantiated as uconn by convention
;;
(defstruct udat
;; the listener side
(port #f)
(host-port #f)
(socket #f)
;; the peers
(peers (make-hash-table)) ;; host:port->peer
;; work handling
(work-queue (make-queue))
(work-proc #f) ;; set by user
(cnum 0) ;; cookie number
(mboxes (make-hash-table))
(avail-cmboxes '()) ;; list of (<cookie> . <mbox>) for re-use
)
;; struct for keeping track of others we are talking to
;;
(defstruct pdat
(host-port #f)
(conns '()) ;; list of pcon structs, pop one off when calling the peer
)
;; struct for peer connections, keep track of expiration etc.
;;
(defstruct pcon
(inp #f)
(oup #f)
(exp (+ (current-seconds) 59)) ;; expires at this time, set to (+ (current-seconds) 59)
(lifetime (+ (current-seconds) 600)) ;; throw away and create new after five minutes
)
;;======================================================================
;; listener
;;======================================================================
;; create a tcp listener and return a populated udat struct with
;; my port, address, hostname, pid etc.
;; return #f if fail to find a port to allocate.
;;
;; if udata-in is #f create the record
;; if there is already a serv-listener return the udata
;;
|
|
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
|
>
|
|
|
|
|
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
|
|
|
|
|
<
|
>
|
|
|
|
|
|
|
<
>
>
>
>
>
>
>
|
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
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
131
132
133
134
135
136
137
138
139
140
141
142
143
144
145
146
147
148
149
150
151
152
153
154
155
156
157
|
;; See README in the distribution at https://www.kiatoa.com/fossils/ulex
;; NOTES:
;; Why sql-de-lite and not say, dbi? - performance mostly, then simplicity.
;;
;;======================================================================
(module ulex
*
#;(
;; NOTE: looking for the handler proc - find the run-listener :)
run-listener ;; (run-listener handler-proc [port]) => uconn
;; NOTE: handler-proc params;
;; (handler-proc rem-host-port qrykey cmd params)
send-receive ;; (send-receive uconn host-port cmd data)
;; NOTE: cmd can be any plain text symbol except for these;
;; 'ping 'ack 'goodbye 'response
set-work-handler ;; (set-work-handler proc)
wait-and-close ;; (wait-and-close uconn)
ulex-listener?
;; needed to get the interface:port that was automatically found
udat-port
udat-host-port
;; for testing only
;; pp-uconn
;; parameters
work-method ;; parameter; 'threads, 'mailbox, 'limited, 'direct
return-method ;; parameter; 'mailbox, 'polling, 'direct
)
(import scheme
chicken.base
chicken.file
chicken.time
chicken.condition
chicken.string
chicken.sort
chicken.pretty-print
address-info
mailbox
matchable
;; queues
regex
regex-case
s11n
srfi-1
srfi-18
srfi-4
srfi-69
system-information
tcp6
typed-records
)
;; udat struct, used by both caller and callee
;; instantiated as uconn by convention
;;
(defstruct udat
;; the listener side
(port #f)
(host-port #f)
(socket #f)
;; the peers
(peers (make-hash-table)) ;; host:port->peer
;; work handling
(work-queue (make-mailbox))
(work-proc #f) ;; set by user
(cnum 0) ;; cookie number
(mboxes (make-hash-table)) ;; for the replies
(avail-cmboxes '()) ;; list of (<cookie> . <mbox>) for re-use
;; threads
(numthreads 10)
(cmd-thread #f)
(work-queue-thread #f)
(num-threads-running 0)
)
;; Parameters
;; work-method:
(define work-method (make-parameter 'mailbox))
;; mailbox - all rdat goes through mailbox
;; threads - all rdat immediately executed in new thread
;; direct - no queuing
;;
;; return-method, return the result to waiting send-receive:
(define return-method (make-parameter 'mailbox))
;; mailbox - create a mailbox and use it for passing returning results to send-receive
;; polling - put the result in a hash table keyed by qrykey and send-receive can poll it for result
;; direct - no queuing, result is passed back in single tcp connection
;;
;; ;; struct for keeping track of others we are talking to
;; ;;
;; (defstruct pdat
;; (host-port #f)
;; (conns '()) ;; list of pcon structs, pop one off when calling the peer
;; )
;;
;; ;; struct for peer connections, keep track of expiration etc.
;; ;;
;; (defstruct pcon
;; (inp #f)
;; (oup #f)
;; (exp (+ (current-seconds) 59)) ;; expires at this time, set to (+ (current-seconds) 59)
;; (lifetime (+ (current-seconds) 600)) ;; throw away and create new after five minutes
;; )
;;======================================================================
;; listener
;;======================================================================
;; is uconn a ulex connector (listener)
;;
(define (ulex-listener? uconn)
(udat? uconn))
;; create a tcp listener and return a populated udat struct with
;; my port, address, hostname, pid etc.
;; return #f if fail to find a port to allocate.
;;
;; if udata-in is #f create the record
;; if there is already a serv-listener return the udata
;;
|
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
140
141
142
143
144
145
146
147
148
149
150
151
152
153
154
155
156
157
158
159
160
161
162
163
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
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
260
261
262
263
264
265
266
267
268
269
270
271
272
273
274
275
276
277
278
279
280
281
282
283
284
285
286
287
|
;; sockaddr-address, sockaddr-port, sockaddr->string
(let* ((tlsn (tcp-listen port 1000 #f)) ;; (tcp-listen TCPPORT [BACKLOG [HOST]])
(addr (get-my-best-address))) ;; (hostinfo-addresses (host-information (current-hostname)))
(udat-port-set! uconn port)
(udat-host-port-set! uconn (conc addr":"port))
(udat-socket-set! uconn tlsn)
uconn))
;;======================================================================
;; peers and connections
;;======================================================================
;; send structured data to recipient
;;
;; NOTE: qrykey is what was called the "cookie" previously
;;
;; retval tells send to expect and wait for return data (one line) and return it or time out
;; this is for ping where we don't want to necessarily have set up our own server yet.
;;
;; NOTE: see below for beginnings of code to allow re-use of tcp connections
;; - I believe (without substantial evidence) that re-using connections will
;; be beneficial ...
;;
(define (send udata host-port qrykey cmd params)
(let* ((my-host-port (udat-host-port udata)) ;; remote will return to this
(isme #f #;(equal? host-port my-host-port)) ;; calling myself?
;; dat is a self-contained work block that can be sent or handled locally
(dat (list my-host-port qrykey cmd params))
)
(if isme
(ulex-handler udata dat) ;; no transmission needed
(handle-exceptions ;; TODO - MAKE THIS EXCEPTION CMD SPECIFIC?
exn
#f
(write dat oup)
(read inp)) ;; yes, we always want an ack
(begin
(print "ERROR: send called but no receiver has been setup. Please call setup first!")
#f))))
(close-input-port inp)
(close-output-port oup)
res)))))) ;; res will always be 'ack
;; send a request to the given host-port and register a mailbox in udata
;; wait for the mailbox data and return it
;;
(define (send-receive uconn host-port cmd data)
(let* ((cmbox (get-cmbox uconn)) ;; would it be better to keep a stack of mboxes to reuse?
(qrykey (car cmbox))
(mbox (cdr cmbox))
(mbox-time (current-milliseconds)))
(if (eq? (send uconn host-port qrykey cmd data) 'ack)
(let* ((mbox-timeout-secs 120) ;; timeout)
(mbox-timeout-result 'MBOX_TIMEOUT)
(res (mailbox-receive! mbox mbox-timeout-secs mbox-timeout-result))
(mbox-receive-time (current-milliseconds)))
(if (eq? res 'MBOX_TIMEOUT)
#f ;; convert to raising exception?
res))
(begin
(print "ERROR: Communication failed?")
#f)))) ;; #f means failed to communicate
;; take a request, rdata, and if not immediate put it in the work queue
;;
;; Reserved cmds; ack ping goodbye response
;;
(define (ulex-handler uconn rdata)
(match rdata ;; (string-split controldat)
((rem-host-port qrykey cmd params)
;; (print "ulex-handler got: "rem-host-port" qrykey: "qrykey" cmd: "cmd" params: "params)
(let ((mbox (hash-table-ref/default (udat-mboxes uconn) qrykey #f)))
(case cmd
;; ((ack )(print "Got ack! But why? Should NOT get here.") 'ack)
((ping)
;; (print "Got Ping!")
(add-to-work-queue uconn rdata)
'ack)
((goodbye)
;; just clear out references to the caller
(add-to-work-queue uconn rdata)
'ack)
((response) ;; this is a result from remote processing, send it as mail ...
(if mbox
(begin
(mailbox-send! mbox params) ;; params here is our result
'ack)
(begin
(print "ERROR: received result but no associated mbox for cookie "qrykey)
#f)))
(else
;; (print "Got generic request: "cmd)
(add-to-work-queue uconn rdata)
'ack))))
(print "BAD DATA? controldat=" rdata)
'ack) ;; send ack anyway?
))
;; given an already set up uconn start the cmd-loop
;;
(define (ulex-cmd-loop uconn)
(let* ((serv-listener (udat-socket uconn)))
(let loop ((state 'start))
(let-values (((inp oup)(tcp-accept serv-listener)))
(let* ((rdat (read inp))
(resp (ulex-handler uconn rdat)))
(if resp (write resp oup))
(close-input-port inp)
(close-output-port oup))
(loop state)))))
;; run-listener does all the work of starting a listener in a thread
;; it then returns control
;;
(define (run-listener handler-proc)
(let* ((uconn (make-udat)))
(udat-work-proc-set! uconn handler-proc)
(if (setup-listener uconn)
(let* ((th1 (make-thread (lambda ()(ulex-cmd-loop uconn)) "Ulex command loop"))
(th2 (make-thread (lambda ()(process-work-queue uconn)) "Ulex work queue processor")))
(thread-start! th1)
(thread-start! th2)
(print "cmd loop and process workers started")
uconn)
(begin
(print "ERROR: run-listener called without proper setup.")
(exit)))))
;; rdata is (rem-host-port qrykey cmd params)
(define (add-to-work-queue uconn rdata)
(queue-add! (udat-work-queue uconn) rdata))
(define (do-work uconn rdata)
(let* ((proc (udat-work-proc uconn))) ;; get it each time - conceivebly it could change
;; put this following into a do-work procedure
(match rdata
((rem-host-port qrykey cmd params)
(let* ((result (proc rem-host-port qrykey cmd params)))
;; send 'response as cmd and result as params
(send uconn rem-host-port qrykey 'response result))) ;; could check for ack
(else
(print "ERROR: rdata "rdata", did not match rem-host-port qrykey cmd params")))))
(define (process-work-queue uconn)
(let ((wqueue (udat-work-queue uconn))
(proc (udat-work-proc uconn)))
(let loop ()
(if (queue-empty? wqueue)
(thread-sleep! 0.1)
(let ((rdata (queue-remove! wqueue)))
(do-work uconn rdata)))
(loop))))
;; below was to enable re-use of connections. This seems non-trivial so for
;; now lets open on each call
;;
;; ;; given host-port get or create peer struct
;; ;;
;; (define (udat-get-peer uconn host-port)
|
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
|
<
|
|
>
|
|
|
>
>
|
|
>
|
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
<
<
<
|
>
>
|
>
|
>
>
>
>
>
|
|
>
>
>
>
|
<
<
>
>
|
|
<
<
|
|
>
|
|
<
|
|
|
|
|
|
|
|
|
|
|
>
>
>
>
>
>
|
|
|
|
|
|
|
|
>
|
|
|
|
<
|
|
>
|
|
|
|
|
|
|
|
>
>
>
>
>
>
>
>
>
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
|
|
|
>
>
>
>
>
>
>
>
>
>
>
>
|
>
>
|
|
>
|
>
>
>
>
>
>
|
|
>
>
|
|
|
>
|
>
|
<
|
>
>
|
|
|
>
>
>
>
>
>
>
>
>
>
|
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
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
260
261
262
263
264
265
266
267
268
269
270
271
272
273
274
275
276
277
278
279
280
281
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
315
316
317
318
319
320
321
322
323
324
325
326
327
328
329
330
331
332
333
334
335
336
337
338
339
340
341
342
343
344
345
346
347
348
349
350
351
352
353
354
355
356
357
358
359
360
361
362
363
364
365
366
367
368
369
370
371
372
373
374
375
376
377
378
379
380
381
382
383
384
385
386
387
388
389
390
391
392
393
394
395
396
397
398
399
400
401
402
403
404
405
406
407
408
409
410
411
412
413
414
415
416
417
418
419
420
421
422
423
424
425
426
427
428
429
430
431
432
433
434
435
436
437
438
439
440
441
442
443
444
445
446
447
448
449
450
451
452
453
454
455
456
457
458
459
460
461
462
463
464
465
466
467
468
469
470
471
|
;; sockaddr-address, sockaddr-port, sockaddr->string
(let* ((tlsn (tcp-listen port 1000 #f)) ;; (tcp-listen TCPPORT [BACKLOG [HOST]])
(addr (get-my-best-address))) ;; (hostinfo-addresses (host-information (current-hostname)))
(udat-port-set! uconn port)
(udat-host-port-set! uconn (conc addr":"port))
(udat-socket-set! uconn tlsn)
uconn))
;; run-listener does all the work of starting a listener in a thread
;; it then returns control
;;
(define (run-listener handler-proc #!optional (port-suggestion 4242))
(let* ((uconn (make-udat)))
(udat-work-proc-set! uconn handler-proc)
(if (setup-listener uconn port-suggestion)
(let* ((th1 (make-thread (lambda ()(ulex-cmd-loop uconn)) "Ulex command loop"))
(th2 (make-thread (lambda ()
(case (work-method)
((mailbox limited)
(process-work-queue uconn))))
"Ulex work queue processor")))
(tcp-buffer-size 2048)
;; (max-connections 2048)
(thread-start! th1)
(thread-start! th2)
(udat-cmd-thread-set! uconn th1)
(udat-work-queue-thread-set! uconn th2)
(print "cmd loop and process workers started, listening on "(udat-host-port uconn)".")
uconn)
(assert #f "ERROR: run-listener called without proper setup."))))
(define (wait-and-close uconn)
(thread-join! (udat-cmd-thread uconn))
(tcp-close (udat-socket uconn)))
;;======================================================================
;; peers and connections
;;======================================================================
(define *send-mutex* (make-mutex))
;; send structured data to recipient
;;
;; NOTE: qrykey is what was called the "cookie" previously
;;
;; retval tells send to expect and wait for return data (one line) and return it or time out
;; this is for ping where we don't want to necessarily have set up our own server yet.
;;
;; NOTE: see below for beginnings of code to allow re-use of tcp connections
;; - I believe (without substantial evidence) that re-using connections will
;; be beneficial ...
;;
(define (send udata host-port qrykey cmd params)
(let* ((my-host-port (udat-host-port udata)) ;; remote will return to this
(isme #f #;(equal? host-port my-host-port)) ;; calling myself?
;; dat is a self-contained work block that can be sent or handled locally
(dat (list my-host-port qrykey cmd params #;(cons (current-seconds)(current-milliseconds)))))
(cond
(isme (ulex-handler udata dat)) ;; no transmission needed
(else
(handle-exceptions ;; TODO - MAKE THIS EXCEPTION CMD SPECIFIC?
exn
#f
(begin
;; (mutex-lock! *send-mutex*)
(let-values (((inp oup)(tcp-connect host-port)))
(let ((res (if (and inp oup)
(begin
(serialize dat oup)
(deserialize inp))
(begin
(print "ERROR: send called but no receiver has been setup. Please call setup first!")
#f))))
(close-input-port inp)
(close-output-port oup)
;; (mutex-unlock! *send-mutex*)
res)))))))) ;; res will always be 'ack unless return-method is direct
(define (send-via-polling uconn host-port cmd data)
(let* ((qrykey (make-cookie uconn))
(sres (send uconn host-port qrykey cmd data)))
(case sres
((ack)
(let loop ((start-time (current-milliseconds)))
(if (> (current-milliseconds)(+ start-time 10000)) ;; ten seconds timeout
(begin
(print "ULEX ERROR: timed out waiting for response from "host-port", "cmd" "data)
#f)
(let* ((result (hash-table-ref/default (udat-mboxes uconn) qrykey #f))) ;; NOTE: we are re-using mboxes hash
(if result ;; result is '(status . result-data) or #f for nothing yet
(begin
(hash-table-delete! (udat-mboxes uconn) qrykey)
(cdr result))
(begin
(thread-sleep! 0.01)
(loop start-time)))))))
(else
(print "ULEX ERROR: Communication failed? sres="sres)
#f))))
(define (send-via-mailbox uconn host-port cmd data)
(let* ((cmbox (get-cmbox uconn)) ;; would it be better to keep a stack of mboxes to reuse?
(qrykey (car cmbox))
(mbox (cdr cmbox))
(mbox-time (current-milliseconds))
(sres (send uconn host-port qrykey cmd data))) ;; short res
(if (eq? sres 'ack)
(let* ((mbox-timeout-secs 120 #;(if (eq? 'primordial (thread-name (current-thread)))
#f
120)) ;; timeout)
(mbox-timeout-result 'MBOX_TIMEOUT)
(res (mailbox-receive! mbox mbox-timeout-secs mbox-timeout-result))
(mbox-receive-time (current-milliseconds)))
;; (put-cmbox uconn cmbox) ;; reuse mbox and cookie. is it worth it?
(hash-table-delete! (udat-mboxes uconn) qrykey)
(if (eq? res 'MBOX_TIMEOUT)
(begin
(print "WARNING: mbox timed out for query "cmd", with data "data
", waiting for response from "host-port".")
;; here it might make sense to clean up connection records and force clean start?
;; NO. The progam using ulex needs to do the reset. Right thing here is exception
#f) ;; convert to raising exception?
res))
(begin
(print "ERROR: Communication failed? Got "sres)
#f))))
;; send a request to the given host-port and register a mailbox in udata
;; wait for the mailbox data and return it
;;
(define (send-receive uconn host-port cmd data)
(let* ((start-time (current-milliseconds))
(result (cond
((member cmd '(ping goodbye)) ;; these are immediate
(send uconn host-port 'ping cmd data))
((eq? (work-method) 'direct)
;; the result from send will be the actual result, not an 'ack
(send uconn host-port 'direct cmd data))
(else
(case (return-method)
((polling)
(send-via-polling uconn host-port cmd data))
((mailbox)
(send-via-mailbox uconn host-port cmd data))
(else
(print "ULEX ERROR: unrecognised return-method "(return-method)".")
#f))))))
;; this is ONLY for development and debugging. It will be removed once Ulex is stable.
(if (< 5000 (- (current-milliseconds) start-time))
(print "ULEX WARNING: round-trip took over 5 seconds; "
cmd", host-port="host-port", data="data))
result))
;;======================================================================
;; responder side
;;======================================================================
;; take a request, rdat, and if not immediate put it in the work queue
;;
;; Reserved cmds; ack ping goodbye response
;;
(define (ulex-handler uconn rdat)
(assert (list? rdat) "FATAL: ulex-handler give rdat as not list")
(match rdat ;; (string-split controldat)
((rem-host-port qrykey cmd params);; timedata)
;; (print "ulex-handler got: "rem-host-port" qrykey: "qrykey" cmd: "cmd" params: "params)
(case cmd
;; ((ack )(print "Got ack! But why? Should NOT get here.") 'ack)
((ping)
;; (print "Got Ping!")
;; (add-to-work-queue uconn rdat)
'ack)
((goodbye)
;; just clear out references to the caller. NOT COMPLETE
(add-to-work-queue uconn rdat)
'ack)
((response) ;; this is a result from remote processing, send it as mail ...
(case (return-method)
((polling)
(hash-table-set! (udat-mboxes uconn) qrykey (cons 'ok params))
'ack)
((mailbox)
(let ((mbox (hash-table-ref/default (udat-mboxes uconn) qrykey #f)))
(if mbox
(begin
(mailbox-send! mbox params) ;; params here is our result
'ack)
(begin
(print "ERROR: received result but no associated mbox for cookie "qrykey)
'no-mbox-found))))
(else (print "ULEX ERROR: unrecognised return-method "(return-method))
'bad-return-method)))
(else ;; generic request - hand it to the work queue
(add-to-work-queue uconn rdat)
'ack)))
(else
(print "ULEX ERROR: bad rdat "rdat)
'bad-rdat)))
;; given an already set up uconn start the cmd-loop
;;
(define (ulex-cmd-loop uconn)
(let* ((serv-listener (udat-socket uconn))
(listener (lambda ()
(let loop ((state 'start))
(let-values (((inp oup)(tcp-accept serv-listener)))
(let* ((rdat (deserialize inp)) ;; '(my-host-port qrykey cmd params)
(resp (ulex-handler uconn rdat)))
(if resp (serialize resp oup))
(close-input-port inp)
(close-output-port oup))
(loop state))))))
;; start N of them
(let loop ((thnum 0)
(threads '()))
(if (< thnum 100)
(let* ((th (make-thread listener (conc "listener" thnum))))
(thread-start! th)
(loop (+ thnum 1)
(cons th threads)))
(map thread-join! threads)))))
;; add a proc to the cmd list, these are done symetrically (i.e. in all instances)
;; so that the proc can be dereferenced remotely
;;
(define (set-work-handler uconn proc)
(udat-work-proc-set! uconn proc))
;;======================================================================
;; work queues - this is all happening on the listener side
;;======================================================================
;; rdat is (rem-host-port qrykey cmd params)
(define (add-to-work-queue uconn rdat)
#;(queue-add! (udat-work-queue uconn) rdat)
(case (work-method)
((threads)
(thread-start! (make-thread (lambda ()
(do-work uconn rdat))
"worker thread")))
((mailbox)
(mailbox-send! (udat-work-queue uconn) rdat))
((direct)
(do-work uconn rdat))
(else
(print "ULEX ERROR: work-method "(work-method)" not recognised, using mailbox.")
(mailbox-send! (udat-work-queue uconn) rdat))))
;; move the logic to return the result somewhere else?
;;
(define (do-work uconn rdat)
(let* ((proc (udat-work-proc uconn))) ;; get it each time - conceivebly it could change
;; put this following into a do-work procedure
(match rdat
((rem-host-port qrykey cmd params)
(let* ((start-time (current-milliseconds))
(result (proc rem-host-port qrykey cmd params))
(end-time (current-milliseconds))
(run-time (- end-time start-time)))
(case (work-method)
((direct) result)
(else
(print "ULEX: work "cmd", "params" done in "run-time" ms")
;; send 'response as cmd and result as params
(send uconn rem-host-port qrykey 'response result) ;; could check for ack
(print "ULEX: response sent back to "rem-host-port" in "(- (current-milliseconds) end-time))))))
(MBOX_TIMEOUT #f)
(else
(print "ERROR: rdat "rdat", did not match rem-host-port qrykey cmd params")))))
;; NEW APPROACH:
;;
(define (process-work-queue uconn)
(let ((wqueue (udat-work-queue uconn))
(proc (udat-work-proc uconn))
(numthr (udat-numthreads uconn)))
(let loop ((thnum 1)
(threads '()))
(let ((thlst (cons (make-thread (lambda ()
(let work-loop ()
(let ((rdat (mailbox-receive! wqueue 24000 'MBOX_TIMEOUT)))
(do-work uconn rdat))
(work-loop)))
(conc "work thread " thnum))
threads)))
(if (< thnum numthr)
(loop (+ thnum 1)
thlst)
(begin
(print "ULEX: Starting "(length thlst)" worker threads.")
(map thread-start! thlst)
(print "ULEX: Threads started. Joining all.")
(map thread-join! thlst)))))))
;; below was to enable re-use of connections. This seems non-trivial so for
;; now lets open on each call
;;
;; ;; given host-port get or create peer struct
;; ;;
;; (define (udat-get-peer uconn host-port)
|
372
373
374
375
376
377
378
379
380
381
382
383
384
385
386
387
388
389
390
391
392
393
394
395
396
397
398
399
400
401
402
403
404
405
406
407
408
409
410
411
412
413
414
415
416
417
418
419
420
421
422
423
|
(define (get-all-ips)
(map address-info-host
(filter (lambda (x)
(equal? (address-info-type x) "tcp"))
(address-infos (get-host-name)))))
;; (map ip->string (vector->list
;; (hostinfo-addresses
;; (host-information (current-hostname))))))
)
(import ulex trace big-chicken srfi-18 test matchable system-information)
(trace-call-sites #t)
(trace
;; ulex-handler
;; send
;; add-to-work-queue
)
(define (handler-proc rem-host-port qrykey cmd params)
(print "handler-proc "rem-host-port" "qrykey" "cmd" "params)
(case cmd
((ping) 'pong)
((calc) (eval (with-input-from-string params read)))
((print)
(print "params="params)
params)
((reflect) `(,rem-host-port ,qrykey ,cmd ,params))
(else `(data ,data))))
(define uconn (run-listener handler-proc))
(pp-uconn uconn)
;; super basic loop back test
(define res #f)
(define targhost (conc (get-host-name)":"4242))
(define th1 (make-thread (lambda ()
(test #f 10 (send-receive uconn targhost 'calc "(+ 5 5)"))
(set! res (send-receive uconn targhost 'ping '()))
(test #f 'pong (send-receive uconn targhost 'ping '()))
)))
(thread-start! th1)
(thread-join! th1)
(print "All done")
(print "Received "res)
|
<
<
<
|
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
|
556
557
558
559
560
561
562
563
|
(define (get-all-ips)
(map address-info-host
(filter (lambda (x)
(equal? (address-info-type x) "tcp"))
(address-infos (get-host-name)))))
)
|