source: project/release/4/remote-mailbox/tags/2.1.0/remote-mailbox-server.scm @ 33908

Last change on this file since 33908 was 33908, checked in by kon, 2 years ago

mv serialize to adapter module

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