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

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

test for compiled code

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