source: project/release/4/remote-mailbox/trunk/remote-mailbox-server.scm

Last change on this file was 35329, checked in by Kon Lovett, 17 months ago

add types, deprecate '/' style identifiers, use moremacros define-warning-parameter, reflow

File size: 9.9 KB
Line 
1;;;; remote-mailbox-server.scm
2;;;; Kon Lovett, Sep '09
3;;;; Kon Lovett, Sep '17
4
5;; Issues
6;;
7;; - Currently the server output port is ignored since the client input port is
8;; closed!
9
10(module remote-mailbox-server
11
12(;export
13  ;; Common
14  ; Parameters
15  default-remote-mailbox-tcp-port-no
16  default-remote-mailbox-hostname
17  ;; Server
18  ; Parameters
19  default-remote-mailbox-listen
20  default-remote-mailbox-auto-create?
21  ; Operations
22  make-remote-mailbox-server
23  make-remote-mailbox-server-thread
24  local-mailbox-for-server
25  drop-local-mailbox!-for-server
26  local-mailbox-names-for-server
27  remote-mailbox-server-run!
28  remote-mailbox-server-start!
29  remote-mailbox-server-stop!
30  ;; Queries
31  remote-mailbox-server?
32  remote-mailbox-server-name
33  remote-mailbox-server-auto-create?
34  remote-mailbox-server-listener
35  remote-mailbox-server-request-limit
36  remote-mailbox-server-debug
37  ;; Convenience
38  local-mailbox-server
39  local-mailbox-thread
40  local-mailbox-start!
41  local-mailbox
42  ;;DEPERCATED
43  default-remote-mailbox-tcp-port
44  local-mailbox/server
45  drop-local-mailbox!/server
46  local-mailbox-names/server)
47
48(import scheme chicken)
49(use
50  (only srfi-18 make-thread thread-start! mutex-name thread-join!)
51  (only data-structures identity)
52  tcp
53  (only miscmacros define-parameter while)
54  (only moremacros define-warning-parameter)
55  tcp-server
56  mailbox
57  lookup-table-synch
58  type-checks
59  type-errors
60  condition-utils
61  remote-mailbox-adapter
62  remote-mailbox-packet
63  remote-mailbox-common)
64
65;;;
66
67(define-type mailbox (struct mailbox))
68(define-type mailbox-name symbol)
69(define-type tcp-port-no fixnum)
70(define-type hostname string)
71
72(define-type remote-mailbox-server (struct remote-mailbox-server))
73
74;;; Conditions
75
76(: make-remote-mailbox-server-condition (string remote-mailbox-server list (or condition symbol list) -> condition))
77;
78(define (make-remote-mailbox-server-condition msg rmbs args kind)
79  (make-exn-condition+
80    'remote-mailbox-tcp-server
81    msg
82    (cons (remote-mailbox-server-name rmbs) args)
83    'remote-mailbox kind) )
84
85(define (remote-mailbox-server-mailbox-exception rmbs . args)
86  (abort (make-remote-mailbox-server-condition "no such mailbox" rmbs args 'mailbox)) )
87
88(define (remote-mailbox-server-request-exception rmbs . args)
89  (abort (make-remote-mailbox-server-condition "unknown remote mailbox client request" rmbs args 'request)) )
90
91;;; Server Side
92
93;;
94
95(: remote-mailbox-server? (* -> boolean : remote-mailbox-server))
96(: remote-mailbox-server-name (remote-mailbox-server -> *))
97(: remote-mailbox-server-auto-create? (remote-mailbox-server -> boolean))
98(: remote-mailbox-server-listener (remote-mailbox-server -> tcp-listener))
99(: remote-mailbox-server-request-limit (remote-mailbox-server -> fixnum))
100(: remote-mailbox-server-debug (remote-mailbox-server -> *))
101;
102(define-record-type remote-mailbox-server
103  (*make-remote-mailbox-server dctm nm autof desrl srvr thread lstnr rlim dbg thrd)
104  remote-mailbox-server?
105  (dctm remote-mailbox-server-dict/synch)
106  (nm remote-mailbox-server-name)
107  (autof remote-mailbox-server-auto-create?)
108  (desrl remote-mailbox-server-deserializer)
109  (srvr remote-mailbox-server-tcp-server remote-mailbox-server-tcp-server-set!)
110  (thread remote-mailbox-server-thread remote-mailbox-server-thread-set!)
111  (lstnr remote-mailbox-server-listener)
112  (rlim remote-mailbox-server-request-limit)
113  (dbg remote-mailbox-server-debug) )
114
115(define-check+error-type remote-mailbox-server)
116
117;; Parameters
118
119(define-constant DEFAULT-REQUEST-COUNT-LIMIT 10000)
120
121(define (remote-mailbox-listener? x)
122  (or (not x) (procedure? x)) )
123
124(: default-remote-mailbox-listen (#!optional (or boolean procedure) -> procedure))
125;
126(define-warning-parameter default-remote-mailbox-listen tcp-listen remote-mailbox-listener
127  ;ugh, automagic identifier injection
128  (unless obj (set! obj tcp-listen)) )
129
130(: default-remote-mailbox-auto-create? (#!optional boolean -> boolean))
131;
132(define-parameter default-remote-mailbox-auto-create? #t identity)
133
134;; Support
135
136(: *local-mailbox-for-server (remote-mailbox-server * boolean -> mailbox))
137;
138(define (*local-mailbox-for-server rmbs name create?)
139  (dict-indempotent-ref!/synch
140    (remote-mailbox-server-dict/synch rmbs)
141    name
142    (lambda (def) (if create? (make-mailbox name) def))) )
143
144(: make-remote-mailbox-server-thunk (remote-mailbox-server #!optional input-port -> procedure))
145;
146(define ((make-remote-mailbox-server-thunk rmbs) #!optional (inp (current-input-port)))
147  (while (not (eof-object? (peek-char inp)))
148    (let (
149      (req
150        (parameterize ((deserializer (remote-mailbox-server-deserializer rmbs)))
151          (deserialize inp))) )
152      (cond
153        ((eq? (void) req)
154          ;ignore void transmissions
155          )
156        ((remote-mailbox-packet? req)
157          (let* (
158            (nam
159              (remote-mailbox-packet-key req))
160            (lmb
161              (*local-mailbox-for-server
162                rmbs nam (remote-mailbox-server-auto-create? rmbs))) )
163            (if lmb
164              (mailbox-send! lmb (remote-mailbox-packet-value req))
165              (remote-mailbox-server-mailbox-exception rmbs nam)) ) )
166        (else
167          (remote-mailbox-server-request-exception rmbs req) ) ) ) ) )
168
169(define (*remote-mailbox-server-run! rmbs)
170  ((remote-mailbox-server-tcp-server rmbs) (remote-mailbox-server-debug rmbs)) )
171
172(define (*make-remote-mailbox-server-thread rmbs)
173  (remote-mailbox-server-thread-set! rmbs
174    (make-thread
175      (lambda () (*remote-mailbox-server-run! rmbs))
176      (remote-mailbox-server-name rmbs)))
177  (remote-mailbox-server-thread rmbs) )
178
179(define (*remote-mailbox-server-start! rmbs)
180  (thread-start! (*make-remote-mailbox-server-thread rmbs)) )
181
182(define (*remote-mailbox-server-stop! rmbs)
183  (handle-exceptions
184    ;as
185    ex
186    ;with
187    (void)
188    ;in
189    (tcp-close (remote-mailbox-server-listener rmbs))
190    (thread-join! (remote-mailbox-server-thread rmbs)) ) )
191
192;; Exported
193
194(: make-remote-mailbox-server (#!rest -> remote-mailbox-server))
195;
196(define (make-remote-mailbox-server
197          #!key
198          (tcp-port-no (default-remote-mailbox-tcp-port-no))
199          (listen (default-remote-mailbox-listen))
200          (name (gensym 'remote-mailbox-server:))
201          (auto-create? (default-remote-mailbox-auto-create?))
202          (request-limit DEFAULT-REQUEST-COUNT-LIMIT)
203          debug)
204  (check-tcp-port-no 'make-remote-mailbox-server tcp-port-no 'tcp-port-no)
205  (check-procedure 'make-remote-mailbox-server listen 'listen)
206  (check-fixnum 'make-remote-mailbox-server request-limit 'request-limit)
207  (let* (
208    (rmbs
209      (*make-remote-mailbox-server
210        (make-dict/synch)
211        name
212        auto-create?
213        (deserializer)
214        #f #f
215        (listen tcp-port-no)
216        request-limit
217        debug #f))
218    (tcps
219      (make-tcp-server
220        (remote-mailbox-server-listener rmbs)
221        (make-remote-mailbox-server-thunk rmbs)
222        (remote-mailbox-server-request-limit rmbs))) )
223    (remote-mailbox-server-tcp-server-set! rmbs tcps)
224    rmbs ) )
225
226(: make-remote-mailbox-server-thread (remote-mailbox-server -> thread))
227;
228(define (make-remote-mailbox-server-thread rmbs)
229  (*make-remote-mailbox-server-thread
230    (check-remote-mailbox-server 'make-remote-mailbox-server-thread rmbs)) )
231
232;;
233
234(: remote-mailbox-server-run! (remote-mailbox-server -> void))
235;
236(define (remote-mailbox-server-run! rmbs)
237  (*remote-mailbox-server-run!
238    (check-remote-mailbox-server 'remote-mailbox-server-run! rmbs)) )
239
240(: remote-mailbox-server-start! (remote-mailbox-server -> thread))
241;
242(define (remote-mailbox-server-start! rmbs)
243  (*remote-mailbox-server-start!
244    (check-remote-mailbox-server 'remote-mailbox-server-start! rmbs)) )
245
246(: remote-mailbox-server-stop! (remote-mailbox-server -> void))
247;
248(define (remote-mailbox-server-stop! rmbs)
249  (*remote-mailbox-server-stop!
250    (check-remote-mailbox-server 'remote-mailbox-server-stop! rmbs)) )
251
252;;
253
254(: local-mailbox-for-server (remote-mailbox-server mailbox-name -> mailbox))
255;
256(define (local-mailbox-for-server rmbs name #!optional (create? (remote-mailbox-server-auto-create? rmbs)))
257  (*local-mailbox-for-server
258    (check-remote-mailbox-server 'local-mailbox-for-server rmbs)
259    (check-mailbox-name 'local-mailbox-for-server name) create?) )
260
261(: drop-local-mailbox!-for-server (remote-mailbox-server mailbox-name -> void))
262;
263(define (drop-local-mailbox!-for-server rmbs name)
264  (dict-delete!/synch
265    (remote-mailbox-server-dict/synch
266      (check-remote-mailbox-server 'drop-local-mailbox!-for-server rmbs))
267    (check-mailbox-name 'drop-local-mailbox!-for-server name)) )
268
269(: local-mailbox-names-for-server (remote-mailbox-server -> (list-of string)))
270;
271(define (local-mailbox-names-for-server rmbs)
272  (dict-keys/synch
273    (remote-mailbox-server-dict/synch
274      (check-remote-mailbox-server 'remote-mailbox-server-mailbox-names rmbs))) )
275
276;;; Convenience
277
278(define +rmbs+ #f)
279(define +thrd+ #f)
280
281(: local-mailbox-start! (#!optional * -> void))
282;
283(define (local-mailbox-start! #!optional debug)
284  (unless +rmbs+
285    (set! +rmbs+ (make-remote-mailbox-server #:name 'default-remote-mailbox-server #:debug debug))
286    (set! +thrd+ (*remote-mailbox-server-start! +rmbs+)) ) )
287
288(: local-mailbox-server (-> remote-mailbox-server))
289;
290(define (local-mailbox-server)
291  +rmbs+ )
292
293(: local-mailbox-thread (-> thread))
294;
295(define (local-mailbox-thread)
296  +thrd+ )
297
298(: local-mailbox (mailbox-name #!optional * -> mailbox))
299;
300(define (local-mailbox name #!optional debug)
301  (unless +rmbs+ (local-mailbox-start! debug))
302  (*local-mailbox-for-server +rmbs+ (check-mailbox-name 'local-mailbox name) #t) )
303
304;;DEPRECATED
305
306(: local-mailbox/server deprecated)
307(define local-mailbox/server local-mailbox-for-server)
308
309(: drop-local-mailbox!/server deprecated)
310(define drop-local-mailbox!/server drop-local-mailbox!-for-server)
311
312(: local-mailbox-names/server (deprecated local-mailbox-names-for-server))
313(define local-mailbox-names/server local-mailbox-names-for-server)
314
315;(: default-remote-mailbox-tcp-port (deprecated default-remote-mailbox-tcp-port-no))
316
317) ;module remote-mailbox-server
Note: See TracBrowser for help on using the repository browser.