source: project/release/4/vandusen/trunk/vandusen-remote.scm @ 39080

Last change on this file since 39080 was 39080, checked in by Moritz Heidkamp, 3 months ago

vandusen: Work around the fact taht dynamic-wind's after thunk is not invoked when the main thunk is exited via an error

File size: 2.5 KB
Line 
1(module vandusen-remote ()
2
3(import chicken scheme)
4(require-library regex)
5(import irregex)
6(use extras srfi-13 vandusen tcp srfi-18 ports)
7
8(plugin 'remote
9        (lambda ()
10          (let ((listener (tcp-listen ($ 'remote-port)
11                                      (or ($ 'remote-backlog) 10)
12                                      (or ($ 'remote-host) "localhost"))))
13            (add-finalizer (lambda ()
14                             (debug "finalizing remote listener")
15                             (tcp-close listener)))
16
17            (thread-start! (lambda ()
18                             (parameterize ((tcp-read-timeout 3000))
19                               (let loop ()
20                                 (condition-case
21                                     (receive (in out) (tcp-accept listener)
22                                              (thread-start! (lambda ()
23                                                               (dynamic-wind+
24                                                                   void
25                                                                   (lambda ()
26                                                                     (let ((line (read-line in)))
27                                                                       (and-let* ((match (irregex-match
28                                                                                          '(seq (submatch (+ (~ space)))
29                                                                                                " "
30                                                                                                (submatch (+ any)))
31                                                                                          line)))
32                                                                         (say (string-trim (irregex-match-substring match 2))
33                                                                              (irregex-match-substring match 1)))))
34                                                                   (lambda ()
35                                                                     (close-input-port in)
36                                                                     (close-output-port out)))))
37                                              (loop))
38                                   (e (exn i/o net)
39                                      (print-error-message e (current-error-port) "Error on tcp-accept")
40                                      (flush-output (current-error-port))
41                                      (loop))))))))))
42
43)
Note: See TracBrowser for help on using the repository browser.