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