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

Last change on this file since 19860 was 19860, checked in by kon, 9 years ago

Uses condition-utils. Client params gen warning for bad arg.

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-deserializer
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/server
25    drop-local-mailbox!/server
26    local-mailbox-names/server
27    remote-mailbox-server-run!
28    remote-mailbox-server-start!
29    ;; Queries
30    remote-mailbox-server?
31    remote-mailbox-server-name
32    remote-mailbox-server-auto-create?
33    remote-mailbox-server-deserializer
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
43  (import
44    scheme
45    chicken
46    (only srfi-18 make-thread thread-start! mutex-name)
47    (only data-structures identity)
48    tcp
49    (only miscmacros define-parameter while)
50    tcp-server
51    s11n
52    mailbox
53    lookup-table-synch
54    type-checks
55    type-errors
56    condition-utils
57    remote-mailbox-common)
58
59  (require-library
60    srfi-18 data-structures tcp
61    tcp-server s11n mailbox miscmacros lookup-table-synch type-checks
62    condition-utils
63    remote-mailbox-common)
64
65;;; Conditions
66
67(define (make-remote-mailbox-server-condition msg rmbs args kind)
68  (make-exn-condition+
69    'remote-mailbox-tcp-server
70    msg
71    (cons (remote-mailbox-server-name rmbs) args)
72    'remote-mailbox kind) )
73
74(define (remote-mailbox-server-mailbox-exception rmbs . args)
75  (abort (make-remote-mailbox-server-condition "no such mailbox" rmbs args 'mailbox)) )
76
77(define (remote-mailbox-server-request-exception rmbs . args)
78  (abort (make-remote-mailbox-server-condition "unknown remote mailbox client request"  rmbs args 'request)) )
79
80;;; Server Side
81
82;;
83
84(define-record-type remote-mailbox-server
85  (*make-remote-mailbox-server dctm nm autof desrl srvr lstnr rlim dbg thrd)
86  remote-mailbox-server?
87  (dctm remote-mailbox-server-dict/synch)
88  (nm remote-mailbox-server-name)
89  (autof remote-mailbox-server-auto-create?)
90  (desrl remote-mailbox-server-deserializer)
91  (srvr remote-mailbox-server-tcp-server remote-mailbox-server-tcp-server-set!)
92  (lstnr remote-mailbox-server-listener)
93  (rlim remote-mailbox-server-request-limit)
94  (dbg remote-mailbox-server-debug) )
95
96;; Parameters
97
98(define-constant default-request-count-limit 10000)
99
100(define-parameter default-remote-mailbox-deserializer #f
101  (lambda (x)
102        (cond
103          ((procedure? x)   x)
104      ((not x)          #f)
105      (else
106        (warning-argument-type 'default-remote-mailbox-deserializer x 'procedure)
107        (default-remote-mailbox-deserializer) ) ) ) )
108
109(define-parameter default-remote-mailbox-listen tcp-listen
110  (lambda (x)
111        (cond
112          ((procedure? x) x)
113      (else
114        (warning-argument-type 'default-remote-mailbox-listen x 'procedure)
115        (default-remote-mailbox-listen) ) ) ) )
116
117(define-parameter default-remote-mailbox-auto-create? #t identity)
118
119;; Support
120
121(define-check+error-type remote-mailbox-server)
122
123(define (*local-mailbox/server rmbs name create?)
124        (dict-indempotent-ref!/synch
125    (remote-mailbox-server-dict/synch rmbs)
126    name
127    (lambda (def) (if create? (make-mailbox name) def))) )
128
129(define ((make-remote-mailbox-server-thunk rmbs))
130  (while (not (eof-object? (peek-char (current-input-port))))
131    (let ((req (deserialize (current-input-port) (remote-mailbox-server-deserializer rmbs))))
132      (cond ((eq? (void) req) ) ;ignore void transmissions
133            ((remote-mailbox-packet? req)
134              (let* ((nam (remote-mailbox-packet-key req))
135                     (lmb (*local-mailbox/server rmbs nam (remote-mailbox-server-auto-create? rmbs))) )
136                (if lmb (mailbox-send! lmb (remote-mailbox-packet-value req))
137                    (remote-mailbox-server-mailbox-exception rmbs nam)) ) )
138            (else
139              (remote-mailbox-server-request-exception rmbs req) ) ) ) ) )
140
141(define (*remote-mailbox-server-run! rmbs)
142        ((remote-mailbox-server-tcp-server rmbs) (remote-mailbox-server-debug rmbs)) )
143
144(define (*make-remote-mailbox-server-thread rmbs)
145  (make-thread (lambda () (*remote-mailbox-server-run! rmbs)) (remote-mailbox-server-name rmbs)) )
146
147(define (*remote-mailbox-server-start! rmbs)
148        (thread-start! (*make-remote-mailbox-server-thread rmbs)) )
149
150;; Exported
151
152(define (make-remote-mailbox-server
153          #!key (tcp-port (default-remote-mailbox-tcp-port))
154                (listen (default-remote-mailbox-listen))
155                (deserializer (default-remote-mailbox-deserializer))
156                (name (gensym 'remote-mailbox-server:))
157                (auto-create? (default-remote-mailbox-auto-create?))
158                (request-limit default-request-count-limit)
159                debug)
160        (check-tcp-port 'make-remote-mailbox-server tcp-port 'tcp-port)
161        (check-procedure 'make-remote-mailbox-server listen 'listen)
162        (when deserializer (check-procedure 'make-remote-mailbox-server deserializer 'deserializer))
163        (check-fixnum 'make-remote-mailbox-server request-limit 'request-limit)
164  (let* ((listener (listen tcp-port))
165         (rmbs (*make-remote-mailbox-server (make-dict/synch) name auto-create?
166                                            deserializer #f listener request-limit
167                                            debug #f))
168         (tcps (make-tcp-server listener
169                                (make-remote-mailbox-server-thunk rmbs)
170                                request-limit)) )
171    (remote-mailbox-server-tcp-server-set! rmbs tcps)
172    rmbs ) )
173
174(define (make-remote-mailbox-server-thread rmbs)
175        (check-remote-mailbox-server 'make-remote-mailbox-server-thread rmbs)
176  (*make-remote-mailbox-server-thread rmbs) )
177
178;;
179
180(define (remote-mailbox-server-run! rmbs)
181        (check-remote-mailbox-server 'remote-mailbox-server-run! rmbs)
182        (*remote-mailbox-server-run! rmbs) )
183
184(define (remote-mailbox-server-start! rmbs)
185        (check-remote-mailbox-server 'remote-mailbox-server-start! rmbs)
186        (*remote-mailbox-server-start! rmbs) )
187
188;;
189
190(define (local-mailbox/server rmbs name #!optional (create? (remote-mailbox-server-auto-create? rmbs)))
191        (check-remote-mailbox-server 'local-mailbox/server rmbs)
192        (check-mailbox-name 'local-mailbox/server name)
193        (*local-mailbox/server rmbs name create?) )
194
195(define (drop-local-mailbox!/server rmbs name)
196        (check-remote-mailbox-server 'drop-local-mailbox!/server rmbs)
197        (check-mailbox-name 'drop-local-mailbox!/server name)
198        (dict-delete!/synch (remote-mailbox-server-dict/synch rmbs) name) )
199
200(define (local-mailbox-names/server rmbs)
201        (check-remote-mailbox-server 'remote-mailbox-server-mailbox-names rmbs)
202        (dict-keys/synch (remote-mailbox-server-dict/synch rmbs)) )
203
204;;; Convenience
205
206(define local-mailbox-start!)
207(define local-mailbox-server)
208(define local-mailbox-thread)
209(define local-mailbox)
210(let ((rmbs #f) (thrd #f))
211
212  (set! local-mailbox-start!
213    (lambda (#!optional debug)
214      (unless rmbs
215        (set! rmbs (make-remote-mailbox-server #:name 'default-remote-mailbox-server #:debug debug))
216        (set! thrd (*remote-mailbox-server-start! rmbs)) ) ) )
217
218  (set! local-mailbox-server (lambda () rmbs))
219
220  (set! local-mailbox-thread (lambda () thrd))
221
222  (set! local-mailbox
223    (lambda (name #!optional debug)
224      (check-mailbox-name 'local-mailbox name)
225      (unless rmbs (local-mailbox-start! debug))
226      (*local-mailbox/server rmbs name #t) ) ) )
227
228) ;module remote-mailbox-server
Note: See TracBrowser for help on using the repository browser.