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

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

Canon dir struct

File size: 8.8 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
43;;;
44
45(define (->boolean x)
46  (not (not x)) )
47
48;;; Synchronized Dictionary
49
50(define-constant INITIAL-DICT-SIZE 4)
51
52(define (make-dict-unique/synch id #!optional (guess INITIAL-DICT-SIZE))
53  (make-object/synch (make-dict guess eq?) id) )
54
55;;;
56
57(define remote-mailbox-tag 'RCH)
58
59(define (make-remote-mailbox-packet rch obj)
60        (vector remote-mailbox-tag (%remote-mailbox-name rch) obj) )
61
62(define (remote-mailbox-packet-mailbox-name obj)
63        (vector-ref obj 1) )
64
65(define (remote-mailbox-packet-mailbox-value obj)
66        (vector-ref obj 2) )
67
68(define (remote-mailbox-packet? obj)
69        (and (vector? obj)
70                         (= 3 (vector-length obj))
71                         (eq? remote-mailbox-tag (vector-ref obj 0))) )
72
73(define (make-remote-mailbox-exception loc msg . args)
74        (make-composite-condition
75                (make-property-condition 'exn 'message msg 'location loc 'arguments args)
76                (make-property-condition 'rch)) )
77
78;;;
79
80(define (tcp-portno? obj)
81        (and (fixnum? obj)
82             (< 0 obj 65536)) )
83
84;;;
85
86(define-constant INITIAL-REMOTE-MAILBOX-PORT 3001)
87
88(define-parameter default-remote-mailbox-port
89        INITIAL-REMOTE-MAILBOX-PORT
90        (lambda (x)
91                (if (tcp-portno? x)
92                        x
93                        (default-remote-mailbox-port)) ) )
94
95;;; Client Side
96
97(define (make-remote-mailbox-mutex)
98        (make-dict-unique/synch 'fullname->remote-mailbox) )
99
100(define fullname->remote-mailbox (make-remote-mailbox-mutex))
101
102(define (make-remote-mailbox-key name host port)
103        (conc name #\@ host #\: port) )
104
105(define-unchecked-record-type %remote-mailbox
106        (%make-remote-mailbox name host port connect mutex input output)
107        %remote-mailbox?
108        (name %remote-mailbox-name %remote-mailbox-name-set!)
109        (host %remote-mailbox-host)
110        (port %remote-mailbox-port)
111        (connect %remote-mailbox-connect-procedure)
112        (mutex %remote-mailbox-mutex)
113        (input %remote-mailbox-input-port %remote-mailbox-input-port-set!)
114        (output %remote-mailbox-output-port %remote-mailbox-output-port-set!) )
115
116(define (invalidate-remote-mailbox! rch)
117        (%remote-mailbox-name-set! rch #f) )
118
119(define (valid-remote-mailbox? rch)
120        (->boolean (%remote-mailbox-name rch)) )
121
122(define (check-mailbox-name obj loc)
123        (unless (symbol? obj)
124                (error loc "mailbox name not a symbol" obj)) )
125
126(define (check-host obj loc)
127        (unless (string? obj)
128                (error loc "host not a string" obj)) )
129
130(define (check-port obj loc)
131        (unless (tcp-portno? obj)
132                (error loc "invalid port" obj)) )
133
134(define (check-remote-mailbox rch loc)
135        (unless (%remote-mailbox? rch)
136                (error loc "not a remote mailbox" rch)) )
137
138(define (check-valid-remote-mailbox rch loc)
139        (check-remote-mailbox rch loc)
140        (unless (valid-remote-mailbox? rch)
141                (error loc "not a valid remote mailbox" rch)) )
142
143(define (get-connection rch)
144        (let ([out (%remote-mailbox-output-port rch)])
145                (if out
146                  ; then we have a connection
147                        (values (%remote-mailbox-input-port rch) out)
148                        ; else make a connection
149                        (let-values ([(in out)
150                                                                                ((%remote-mailbox-connect-procedure rch)
151                                                                                        (%remote-mailbox-host rch)
152                                                                                        (%remote-mailbox-port rch))])
153                                (%remote-mailbox-output-port-set! rch out)
154                                (%remote-mailbox-input-port-set! rch in)
155                                (values in out) )) ) )
156
157(define (close-remote-mailbox-connection! rch)
158        (close-input-port (%remote-mailbox-input-port rch))
159        (close-output-port (%remote-mailbox-output-port rch))
160        (%remote-mailbox-output-port-set! rch #f)
161        (%remote-mailbox-input-port-set! rch #f)
162        (invalidate-remote-mailbox! rch) )
163
164(define (close-all-remote-mailbox-connections!)
165        (%let/synch ([n->o fullname->remote-mailbox])
166        (dict-for-each n->o
167                (lambda (key rch)
168                                (synch (%remote-mailbox-mutex rch)
169                                (close-remote-mailbox-connection! rch) ) ) ) ) )
170
171;;;
172
173(define-parameter remote-mailbox-serializer
174  #f
175  (lambda (x)
176        (cond
177                [(procedure? x) x]
178                [(not x) #f]
179                [else (remote-mailbox-serializer)]) ) )
180
181(define-parameter remote-mailbox-connect-procedure
182  tcp-connect
183  (lambda (x)
184        (if (procedure? x)
185                x
186                (remote-mailbox-connect-procedure)) ) )
187
188(define (get-remote-mailbox name #!optional (host "localhost") (port (default-remote-mailbox-port)))
189        (check-mailbox-name name 'get-remote-mailbox)
190        (check-host host 'get-remote-mailbox)
191        (check-port port 'get-remote-mailbox)
192        (let ([key (make-remote-mailbox-key name host port)])
193                (%let/synch ([n->o fullname->remote-mailbox])
194                        (or (dict-ref n->o key)
195                                        (let ([rch
196                  (%make-remote-mailbox name host port
197                    (remote-mailbox-connect-procedure)
198                    (make-mutex key) #f #f)])
199                                                (dict-set! n->o key rch)
200                                                rch )) ) ) )
201
202(define (remote-mailbox? obj)
203        (and (%remote-mailbox? obj) (valid-remote-mailbox? obj)) )
204
205(define (remote-mailbox-name rch)
206        (check-remote-mailbox rch 'remote-mailbox-name)
207        (%remote-mailbox-name rch) )
208
209(define (remote-mailbox-host rch)
210        (check-remote-mailbox rch 'remote-mailbox-host)
211        (%remote-mailbox-host rch) )
212
213(define (remote-mailbox-port rch)
214        (check-remote-mailbox rch 'remote-mailbox-port)
215        (%remote-mailbox-port rch) )
216
217(define (remote-mailbox-connected? rch)
218        (check-remote-mailbox rch 'remote-mailbox-connected?)
219        (->boolean (%remote-mailbox-output-port rch)) )
220
221(define (drop-remote-mailbox! rch)
222        (check-valid-remote-mailbox rch 'drop-remote-mailbox!)
223        (let ([mutex (%remote-mailbox-mutex rch)])
224                (synch mutex
225                        (close-remote-mailbox-connection! rch)
226                        (%let/synch ([n->o fullname->remote-mailbox])
227                                (dict-delete! n->o (mutex-specific mutex)) ) ) ) )
228
229(define (drop-all-remote-mailboxs!)
230        (close-all-remote-mailbox-connections!)
231        (set! fullname->remote-mailbox (make-remote-mailbox-mutex)) )
232
233(define (remote-mailbox-send! rch obj)
234        (check-valid-remote-mailbox rch 'remote-mailbox-send!)
235        (synch (%remote-mailbox-mutex rch)
236                (let-values ([(in out) (get-connection rch)])
237                        (serialize (make-remote-mailbox-packet rch obj) out (remote-mailbox-serializer)) ) ) )
238
239;;; Server Side
240
241(define-parameter remote-mailbox-deserializer
242  #f
243  (lambda (x)
244        (cond
245                [(procedure? x) x]
246                [(not x) #f]
247                [else (remote-mailbox-deserializer)]) ) )
248
249(define-parameter remote-mailbox-listen-procedure
250  tcp-listen
251  (lambda (x)
252        (if (procedure? x)
253                x
254                (remote-mailbox-listen-procedure)) ) )
255
256(define (remote-mailbox-server)
257        (let ([req (deserialize (current-input-port) (remote-mailbox-deserializer))])
258                (unless (undefined? req)
259                        (cond
260                                [(remote-mailbox-packet? req)
261                                        (mailbox-send!
262                                                (get-local-mailbox (remote-mailbox-packet-mailbox-name req) #t)
263                                                (remote-mailbox-packet-mailbox-value req))]
264                                [else
265                                        (signal
266            (make-remote-mailbox-exception 'remote-mailbox-server
267              "request from remote mailbox client not understood"
268              req))])) )
269                (remote-mailbox-server) )
270
271(define (%make-remote-mailbox-server listener)
272        (make-tcp-server listener remote-mailbox-server) )
273
274(define name->mailbox (make-dict-unique/synch 'name->mailbox))
275
276(define (get-local-mailbox name #!optional (create? #t))
277        (check-mailbox-name name 'get-local-mailbox)
278        (%let/synch ([n->o name->mailbox])
279                (or (dict-ref n->o name)
280                                (if create?
281                                        (let ([ch (make-mailbox name)])
282                                                (dict-set! n->o name ch)
283                                                ch )
284                                        #f)) ) )
285
286(define (drop-local-mailbox! name)
287        (%let/synch ([n->o name->mailbox])
288                (dict-delete! n->o name) ) )
289
290(define (make-remote-mailbox-server #!optional (port (default-remote-mailbox-port)))
291        (check-port port 'make-remote-mailbox-server)
292        (%make-remote-mailbox-server ((remote-mailbox-listen-procedure) port)) )
293
294(define run-remote-mailbox-server
295        (let ([server #f])
296                (lambda (#!optional (port (default-remote-mailbox-port)))
297                        (unless server
298                                (check-port port 'run-remote-mailbox-server)
299                                (let ([listener ((remote-mailbox-listen-procedure) port)])
300                                        (set! server
301                                                (make-thread
302                                                        (cute (%make-remote-mailbox-server listener) "remote-mailbox-server")
303                                                        'remote-mailbox-server))
304                                        (thread-specific-set! server listener)
305                                        (thread-start! server)))
306                        server) ) )
307
308(define (remote-mailbox-server-listener server)
309        (unless (and (thread? server) (eq? 'remote-mailbox-server (thread-name)))
310                (error 'remote-mailbox-server-listener "not a server thread" server))
311        (thread-specific server) )
Note: See TracBrowser for help on using the repository browser.