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

Last change on this file since 34761 was 34761, checked in by Kon Lovett, 2 years ago

re-flow

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