source: project/release/3/remote-mailbox/trunk/remote-mailbox.scm @ 11636

Last change on this file since 11636 was 11636, checked in by Kon Lovett, 12 years ago

Cosmetic changes.

File size: 9.6 KB
Line 
1;;;; remote-mailbox.scm
2;;;; Kon Lovett, Jul '06
3
4;; Issues
5;;
6;; - Currently the client input port is ignored.
7
8(use srfi-18 tcp)
9(use tcp-server s11n mailbox miscmacros synch lookup-table misc-extn-record misc-extn-symbol)
10
11(define-extension remote-mailbox
12  (export
13        default-remote-mailbox-port
14    ;
15        remote-mailbox-serializer
16        remote-mailbox-connect-procedure
17                get-remote-mailbox
18                remote-mailbox?
19                remote-mailbox-name
20                remote-mailbox-host
21                remote-mailbox-port
22                remote-mailbox-connected?
23                drop-remote-mailbox!
24                drop-all-remote-mailboxs!
25                remote-mailbox-send!
26    ;
27                remote-mailbox-deserializer
28        remote-mailbox-listen-procedure
29                get-local-mailbox
30                drop-local-mailbox!
31                make-remote-mailbox-server
32                run-remote-mailbox-server
33                remote-mailbox-server-listener) )
34
35(eval-when (compile)
36  (declare
37    (usual-integrations)
38    (no-procedure-checks)
39    (no-bound-checks)
40    (inline)
41    (fixnum)
42    (bound-to-procedure
43      %remote-mailbox-name) ) )
44
45;;;
46
47(define (->boolean x)
48  (and x
49       #t) )
50
51;;;
52
53(define-inline (tcp-portno? obj)
54        (and (fixnum? obj)
55             (and (fx< 0 obj) (fx< obj 65536)) ) )
56
57;;; Synchronized Dictionary
58
59(define-constant INITIAL-DICT-SIZE 4)
60
61(define-inline (make-dict-unique/synch id #!optional (guess INITIAL-DICT-SIZE))
62  (make-object/synch (make-dict guess eq?) id) )
63
64;;; Local Exceptional Conditions
65
66(define (make-exn-condition loc msg . args)
67  (if (null? args)
68      (make-property-condition 'exn 'location loc 'message msg)
69      (make-property-condition 'exn 'location loc 'message msg 'arguments args) ) )
70
71(define (make-remote-mailbox-exception loc msg . args)
72        (make-composite-condition
73   (apply make-exn-condition loc msg args)
74         (make-property-condition 'remote-mailbox)) )
75
76;;; Remote Mailbox Packet
77
78(define remote-mailbox-tag 'rmb)
79
80(define-inline (make-remote-mailbox-packet rmb val)
81        (vector remote-mailbox-tag (%remote-mailbox-name rmb) val) )
82
83(define-inline (remote-mailbox-packet-mailbox-tag rmp)
84        (vector-ref rmp 0) )
85
86(define-inline (remote-mailbox-packet-mailbox-name rmp)
87        (vector-ref rmp 1) )
88
89(define-inline (remote-mailbox-packet-mailbox-value rmp)
90        (vector-ref rmp 2) )
91
92(define-inline (remote-mailbox-packet? obj)
93        (and (vector? obj)
94                         (= 3 (vector-length obj))
95                         (eq? remote-mailbox-tag (remote-mailbox-packet-mailbox-tag obj))) )
96
97;;; Communication IP Port
98
99(define-constant INITIAL-REMOTE-MAILBOX-PORT 3001)
100
101(define-parameter default-remote-mailbox-port
102        INITIAL-REMOTE-MAILBOX-PORT
103        (lambda (x)
104                (if (tcp-portno? x)
105        x
106        (default-remote-mailbox-port)) ) )
107
108;;; Client Side
109
110;; Support
111
112(define (make-remote-mailbox-mutex)
113        (make-dict-unique/synch 'fullname->remote-mailbox) )
114
115(define fullname->remote-mailbox (make-remote-mailbox-mutex))
116
117(define (make-remote-mailbox-key name host port)
118        (conc name #\@ host #\: port) )
119
120(define-unchecked-record-type %remote-mailbox
121        (%make-remote-mailbox name host port connect mutex input output)
122        %remote-mailbox?
123        (name %remote-mailbox-name %remote-mailbox-name-set!)
124        (host %remote-mailbox-host)
125        (port %remote-mailbox-port)
126        (connect %remote-mailbox-connect-procedure)
127        (mutex %remote-mailbox-mutex)
128        (input %remote-mailbox-input-port %remote-mailbox-input-port-set!)
129        (output %remote-mailbox-output-port %remote-mailbox-output-port-set!) )
130
131(define (invalidate-remote-mailbox! rmb)
132        (%remote-mailbox-name-set! rmb #f) )
133
134(define (valid-remote-mailbox? rmb)
135        (->boolean (%remote-mailbox-name rmb)) )
136
137(define (check-mailbox-name loc obj)
138        (unless (symbol? obj)
139                (error loc "mailbox name not a symbol" obj)) )
140
141(define (check-host loc obj)
142        (unless (string? obj)
143                (error loc "host not a string" obj)) )
144
145(define (check-port loc obj)
146        (unless (tcp-portno? obj)
147                (error loc "invalid port" obj)) )
148
149(define (check-remote-mailbox loc rmb)
150        (unless (%remote-mailbox? rmb)
151                (error loc "not a remote mailbox" rmb)) )
152
153(define (check-valid-remote-mailbox loc rmb)
154        (check-remote-mailbox loc rmb)
155        (unless (valid-remote-mailbox? rmb)
156                (error loc "not a valid remote mailbox" rmb)) )
157
158(define (get-connection rmb)
159        (let ([out (%remote-mailbox-output-port rmb)])
160                (if out
161        ; then we have a connection
162        (values (%remote-mailbox-input-port rmb) out)
163        ; else make a connection
164        (let-values ([(in out)
165                      ((%remote-mailbox-connect-procedure rmb)
166                       (%remote-mailbox-host rmb)
167                       (%remote-mailbox-port rmb))])
168          (%remote-mailbox-output-port-set! rmb out)
169          (%remote-mailbox-input-port-set! rmb in)
170          (values in out) )) ) )
171
172(define (close-remote-mailbox-connection! rmb)
173        (close-input-port (%remote-mailbox-input-port rmb))
174        (close-output-port (%remote-mailbox-output-port rmb))
175        (%remote-mailbox-output-port-set! rmb #f)
176        (%remote-mailbox-input-port-set! rmb #f)
177        (invalidate-remote-mailbox! rmb) )
178
179(define (close-all-remote-mailbox-connections!)
180        (%let/synch ([n->o fullname->remote-mailbox])
181        (dict-for-each n->o
182         (lambda (key rmb)
183                   (synch (%remote-mailbox-mutex rmb)
184             (close-remote-mailbox-connection! rmb) ) ) ) ) )
185
186;;; Exported
187
188;; Parameters
189
190(define-parameter remote-mailbox-serializer
191  #f
192  (lambda (x)
193        (cond [(procedure? x) x]
194          [(not x) #f]
195          [else (remote-mailbox-serializer)]) ) )
196
197(define-parameter remote-mailbox-connect-procedure
198  tcp-connect
199  (lambda (x)
200        (if (procedure? x)
201        x
202        (remote-mailbox-connect-procedure)) ) )
203
204;; Operations
205
206(define (get-remote-mailbox name #!optional (host "localhost") (port (default-remote-mailbox-port)))
207        (check-mailbox-name 'get-remote-mailbox name)
208        (check-host 'get-remote-mailbox host)
209        (check-port 'get-remote-mailbox port)
210        (let ([key (make-remote-mailbox-key name host port)])
211                (%let/synch ([n->o fullname->remote-mailbox])
212                        (or (dict-ref n->o key)
213                                        (let ([rmb (%make-remote-mailbox name host port
214                                                                         (remote-mailbox-connect-procedure)
215                                                                         (make-mutex key) #f #f)])
216                                                (dict-set! n->o key rmb)
217                                                rmb ) ) ) ) )
218
219(define (remote-mailbox? obj)
220        (and (%remote-mailbox? obj) (valid-remote-mailbox? obj)) )
221
222(define (remote-mailbox-name rmb)
223        (check-remote-mailbox 'remote-mailbox-name rmb)
224        (%remote-mailbox-name rmb) )
225
226(define (remote-mailbox-host rmb)
227        (check-remote-mailbox 'remote-mailbox-host rmb)
228        (%remote-mailbox-host rmb) )
229
230(define (remote-mailbox-port rmb)
231        (check-remote-mailbox 'remote-mailbox-port rmb)
232        (%remote-mailbox-port rmb) )
233
234(define (remote-mailbox-connected? rmb)
235        (check-remote-mailbox 'remote-mailbox-connected? rmb)
236        (->boolean (%remote-mailbox-output-port rmb)) )
237
238(define (drop-remote-mailbox! rmb)
239        (check-valid-remote-mailbox 'drop-remote-mailbox! rmb)
240        (let ([mutex (%remote-mailbox-mutex rmb)])
241                (synch mutex
242                        (close-remote-mailbox-connection! rmb)
243                        (%let/synch ([n->o fullname->remote-mailbox])
244                                (dict-delete! n->o (mutex-specific mutex)) ) ) ) )
245
246(define (drop-all-remote-mailboxs!)
247        (close-all-remote-mailbox-connections!)
248        (set! fullname->remote-mailbox (make-remote-mailbox-mutex)) )
249
250(define (remote-mailbox-send! rmb obj)
251        (check-valid-remote-mailbox 'remote-mailbox-send! rmb)
252        (synch (%remote-mailbox-mutex rmb)
253                (let-values ([(in out) (get-connection rmb)])
254                        (serialize (make-remote-mailbox-packet rmb obj) out (remote-mailbox-serializer)) ) ) )
255
256;;; Server Side
257
258;; Parameters
259
260(define-parameter remote-mailbox-deserializer
261  #f
262  (lambda (x)
263        (cond [(procedure? x)   x]
264          [(not x)          #f]
265          [else             (remote-mailbox-deserializer)]) ) )
266
267(define-parameter remote-mailbox-listen-procedure
268  tcp-listen
269  (lambda (x)
270        (if (procedure? x)
271        x
272        (remote-mailbox-listen-procedure)) ) )
273
274;; Support
275
276(define (remote-mailbox-server)
277        (let ([req (deserialize (current-input-port) (remote-mailbox-deserializer))])
278                (unless (undefined? req)
279                        (cond [(remote-mailbox-packet? req)
280              (mailbox-send!
281               (get-local-mailbox (remote-mailbox-packet-mailbox-name req) #t)
282               (remote-mailbox-packet-mailbox-value req))]
283            [else
284              (signal
285               (make-remote-mailbox-exception 'remote-mailbox-server
286                "request from remote mailbox client not understood"
287                req))])) )
288                (remote-mailbox-server) )
289
290(define (%make-remote-mailbox-server listener)
291        (make-tcp-server listener remote-mailbox-server) )
292
293(define name->mailbox (make-dict-unique/synch 'name->mailbox))
294
295;; Exported
296
297(define (get-local-mailbox name #!optional (create? #t))
298        (check-mailbox-name 'get-local-mailbox name)
299        (%let/synch ([n->o name->mailbox])
300                (or (dict-ref n->o name)
301                                (and create?
302             (let ([ch (make-mailbox name)])
303               (dict-set! n->o name ch)
304               ch ) ) ) ) )
305
306(define (drop-local-mailbox! name)
307        (%let/synch ([n->o name->mailbox])
308                (dict-delete! n->o name) ) )
309
310(define (make-remote-mailbox-server #!optional (port (default-remote-mailbox-port)))
311        (check-port 'make-remote-mailbox-server port)
312        (%make-remote-mailbox-server ((remote-mailbox-listen-procedure) port)) )
313
314(define run-remote-mailbox-server
315        (let ([server #f])
316                (lambda (#!optional (port (default-remote-mailbox-port)))
317                        (unless server
318                                (check-port 'run-remote-mailbox-server port)
319                                (let ([listener ((remote-mailbox-listen-procedure) port)])
320                                        (set! server
321                                                    (make-thread
322                                                           (cute (%make-remote-mailbox-server listener) "remote-mailbox-server")
323                                                           'remote-mailbox-server))
324                                        (thread-specific-set! server listener)
325                                        (thread-start! server)))
326                        server) ) )
327
328(define (remote-mailbox-server-listener server)
329        (unless (and (thread? server) (eq? 'remote-mailbox-server (thread-name)))
330                (error 'remote-mailbox-server-listener "not a server thread" server))
331        (thread-specific server) )
Note: See TracBrowser for help on using the repository browser.