Commit | Line | Data |
---|---|---|
d30542c2 AW |
1 | ;;; Repl server |
2 | ||
5e74217c | 3 | ;; Copyright (C) 2003, 2010, 2011, 2014 Free Software Foundation, Inc. |
d30542c2 AW |
4 | |
5 | ;; This library is free software; you can redistribute it and/or | |
6 | ;; modify it under the terms of the GNU Lesser General Public | |
7 | ;; License as published by the Free Software Foundation; either | |
8 | ;; version 3 of the License, or (at your option) any later version. | |
9 | ;; | |
10 | ;; This library is distributed in the hope that it will be useful, | |
11 | ;; but WITHOUT ANY WARRANTY; without even the implied warranty of | |
12 | ;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU | |
13 | ;; Lesser General Public License for more details. | |
14 | ;; | |
15 | ;; You should have received a copy of the GNU Lesser General Public | |
16 | ;; License along with this library; if not, write to the Free Software | |
17 | ;; Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA | |
18 | ;; 02110-1301 USA | |
19 | ||
20 | ;;; Code: | |
21 | ||
22 | (define-module (system repl server) | |
23 | #:use-module (system repl repl) | |
24 | #:use-module (ice-9 threads) | |
5ecc5811 MW |
25 | #:use-module (ice-9 match) |
26 | #:use-module (srfi srfi-1) | |
d30542c2 AW |
27 | #:export (make-tcp-server-socket |
28 | make-unix-domain-server-socket | |
29 | run-server | |
30 | spawn-server | |
31 | stop-server-and-clients!)) | |
32 | ||
5ecc5811 MW |
33 | ;; List of pairs of the form (SOCKET . FORCE-CLOSE), where SOCKET is a |
34 | ;; socket port, and FORCE-CLOSE is a thunk that forcefully shuts down | |
35 | ;; the socket. | |
d30542c2 AW |
36 | (define *open-sockets* '()) |
37 | ||
38 | (define sockets-lock (make-mutex)) | |
39 | ||
5ecc5811 | 40 | ;; WARNING: it is unsafe to call 'close-socket!' from another thread. |
b0a31499 | 41 | ;; Note: although not exported, this is used by (system repl coop-server) |
d30542c2 AW |
42 | (define (close-socket! s) |
43 | (with-mutex sockets-lock | |
5ecc5811 | 44 | (set! *open-sockets* (assq-remove! *open-sockets* s))) |
d30542c2 AW |
45 | ;; Close-port could block or raise an exception flushing buffered |
46 | ;; output. Hmm. | |
47 | (close-port s)) | |
48 | ||
b0a31499 | 49 | ;; Note: although not exported, this is used by (system repl coop-server) |
5ecc5811 | 50 | (define (add-open-socket! s force-close) |
d30542c2 | 51 | (with-mutex sockets-lock |
5ecc5811 | 52 | (set! *open-sockets* (acons s force-close *open-sockets*)))) |
d30542c2 AW |
53 | |
54 | (define (stop-server-and-clients!) | |
55 | (cond | |
56 | ((with-mutex sockets-lock | |
5ecc5811 MW |
57 | (match *open-sockets* |
58 | (() #f) | |
59 | (((s . force-close) . rest) | |
60 | (set! *open-sockets* rest) | |
61 | force-close))) | |
62 | => (lambda (force-close) | |
63 | (force-close) | |
d30542c2 AW |
64 | (stop-server-and-clients!))))) |
65 | ||
66 | (define* (make-tcp-server-socket #:key | |
67 | (host #f) | |
68 | (addr (if host (inet-aton host) INADDR_LOOPBACK)) | |
69 | (port 37146)) | |
70 | (let ((sock (socket PF_INET SOCK_STREAM 0))) | |
71 | (setsockopt sock SOL_SOCKET SO_REUSEADDR 1) | |
72 | (bind sock AF_INET addr port) | |
73 | sock)) | |
74 | ||
75 | (define* (make-unix-domain-server-socket #:key (path "/tmp/guile-socket")) | |
76 | (let ((sock (socket PF_UNIX SOCK_STREAM 0))) | |
77 | (setsockopt sock SOL_SOCKET SO_REUSEADDR 1) | |
78 | (bind sock AF_UNIX path) | |
79 | sock)) | |
80 | ||
5ecc5811 MW |
81 | ;; List of errno values from 'select' or 'accept' that should lead to a |
82 | ;; retry in 'run-server'. | |
83 | (define errs-to-retry | |
84 | (delete-duplicates | |
85 | (filter-map (lambda (name) | |
86 | (and=> (module-variable the-root-module name) | |
87 | variable-ref)) | |
88 | '(EINTR EAGAIN EWOULDBLOCK)))) | |
89 | ||
d30542c2 | 90 | (define* (run-server #:optional (server-socket (make-tcp-server-socket))) |
b0a31499 | 91 | (run-server* server-socket serve-client)) |
5ecc5811 | 92 | |
b0a31499 DT |
93 | ;; Note: although not exported, this is used by (system repl coop-server) |
94 | (define (run-server* server-socket serve-client) | |
5ecc5811 MW |
95 | ;; We use a pipe to notify the server when it should shut down. |
96 | (define shutdown-pipes (pipe)) | |
97 | (define shutdown-read-pipe (car shutdown-pipes)) | |
98 | (define shutdown-write-pipe (cdr shutdown-pipes)) | |
99 | ||
100 | ;; 'shutdown-server' is called by 'stop-server-and-clients!'. | |
101 | (define (shutdown-server) | |
102 | (display #\! shutdown-write-pipe) | |
103 | (force-output shutdown-write-pipe)) | |
104 | ||
105 | (define monitored-ports | |
106 | (list server-socket | |
107 | shutdown-read-pipe)) | |
108 | ||
d30542c2 AW |
109 | (define (accept-new-client) |
110 | (catch #t | |
5ecc5811 MW |
111 | (lambda () |
112 | (let ((ready-ports (car (select monitored-ports '() '())))) | |
113 | ;; If we've been asked to shut down, return #f. | |
114 | (and (not (memq shutdown-read-pipe ready-ports)) | |
115 | (accept server-socket)))) | |
116 | (lambda k-args | |
117 | (let ((err (system-error-errno k-args))) | |
118 | (cond | |
119 | ((memv err errs-to-retry) | |
120 | (accept-new-client)) | |
121 | (else | |
122 | (warn "Error accepting client" k-args) | |
123 | ;; Retry after a timeout. | |
124 | (sleep 1) | |
125 | (accept-new-client))))))) | |
126 | ||
127 | ;; Put the socket into non-blocking mode. | |
128 | (fcntl server-socket F_SETFL | |
129 | (logior O_NONBLOCK | |
130 | (fcntl server-socket F_GETFL))) | |
131 | ||
adf43b3f | 132 | (sigaction SIGPIPE SIG_IGN) |
5ecc5811 | 133 | (add-open-socket! server-socket shutdown-server) |
d30542c2 AW |
134 | (listen server-socket 5) |
135 | (let lp ((client (accept-new-client))) | |
136 | ;; If client is false, we are shutting down. | |
137 | (if client | |
138 | (let ((client-socket (car client)) | |
139 | (client-addr (cdr client))) | |
d30542c2 | 140 | (make-thread serve-client client-socket client-addr) |
5ecc5811 MW |
141 | (lp (accept-new-client))) |
142 | (begin (close shutdown-write-pipe) | |
143 | (close shutdown-read-pipe) | |
144 | (close server-socket))))) | |
d30542c2 AW |
145 | |
146 | (define* (spawn-server #:optional (server-socket (make-tcp-server-socket))) | |
147 | (make-thread run-server server-socket)) | |
148 | ||
149 | (define (serve-client client addr) | |
5ecc5811 MW |
150 | |
151 | (let ((thread (current-thread))) | |
152 | ;; Close the socket when this thread exits, even if canceled. | |
153 | (set-thread-cleanup! thread (lambda () (close-socket! client))) | |
154 | ;; Arrange to cancel this thread to forcefully shut down the socket. | |
155 | (add-open-socket! client (lambda () (cancel-thread thread)))) | |
156 | ||
d30542c2 AW |
157 | (with-continuation-barrier |
158 | (lambda () | |
5e74217c MW |
159 | (parameterize ((current-input-port client) |
160 | (current-output-port client) | |
161 | (current-error-port client) | |
162 | (current-warning-port client)) | |
163 | (with-fluids ((*repl-stack* '())) | |
5ecc5811 | 164 | (start-repl)))))) |