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