source: project/release/4/remote-mailbox/trunk/remote-mailbox-client.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: 5.5 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
14    default-remote-mailbox-hostname
15    ;; Client
16    ; Parameters
17    default-remote-mailbox-connect
18    default-remote-mailbox-serializer
19    ; Operations
20    remote-mailbox
21    remote-mailbox?
22    remote-mailbox-name
23    remote-mailbox-hostname
24    remote-mailbox-tcp-port
25    remote-mailbox-connected?
26    drop-remote-mailbox!
27    drop-remote-mailboxes!
28    remote-mailboxes
29    remote-mailbox-send!)
30
31  (import
32    scheme
33    chicken
34    tcp
35    (only srfi-18 make-mutex mutex-name)
36    (only data-structures conc)
37    (only miscmacros define-parameter)
38    s11n
39    mailbox
40    synch
41    lookup-table-synch
42    (only type-checks check-procedure define-check+error-type)
43    (only type-errors warning-argument-type)
44    remote-mailbox-common)
45
46  (require-library
47    tcp srfi-18
48    miscmacros s11n mailbox synch lookup-table-synch
49    type-checks type-errors
50    remote-mailbox-common)
51
52;;; Utilities
53
54(define (->boolean x) (and x #t))
55
56;;; Support
57
58(define-record-type remote-mailbox
59        (*make-remote-mailbox name hstnam prtnum connect mutex input output)
60        *remote-mailbox?
61        (name remote-mailbox-name remote-mailbox-name-set!)
62        (hstnam remote-mailbox-hostname)
63        (prtnum remote-mailbox-tcp-port)
64        (connect remote-mailbox-connect)
65        (mutex remote-mailbox-mutex)
66        (input remote-mailbox-input-port remote-mailbox-input-port-set!)
67        (output remote-mailbox-output-port remote-mailbox-output-port-set!) )
68
69(define (invalidate-remote-mailbox! rmb) (remote-mailbox-name-set! rmb #f))
70(define (valid-remote-mailbox? rmb) (->boolean (remote-mailbox-name rmb)))
71
72(define (remote-mailbox-key rmb) (mutex-name (remote-mailbox-mutex rmb)))
73
74(define +remote-mailbox-key->remote-mailbox+ (make-dict/synch))
75
76(define (make-remote-mailbox-key name hostname tcp-port)
77        (conc name #\@ hostname (if tcp-port (conc #\: tcp-port) "")) )
78
79(define (*remote-mailbox name hostname tcp-port connect)
80  (let ((key (make-remote-mailbox-key name hostname tcp-port)))
81    (dict-indempotent-ref!/synch
82      +remote-mailbox-key->remote-mailbox+
83      key
84      (lambda (def)
85        (*make-remote-mailbox name hostname tcp-port connect (make-mutex key) #f #f))) ) )
86
87(define (*remote-mailbox-connected? rmb) (->boolean (remote-mailbox-output-port rmb)))
88
89(define (connection/remote-mailbox rmb)
90        (if (*remote-mailbox-connected? rmb) (remote-mailbox-output-port rmb)
91      ; else make a connection
92      (let-values (((in out)
93                    (let ((connect (remote-mailbox-connect rmb))
94                          (tcp-port (remote-mailbox-tcp-port rmb)) )
95                      ; Allow hostname to carry service/portno
96                      (if (not tcp-port) (connect (remote-mailbox-hostname rmb))
97                          (connect (remote-mailbox-hostname rmb) tcp-port) ) ) ) )
98        (remote-mailbox-input-port-set! rmb in)
99        (remote-mailbox-output-port-set! rmb out)
100        out )) )
101
102(define (close-remote-mailbox-connection! rmb)
103  (close-input-port (remote-mailbox-input-port rmb))
104        (remote-mailbox-input-port-set! rmb #f)
105        (close-output-port (remote-mailbox-output-port rmb))
106        (remote-mailbox-output-port-set! rmb #f)
107        (invalidate-remote-mailbox! rmb) )
108
109(define (*drop-remote-mailbox! rmb)
110        (record/synch remote-mailbox rmb
111    (close-remote-mailbox-connection! rmb)
112    (dict-delete!/synch +remote-mailbox-key->remote-mailbox+ (remote-mailbox-key rmb)) ) )
113
114(define-check+error-type remote-mailbox)
115
116;;; Exported
117
118;; Parameters
119
120(define-parameter default-remote-mailbox-serializer #f
121  (lambda (x)
122        (cond
123          ((procedure? x) x)
124      ((not x)        #f)
125      (else
126        (warning-argument-type 'default-remote-mailbox-serializer x 'procedure)
127        (default-remote-mailbox-serializer))) ) )
128
129(define-parameter default-remote-mailbox-connect tcp-connect
130  (lambda (x)
131        (cond
132          ((procedure? x) x)
133      (else
134        (warning-argument-type 'default-remote-mailbox-connect x 'procedure)
135        (default-remote-mailbox-connect) ) ) ) )
136
137;; Operations
138
139(define (remote-mailbox name #!key (hostname (default-remote-mailbox-hostname))
140                                   (tcp-port (default-remote-mailbox-tcp-port))
141                                   (connect (default-remote-mailbox-connect)))
142        (check-mailbox-name 'remote-mailbox name 'name)
143        (check-hostname 'remote-mailbox hostname 'hostname)
144        (when tcp-port (check-tcp-port 'remote-mailbox tcp-port 'tcp-port))
145        (check-procedure 'remote-mailbox connect 'connect)
146        (*remote-mailbox name hostname tcp-port connect) )
147
148(define (remote-mailbox? obj)
149        (and (*remote-mailbox? obj) (valid-remote-mailbox? obj)) )
150
151(define (remote-mailbox-connected? rmb)
152        (check-remote-mailbox 'remote-mailbox-connected? rmb)
153        (*remote-mailbox-connected? rmb) )
154
155(define (remote-mailboxes)
156        (dict-values/synch +remote-mailbox-key->remote-mailbox+) )
157
158(define (drop-remote-mailbox! rmb)
159        (check-remote-mailbox 'drop-remote-mailbox! rmb)
160        (*drop-remote-mailbox! rmb) )
161
162(define (drop-remote-mailboxes!)
163  (for-each (cut *drop-remote-mailbox! <>) (remote-mailboxes)) )
164
165(define (remote-mailbox-send! rmb val #!optional (serializer (default-remote-mailbox-serializer)))
166        (check-remote-mailbox 'remote-mailbox-send! rmb)
167        (when serializer (check-procedure 'remote-mailbox serializer 'serializer))
168        (record/synch remote-mailbox rmb
169                (let ((out (connection/remote-mailbox rmb))
170                      (req (make-remote-mailbox-packet (remote-mailbox-name rmb) val)) )
171                        (serialize req out serializer) ) ) )
172
173) ;module remote-mailbox-client
174
Note: See TracBrowser for help on using the repository browser.