source: project/release/4/remote-mailbox/trunk/remote-mailbox-client.scm @ 35329

Last change on this file since 35329 was 35329, checked in by kon, 15 months ago

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

File size: 5.7 KB
Line 
1;;;; remote-mailbox-client.scm
2;;;; Kon Lovett, Sep '09
3
4;; Issues
5;;
6;; - Currently the client input port is unused.
7
8(module remote-mailbox-client
9
10(;export
11  ;;common
12  ;parameters
13  default-remote-mailbox-tcp-port-no
14  default-remote-mailbox-hostname
15  ;;client
16  ;parameters
17  default-remote-mailbox-connect
18  ;operations
19  remote-mailbox
20  remote-mailbox?
21  remote-mailbox-name
22  remote-mailbox-hostname
23  remote-mailbox-tcp-port
24  remote-mailbox-connected?
25  drop-remote-mailbox!
26  drop-remote-mailboxes!
27  remote-mailboxes
28  remote-mailbox-send!)
29
30(import scheme chicken)
31(use
32  tcp
33  (only srfi-18 make-mutex mutex-name)
34  (only data-structures conc)
35  (only moremacros ->boolean define-warning-parameter)
36  (only type-errors warning-argument-type)
37  mailbox
38  synch
39  lookup-table-synch
40  (only type-checks check-procedure define-check+error-type)
41  remote-mailbox-adapter
42  remote-mailbox-packet
43  remote-mailbox-common)
44
45;;; Utilities
46
47;;; Support
48
49(define-type remote-mailbox (struct remote-mailbox))
50(define-type mailbox-name symbol)
51(define-type hostname string)
52
53(: remote-mailbox-name (remote-mailbox -> mailbox-name))
54(: remote-mailbox-hostname (remote-mailbox -> hostname))
55;
56(define-record-type remote-mailbox
57  (*make-remote-mailbox name hstnam prtnum serializer connect mutex input output)
58  *remote-mailbox?
59  (name remote-mailbox-name remote-mailbox-name-set!)
60  (hstnam remote-mailbox-hostname)
61  (prtnum remote-mailbox-tcp-port)
62  (serializer remote-mailbox-serializer)
63  (connect remote-mailbox-connect)
64  (mutex remote-mailbox-mutex)
65  (input remote-mailbox-input-port remote-mailbox-input-port-set!)
66  (output remote-mailbox-output-port remote-mailbox-output-port-set!) )
67
68(define (invalidate-remote-mailbox! rmb)
69  (remote-mailbox-name-set! rmb #f) )
70
71(define (valid-remote-mailbox? rmb)
72  (->boolean (remote-mailbox-name rmb)) )
73
74(define (remote-mailbox-key rmb)
75  (mutex-name (remote-mailbox-mutex rmb)) )
76
77(define +remote-mailbox-key->remote-mailbox+ (make-dict/synch))
78
79(define (make-remote-mailbox-key name hostname tcp-port)
80  (conc name #\@ hostname (if tcp-port (conc #\: tcp-port) "")) )
81
82(define (*remote-mailbox name hostname tcp-port connect)
83  (let ((key (make-remote-mailbox-key name hostname tcp-port)))
84    (dict-indempotent-ref!/synch +remote-mailbox-key->remote-mailbox+
85      key
86      (lambda (def)
87        (*make-remote-mailbox
88          name
89          hostname tcp-port
90          (serializer) connect
91          (make-mutex key) #f #f))) ) )
92
93(define (*remote-mailbox-connected? rmb)
94  (->boolean (remote-mailbox-output-port rmb)) )
95
96(define (connection/remote-mailbox rmb)
97  (if (*remote-mailbox-connected? rmb)
98    (remote-mailbox-output-port rmb)
99    ;else make a connection
100    (let-values (
101      ((in out)
102        (let (
103          (connect (remote-mailbox-connect rmb))
104          (tcp-port (remote-mailbox-tcp-port rmb)) )
105          ;Allow hostname to carry service/portno
106          (if (not tcp-port)
107            (connect (remote-mailbox-hostname rmb))
108            (connect (remote-mailbox-hostname rmb) tcp-port) ) ) ) )
109      (remote-mailbox-input-port-set! rmb in)
110      (remote-mailbox-output-port-set! rmb out)
111      out )) )
112
113(define (close-remote-mailbox-connection! rmb)
114  (close-input-port (remote-mailbox-input-port rmb))
115  (remote-mailbox-input-port-set! rmb #f)
116  (close-output-port (remote-mailbox-output-port rmb))
117  (remote-mailbox-output-port-set! rmb #f)
118  (invalidate-remote-mailbox! rmb) )
119
120(define (*drop-remote-mailbox! rmb)
121  (record/synch remote-mailbox rmb
122    (close-remote-mailbox-connection! rmb)
123    (dict-delete!/synch +remote-mailbox-key->remote-mailbox+
124      (remote-mailbox-key rmb)) ) )
125
126;;; Exported
127
128;; Parameters
129
130(define (remote-mailbox-connector? x)
131  (or (not x) (procedure? x)) )
132
133(: default-remote-mailbox-connect (#!optional (or boolean procedure) -> procedure))
134;
135(define-warning-parameter default-remote-mailbox-connect tcp-connect remote-mailbox-connector
136  ;ugh, automagic identifier injection
137  (unless obj (set! obj tcp-connect)) )
138
139;; Operations
140
141(: remote-mailbox (mailbox-name #!rest -> remote-mailbox))
142;
143(define (remote-mailbox name
144          #!key
145          (hostname (default-remote-mailbox-hostname))
146          (tcp-port (default-remote-mailbox-tcp-port-no))
147          (connect (default-remote-mailbox-connect)))
148  (*remote-mailbox
149    (check-mailbox-name 'remote-mailbox name 'name)
150    (check-hostname 'remote-mailbox hostname 'hostname)
151    (or tcp-port (check-tcp-port-no 'remote-mailbox tcp-port 'tcp-port))
152    (check-procedure 'remote-mailbox connect 'connect)) )
153
154(: remote-mailbox? (* -> boolean : remote-mailbox))
155;
156(define (remote-mailbox? obj)
157  (and (*remote-mailbox? obj) (valid-remote-mailbox? obj)) )
158
159(define-check+error-type remote-mailbox)
160
161(: remote-mailbox-connected? (remote-mailbox -> boolean))
162;
163(define (remote-mailbox-connected? rmb)
164  (*remote-mailbox-connected? (check-remote-mailbox 'remote-mailbox-connected? rmb)) )
165
166(: remote-mailboxes (-> (list-of remote-mailbox)))
167;
168(define (remote-mailboxes)
169  (dict-values/synch +remote-mailbox-key->remote-mailbox+) )
170
171(: drop-remote-mailbox! (remote-mailbox -> void))
172;
173(define (drop-remote-mailbox! rmb)
174  (*drop-remote-mailbox! (check-remote-mailbox 'drop-remote-mailbox! rmb)) )
175
176(: drop-remote-mailboxes! (-> void))
177;
178(define (drop-remote-mailboxes!)
179  (for-each (cut *drop-remote-mailbox! <>) (remote-mailboxes)) )
180
181(: remote-mailbox-send! (remote-mailbox * -> void))
182;
183(define (remote-mailbox-send! rmb val)
184  (record/synch remote-mailbox (check-remote-mailbox 'remote-mailbox-send! rmb)
185    (let (
186      (out (connection/remote-mailbox rmb))
187      (req (make-remote-mailbox-packet (remote-mailbox-name rmb) val)) )
188      (parameterize ((serializer (remote-mailbox-serializer rmb)))
189        (serialize req out) ) ) ) )
190
191) ;module remote-mailbox-client
192
Note: See TracBrowser for help on using the repository browser.