source: project/release/3/remote-repl/trunk/remote-repl-client.scm @ 11674

Last change on this file since 11674 was 11674, checked in by elf, 12 years ago

licence update, tcp-read-timeout clash fix, examples added

File size: 7.6 KB
Line 
1;;;; egg:        remote-repl
2;;;; file:       remote-repl-client.scm
3;;;; author:     elf <elf@ephemeral.net>
4;;;; date:       16 Aug 2008
5;;;; purpose:    client component of the remote repl
6;;;;
7;;;; licence:    BSD (see LICENCE)
8;;;; copyright:  Copyright (C) 2008, Elf
9;;;;             All rights reserved.
10;;;;
11;;;; changelog:  20080816 [elf]  Initial release.
12;;;;             20080817 [elf]  Fix for read timeouts. (reported by certainty)
13;;;;             20080817 [elf]  Bumped version to 1.1.0
14;;;;             20080817 [elf]  Compilation warnings cleaned up.
15;;;;             20080817 [elf]  Bumped version to 1.1.1
16;;;;             20080817 [elf]  Bumped version to 1.1.2
17;;;;             20080817 [elf]  Removed timeout due to conflict with server.
18;;;;                             Fixed output behaviour.
19;;;;             20080817 [elf]  Bumped version to 1.1.3
20;;;;
21
22
23
24;;; chicken library loading
25
26
27(require-extension tcp)       ; tcp sockets
28(require-extension srfi-18)   ; lightweight thread library
29
30
31
32;;; chicken compile-time directives
33
34
35(eval-when (compile)
36    (declare
37        (uses library extras eval tcp srfi-18)
38        (bound-to-procedure
39            rrepl-client-new
40            rrepl-client?
41            rrepl-client:read
42            rrepl-client:read!
43            rrepl-client:print
44            rrepl-client:print!
45            rrepl-client:close
46            rrepl-client:close!
47            rrepl-client:inport
48            rrepl-client:inport!
49            rrepl-client:outport
50            rrepl-client:outport!
51            rrepl-client:active
52            rrepl-client:active!
53            print-default
54            auth-default
55            close
56            condition-msg
57            rrepl-client-connect
58            rrepl-client-send
59            rrepl-client-close
60        )
61        (export
62            rrepl-client?
63            rrepl-client:read
64            rrepl-client:print
65            rrepl-client:close
66            rrepl-client:inport
67            rrepl-client:outport
68            rrepl-client:active
69            rrepl-client-connect
70            rrepl-client-send
71            rrepl-client-close
72            )
73        (emit-exports "remote-repl-client.exports")
74        (unused
75            rrepl-client:read!
76            rrepl-client:print!
77            rrepl-client:close!
78            )
79        (inline)
80        (inline-limit 100)
81        (lambda-lift)
82        (disable-interrupts)
83        (no-bound-checks)
84        (no-procedure-checks)
85        (standard-bindings)
86        (extended-bindings)
87        (usual-integrations)
88    ))
89
90
91
92;;; data structures
93
94
95;; record: rrepl-client
96;; structure containing client (remote controller) data
97;; fields:
98;;    reader   (read)    :  proc to read a line from input port (iport)
99;;    printer  (print)   :  proc to print (send) to output port (expr oport)
100;;    close    (close)   :  proc to close client ports (client)
101;;    inport   (inport)  :  input socket port
102;;    outport  (outport) :  output socket port
103;;    active   (active)  :  boolean, is client active?
104(define-record-type rrepl-client
105    (rrepl-client-new reader printer close inport outport active)
106    rrepl-client?
107        (reader     rrepl-client:read       rrepl-client:read!)
108        (printer    rrepl-client:print      rrepl-client:print!)
109        (close      rrepl-client:close      rrepl-client:close!)
110        (inport     rrepl-client:inport     rrepl-client:inport!)
111        (outport    rrepl-client:outport    rrepl-client:outport!)
112        (active     rrepl-client:active     rrepl-client:active!)
113    )
114
115
116
117;; generic and default procedures
118
119
120;; (print-default EXPRESSION OUTPUT-PORT)
121;; default handler for sending data (newline is important!)
122(define (print-default expr port)
123    (write expr port)
124    (newline port))
125
126;; (auth-default CLIENT-RECORD)
127;; default handler for authentication (do nothing and return client record)
128(define (auth-default cli)
129    cli)
130
131;; (close INPUT-PORT-CLOSE-PROC OUTPUT-PORT-CLOSE-PROC)
132;; wrapper for cleanup when closing client ports
133(define (close close-in close-out)
134    (lambda (cli)
135        (condition-case
136            (close-in (rrepl-client:inport cli))
137                (var ()    #f))
138        (condition-case
139            (close-out (rrepl-client:outport cli))
140                (var ()    #f))
141        (rrepl-client:inport! cli #f)
142        (rrepl-client:outport! cli #f)
143        (rrepl-client:active! cli #f)))
144
145;; (condition-msg CONDITION)
146;; message component of exception
147(define condition-msg    (condition-property-accessor 'exn 'message))
148
149
150
151;;; high-level interface
152
153
154;; rrepl-client-connect
155;; connect to a remote-repl server
156;; args:
157;;    host       :  string hostname/ip where server resides
158;;    port       :  integer port number where server resides
159;;    connect    :  proc to perform socket connection (host port)
160;;    auth       :  proc to handle authentication (client)
161;;    reader     :  proc to read a line from input port (iport)
162;;    printer    :  proc to send data to output port (expr oport)
163;;    close-in   :  proc to close input port (iport)
164;;    close-out  :  proc to close output port (oport)
165(define (rrepl-client-connect host port #!key (connect     tcp-connect)
166                                              (auth        auth-default)
167                                              (reader      read-line)
168                                              (printer     print-default)
169                                              (close-in    close-input-port)
170                                              (close-out   close-output-port))
171    (##sys#check-string host 'rrepl-client-connect)
172    (##sys#check-range port 1 32767 'rrepl-client-connect)
173    (call-with-values
174        (lambda ()
175            (connect host port))
176        (lambda (i o)
177            (auth (rrepl-client-new reader
178                                    printer
179                                    (close close-in close-out)
180                                    i
181                                    o
182                                    #t)))))
183
184;; (rrepl-client-send CLIENT-RECORD EXPRESSION)
185;; send data for evaluation on remote server and get result
186(define (rrepl-client-send cli expr)
187    (##sys#check-structure cli 'rrepl-client 'rrepl-client-send)
188    (if (rrepl-client:active cli)
189        (begin
190            (condition-case
191                ((rrepl-client:print cli) expr (rrepl-client:outport cli))
192                    (var ()
193                        ((rrepl-client:close cli) cli)
194                        (display "write error - closing\n")))
195            (if (rrepl-client:active cli)
196                (let ploop ((t   #t)
197                            (r   ##sys#undefined-value))
198                    (condition-case
199                        (set! r
200                            ((rrepl-client:read cli) (rrepl-client:inport cli)))
201                            (var ()
202                                (if (string=? (condition-msg var)
203                                              "read operation timed out")
204                                    (set! t #f)
205                                    (begin
206                                        ((rrepl-client:close cli) cli)
207                                        (display "read error - closing\n")))))
208                    (if t
209                        r
210                        (ploop #t ##sys#undefined-value)))))
211        (display "client is not active\n")))
212
213;; (rrepl-client-close CLIENT-RECORD)
214;; shut down a client connection
215(define (rrepl-client-close cli)
216    (##sys#check-structure cli 'rrepl-client 'rrepl-client-close)
217    (if (rrepl-client:active cli)
218        (begin
219            (display (rrepl-client-send cli '(rrepl-session-close)))
220            (newline)
221            ((rrepl-client:close cli) cli))
222        #t))
223
Note: See TracBrowser for help on using the repository browser.