source: project/release/3/remote-repl/trunk/remote-repl-server.scm @ 11665

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

fixes and version bump

File size: 17.2 KB
Line 
1;;;; egg:        remote-repl
2;;;; file:       remote-repl-server.scm
3;;;; author:     elf <elf@ephemeral.net>
4;;;; date:       16 Aug 2008
5;;;; purpose:    server 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 session print timeout.
13;;;;             20080817 [elf]  Fix for sleep(2) blocking behaviour and
14;;;;                             main thread blocking.  (reported by certainty)
15;;;;             20080817 [elf]  Bumped version to 1.1.0
16;;;;             20080817 [elf]  Fix for sleep(2) behaviour in compiled code.
17;;;;             20080817 [elf]  sleep (from unit posix) redefined to
18;;;;                             thread-sleep! (from unit srfi-18).
19;;;;             20080817 [elf]  Compilation warnings cleaned up.
20;;;;             20080817 [elf]  Bumped version to 1.1.1
21;;;;
22
23
24
25;;; chicken library loading
26
27
28(require-extension posix)     ; POSIX wrapper library
29(require-extension tcp)       ; tcp sockets
30(require-extension srfi-1)    ; list library
31(require-extension srfi-18)   ; lightweight thread library
32
33
34
35;;; chicken compile-time directives
36
37
38(eval-when (compile)
39    (declare
40        (uses library extras eval tcp posix srfi-1 srfi-18)
41        (bound-to-procedure
42            rrepl-server-new
43            rrepl-server?
44            rrepl-server:close-listen
45            rrepl-server:close-listen!
46            rrepl-server:read
47            rrepl-server:read!
48            rrepl-server:eval
49            rrepl-server:eval!
50            rrepl-server:print
51            rrepl-server:print!
52            rrepl-server:close
53            rrepl-server:close!
54            rrepl-server:listener
55            rrepl-server:listener!
56            rrepl-server:listen-thr
57            rrepl-server:listen-thr!
58            rrepl-server:remotes
59            rrepl-server:remotes!
60            rrepl-server:accepting
61            rrepl-server:accepting!
62            rrepl-server:active
63            rrepl-server:active!
64            rrepl-session-new
65            rrepl-session?
66            rrepl-session:inport
67            rrepl-session:inport!
68            rrepl-session:outport
69            rrepl-session:outport!
70            rrepl-session:thread
71            rrepl-session:thread!
72            rrepl-session:extra
73            rrepl-session:extra!
74            rrepl-session:active
75            rrepl-session:active!
76            close-listen
77            auth-default
78            eval-default
79            close
80            condition-msg
81            condition-loc
82            condition-arg
83            serialise-exn
84            make-session-thread
85            make-listener-thread
86            rrepl-server-start
87            rrepl-server-close
88            )
89        (export
90            rrepl-server?
91            rrepl-server:close-listen
92            rrepl-server:read
93            rrepl-server:eval
94            rrepl-server:print
95            rrepl-server:close
96            rrepl-server:listener
97            rrepl-server:listen-thr
98            rrepl-server:remotes
99            rrepl-server:accepting
100            rrepl-server:accepting!
101            rrepl-server:active
102            rrepl-server:active!
103            rrepl-session?
104            rrepl-session:inport
105            rrepl-session:outport
106            rrepl-session:thread
107            rrepl-session:extra
108            rrepl-session:extra!
109            rrepl-session:active
110            rrepl-session:active!
111            rrepl-server-start
112            rrepl-server-close
113            sleep
114            )
115        (emit-exports "remote-repl-server.exports")
116        (unused
117            rrepl-server:close-listen!
118            rrepl-server:read!
119            rrepl-server:eval!
120            rrepl-server:print!
121            rrepl-server:close!
122            )
123        (inline)
124        (inline-limit 100)
125        (lambda-lift)
126        (disable-interrupts)
127        (no-bound-checks)
128        (no-procedure-checks)
129        (standard-bindings)
130        (extended-bindings)
131        (usual-integrations)
132    ))
133
134
135
136;;; system overrides
137
138
139;; sleep -> thread-sleep! to prevent indefinite blocking
140(define sleep    thread-sleep!)
141
142
143
144;;; data structures
145
146
147;; record: rrepl-server
148;; structure containing general server data
149;; fields:
150;;    clisten    (close-listen) : proc to close the listener port (serv)
151;;    reader     (read)         : proc to read from the input port (iport)
152;;    evaler     (eval)         : proc to eval locally (expr sess)
153;;    printer    (print)        : proc to print to the output port (expr oport)
154;;    close      (close)        : proc to close the session ports (serv sess)
155;;    listener   (listener)     : listener port
156;;    lthread    (listen-thr)   : listener thread
157;;    rthreads   (remotes)      : list of active sessions
158;;    accepting  (accepting)    : boolean, is listener thread active?
159;;    active     (active)       : boolean, is server running?
160(define-record-type rrepl-server
161    (rrepl-server-new clisten reader evaler printer close
162                      listener lthread rthreads accepting active)
163    rrepl-server?
164        (clisten      rrepl-server:close-listen    rrepl-server:close-listen!)
165        (reader       rrepl-server:read            rrepl-server:read!)
166        (evaler       rrepl-server:eval            rrepl-server:eval!)
167        (printer      rrepl-server:print           rrepl-server:print!)
168        (close        rrepl-server:close           rrepl-server:close!)
169        (listener     rrepl-server:listener        rrepl-server:listener!)
170        (lthread      rrepl-server:listen-thr      rrepl-server:listen-thr!)
171        (rthreads     rrepl-server:remotes         rrepl-server:remotes!)
172        (accepting    rrepl-server:accepting       rrepl-server:accepting!)
173        (active       rrepl-server:active          rrepl-server:active!)
174    )
175
176;; record: rrepl-session
177;; structure containing per-session data
178;; fields:
179;;    inport  :  input socket port
180;;    outport :  output socket port
181;;    thread  :  thread containing session repl
182;;    extra   :  user-definable data
183;;    active  :  boolean, is session active?
184(define-record-type rrepl-session
185    (rrepl-session-new inport outport thread extra active)
186    rrepl-session?
187        (inport     rrepl-session:inport     rrepl-session:inport!)
188        (outport    rrepl-session:outport    rrepl-session:outport!)
189        (thread     rrepl-session:thread     rrepl-session:thread!)
190        (extra      rrepl-session:extra      rrepl-session:extra!)
191        (active     rrepl-session:active     rrepl-session:active!)
192    )
193
194
195
196;;; generic and default procedures
197
198
199;; (close-listen SOCKET-LISTENER-CLOSE-PROC)
200;; wrapper for cleanup when closing listener port
201(define (close-listen clisten)
202    (lambda (serv)
203        (condition-case
204            (clisten (rrepl-server:listener serv))
205                (var ()    #f))
206        (rrepl-server:listener! serv #f)
207        (rrepl-server:accepting! serv #f)))
208
209;; (auth-default SERVER-RECORD SESSION-RECORD)
210;; default handler for authentication (do nothing and return session)
211(define (auth-default serv sess)
212    sess)
213
214;; (eval-default EXPRESSION SESSION-RECORD)
215;; default handler for evaluating expressions (call eval)
216(define (eval-default expr sess)
217    (eval expr))
218
219;; (print-default EXPRESSION OUTPUT-PORT)
220;; default handler/wrapper for output (newline is important!)
221(define (print-default expr port)
222    (write expr port)
223    (newline port))
224
225;; (close INPUT-PORT-CLOSE-PROC OUTPUT-PORT-CLOSE-PROC)
226;; wrapper for cleanup when closing a session
227(define (close close-in close-out)
228    (lambda (serv sess)
229        (condition-case
230            (close-in (rrepl-session:inport sess))
231                (var ()    #f))
232        (condition-case
233            (close-out (rrepl-session:outport sess))
234                (var ()    #f))
235        (rrepl-session:inport! sess #f)
236        (rrepl-session:outport! sess #f)
237        (rrepl-session:active! sess #f)
238        (rrepl-server:remotes! serv (delete sess (rrepl-server:remotes serv)))))
239
240
241
242;;; repl error printers
243
244
245;; (condition-msg CONDITION)
246;; message component of exception
247(define condition-msg    (condition-property-accessor 'exn 'message))
248
249;; (condition-loc CONDITION)
250;; location (caller) component of exception
251(define condition-loc    (condition-property-accessor 'exn 'location))
252
253;; (condition-arg CONDITION)
254;; arguments component of exception
255(define condition-arg    (condition-property-accessor 'exn 'arguments))
256
257;; (serialise-exn CONDITION)
258;; create output string from an error in eval stage
259(define (serialise-exn e)
260    (conc "condition: " (##sys#slot e 1)
261          " - " (condition-msg e)
262          (if (condition-arg e)
263              (conc "   args: " (condition-arg e))
264              "")
265          (if (condition-loc e)
266              (conc "   in procedure " (condition-loc e))
267              "")))
268
269
270
271;;; thread procedures
272
273
274;; (make-session-thread SERVER-RECORD SESSION-RECORD)
275;; create a new session thread
276(define (make-session-thread serv sess)
277    (make-thread
278        (lambda ()
279            (define (rrepl-session-close)
280                (rrepl-session:active! sess 1)
281                "shutting down session...")
282            (let loop ()
283                (if (and (rrepl-server:active serv)
284                         (rrepl-session:active sess))
285                    (let* ((t   #t)
286                           (r   (condition-case
287                                    ((rrepl-server:read serv)
288                                      (rrepl-session:inport sess))
289                                        (var ()
290                                            (if (string=?
291                                                    (condition-msg var)
292                                                    "read operation timed out")
293                                                (set! t #f)
294                                                ((rrepl-server:close serv)
295                                                    serv sess)))))
296                           (e   (and t
297                                     (rrepl-session:active sess)
298                                     (rrepl-server:active serv)
299                                     (if (equal? r '(rrepl-session-close))
300                                         (rrepl-session-close)
301                                         (condition-case
302                                             ((rrepl-server:eval serv) r sess)
303                                                 (var ()
304                                                     (serialise-exn var))))))
305                           (p   (and t
306                                     (rrepl-session:active sess)
307                                     (let ploop ((s   #t))
308                                         (condition-case
309                                             ((rrepl-server:print serv)
310                                               e
311                                               (rrepl-session:outport sess))
312                                                 (var ()
313                                                     (if (string=?
314                                                             (condition-msg var)
315                                                             "write operation timed out")
316                                                         (set! s #f)
317                                                         ((rrepl-server:close serv)
318                                                             serv sess))))
319                                         (or s
320                                             (ploop #t))))))
321                        (and (eq? (rrepl-session:active sess) 1)
322                             (rrepl-session:active! sess #f))
323                        (thread-yield!)
324                        (loop))
325                    ((rrepl-server:close serv) serv sess))))))
326
327;; (make-listener-thread SERVER-RECORD SOCKET-ACCEPT-PROC AUTH-PROC)
328;; create a new listener thread
329(define (make-listener-thread serv accept auth)
330    (make-thread
331        (lambda ()
332            (let loop ()
333                (if (and (rrepl-server:accepting serv)
334                         (rrepl-server:active serv))
335                    (let* ((s   (call-with-values
336                                    (lambda ()
337                                        (condition-case
338                                            (accept
339                                              (rrepl-server:listener serv))
340                                                (val ()
341                                                    (values #f #f))))
342                                    (lambda (i o)
343                                        (and (rrepl-server:active serv)
344                                             (rrepl-server:accepting serv)
345                                             i
346                                             (auth serv
347                                                  (rrepl-session-new
348                                                      i
349                                                      o
350                                                      #f
351                                                      #f
352                                                      #t))))))
353                           (t   (and s
354                                     (rrepl-server:active serv)
355                                     (rrepl-server:accepting serv)
356                                     (make-session-thread serv s))))
357                        (and t
358                             (rrepl-server:active serv)
359                             (rrepl-server:accepting serv)
360                             (rrepl-session:thread! s t)
361                             (rrepl-server:remotes! serv
362                                 (cons s (rrepl-server:remotes serv)))
363                             (thread-quantum-set! t
364                                 (+ (tcp-read-timeout)
365                                    (quotient (tcp-read-timeout) 5)))
366                             (thread-start! t))
367                        (thread-yield!)
368                        (loop))
369                    ((rrepl-server:close-listen serv) serv))))))
370
371
372
373;;; high-level interface
374
375
376;; rrepl-server-start
377;; starts a new remote repl server
378;; args:
379;;    port           : integer, port to listen for connections
380;;    listen         : proc to listen on a port (port backlog host)
381;;    accept         : proc to accept connections (listener-port)
382;;    clisten        : proc to close listener port (listener-port)
383;;    auth           : proc to authenticate connections (serv sess)
384;;    host           : string hostname/ip to only allow connections from
385;;    backlog        : integer, number of pending connections for listener
386;;    timeout-read   : integer time in ms for read timeout
387;;    timeout-write  : integer time in ms for write timeout
388;;    timeout-accept : integer time in ms for accept timeout
389;;    reader         : proc to read from input port (iport)
390;;    evaler         : proc to eval locally (expr sess)
391;;    printer        : proc to print to output port (expr oport)
392;;    close-in       : proc to close input port (iport)
393;;    close-out      : proc to close output port (oport)
394(define (rrepl-server-start port #!key (listen           tcp-listen)
395                                       (accept           tcp-accept)
396                                       (clisten          tcp-close)
397                                       (auth             auth-default)
398                                       (host             #f)
399                                       (backlog          4)
400                                       (timeout-read     50000)
401                                       (timeout-write    50000)
402                                       (timeout-accept   50000)
403                                       (reader           read)
404                                       (evaler           eval-default)
405                                       (printer          print-default)
406                                       (close-in         close-input-port)
407                                       (close-out        close-output-port))
408    (##sys#check-range port 1 32767 'rrepl-server-start)
409    (tcp-accept-timeout timeout-accept)
410    (tcp-read-timeout timeout-read)
411    (tcp-write-timeout timeout-write)
412    (thread-quantum-set! (current-thread)
413        (- timeout-read (quotient timeout-read 5)))
414    (let* ((s   (rrepl-server-new (close-listen clisten)
415                                  reader
416                                  evaler
417                                  printer
418                                  (close close-in close-out)
419                                  (listen port backlog host)
420                                  #f
421                                  '()
422                                  #t
423                                  #t))
424           (t   (make-listener-thread s accept auth)))
425        (rrepl-server:listen-thr! s t)
426        (thread-quantum-set! t 1000)
427        (thread-start! t)
428        s))
429
430;; (rrepl-server-close SERVER-RECORD)
431;; shut down the server and all connections
432(define (rrepl-server-close serv)
433    (##sys#check-structure serv 'rrepl-server 'rrepl-server-close)
434    (rrepl-server:active! serv #f)
435    (thread-join! (rrepl-server:listen-thr serv))
436    (for-each
437        (lambda (x)
438            (thread-join! (rrepl-session:thread x)))
439        (rrepl-server:remotes serv))
440    #t)
441
Note: See TracBrowser for help on using the repository browser.