Commit | Line | Data |
---|---|---|
ea19f0b3 NJ |
1 | ;;;; Guile Debugger UI server |
2 | ||
3 | ;;; Copyright (C) 2003 Free Software Foundation, Inc. | |
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 2.1 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., 59 Temple Place, Suite 330, Boston, MA 02111-1307 USA | |
18 | ||
19 | (define-module (ice-9 gds-server) | |
20 | #:export (run-server)) | |
21 | ||
22 | ;; UI is normally via a pipe to Emacs, so make sure to flush output | |
23 | ;; every time we write. | |
24 | (define (write-to-ui form) | |
25 | (write form) | |
26 | (newline) | |
27 | (force-output)) | |
28 | ||
29 | (define (trc . args) | |
30 | (write-to-ui (cons '* args))) | |
31 | ||
32 | (define (with-error->eof proc port) | |
33 | (catch #t | |
34 | (lambda () (proc port)) | |
35 | (lambda args the-eof-object))) | |
36 | ||
37 | (define connection->id (make-object-property)) | |
38 | ||
e2d23cc0 | 39 | (define (run-server port-or-path) |
ea19f0b3 | 40 | |
e2d23cc0 NJ |
41 | (or (integer? port-or-path) |
42 | (string? port-or-path) | |
43 | (error "port-or-path should be an integer (port number) or a string (file name)" | |
44 | port-or-path)) | |
45 | ||
46 | (let ((server (socket (if (integer? port-or-path) PF_INET PF_UNIX) | |
47 | SOCK_STREAM | |
48 | 0))) | |
ea19f0b3 NJ |
49 | |
50 | ;; Initialize server socket. | |
e2d23cc0 NJ |
51 | (if (integer? port-or-path) |
52 | (begin | |
53 | (setsockopt server SOL_SOCKET SO_REUSEADDR 1) | |
54 | (bind server AF_INET INADDR_ANY port-or-path)) | |
55 | (begin | |
56 | (catch #t | |
57 | (lambda () (delete-file port-or-path)) | |
58 | (lambda _ #f)) | |
59 | (bind server AF_UNIX port-or-path))) | |
60 | ||
61 | ;; Start listening. | |
ea19f0b3 NJ |
62 | (listen server 5) |
63 | ||
64 | (let loop ((clients '()) (readable-sockets '())) | |
65 | ||
66 | (define (do-read port) | |
67 | (cond ((eq? port (current-input-port)) | |
68 | (do-read-from-ui)) | |
69 | ((eq? port server) | |
70 | (accept-new-client)) | |
71 | (else | |
72 | (do-read-from-client port)))) | |
73 | ||
74 | (define (do-read-from-ui) | |
75 | (trc "reading from ui") | |
76 | (let* ((form (with-error->eof read (current-input-port))) | |
77 | (client (assq-ref (map (lambda (port) | |
78 | (cons (connection->id port) port)) | |
79 | clients) | |
80 | (car form)))) | |
81 | (with-error->eof read-char (current-input-port)) | |
82 | (if client | |
83 | (begin | |
84 | (write (cdr form) client) | |
85 | (newline client)) | |
86 | (trc "client not found"))) | |
87 | clients) | |
88 | ||
89 | (define (accept-new-client) | |
90 | (let ((new-port (car (accept server)))) | |
91 | ;; Read the client's ID. | |
92 | (let ((name-form (read new-port))) | |
93 | ;; Absorb the following newline character. | |
94 | (read-char new-port) | |
95 | ;; Check that we have a name form. | |
96 | (or (eq? (car name-form) 'name) | |
97 | (error "Invalid name form:" name-form)) | |
98 | ;; Store an association from the connection to the ID. | |
99 | (set! (connection->id new-port) (cadr name-form)) | |
100 | ;; Pass the name form on to Emacs. | |
101 | (write-to-ui (cons (connection->id new-port) name-form))) | |
102 | ;; Add the new connection to the set that we select on. | |
103 | (cons new-port clients))) | |
104 | ||
105 | (define (do-read-from-client port) | |
106 | (trc "reading from client") | |
107 | (let ((next-char (with-error->eof peek-char port))) | |
108 | ;;(trc 'next-char next-char) | |
109 | (cond ((eof-object? next-char) | |
110 | (write-to-ui (list (connection->id port) 'closed)) | |
111 | (close port) | |
112 | (delq port clients)) | |
113 | ((char=? next-char #\() | |
114 | (write-to-ui (cons (connection->id port) | |
115 | (with-error->eof read port))) | |
116 | clients) | |
117 | (else | |
118 | (with-error->eof read-char port) | |
119 | clients)))) | |
120 | ||
121 | ;;(trc 'clients clients) | |
122 | ;;(trc 'readable-sockets readable-sockets) | |
123 | ||
124 | (if (null? readable-sockets) | |
125 | (loop clients (car (select (cons (current-input-port) | |
126 | (cons server clients)) | |
127 | '() | |
128 | '()))) | |
129 | (loop (do-read (car readable-sockets)) (cdr readable-sockets)))))) | |
130 | ||
131 | ;; What happens if there are multiple copies of Emacs running on the | |
132 | ;; same machine, and they all try to start up the GDS server? They | |
133 | ;; can't all listen on the same TCP port, so the short answer is that | |
134 | ;; all of them except the first will get an EADDRINUSE error when | |
135 | ;; trying to bind. | |
136 | ;; | |
137 | ;; We want to be able to handle this scenario, though, so that Scheme | |
138 | ;; code can be evaluated, and help invoked, in any of those Emacsen. | |
139 | ;; So we introduce the idea of a "slave server". When a new GDS | |
140 | ;; server gets an EADDRINUSE bind error, the implication is that there | |
141 | ;; is already a GDS server running, so the new server instead connects | |
142 | ;; to the existing one (by issuing a connect to the GDS port number). | |
143 | ;; | |
144 | ;; Let's call the first server the "master", and the new one the | |
145 | ;; "slave". In principle the master can now proxy any GDS client | |
146 | ;; connections through to the slave, so long as there is sufficient | |
147 | ;; information in the protocol for it to decide when and how to do | |
148 | ;; this. | |
149 | ;; | |
150 | ;; The basic information and mechanism that we need for this is as | |
151 | ;; follows. | |
152 | ;; | |
153 | ;; - A unique ID for each Emacs; this can be each Emacs's PID. When a | |
154 | ;; slave server connects to the master, it announces itself by sending | |
155 | ;; the protocol (emacs ID). | |
156 | ;; | |
157 | ;; - A way for a client to indicate which Emacs it wants to use. At | |
158 | ;; the protocol level, this is an extra argument in the (name ...) | |
159 | ;; protocol. (The absence of this argument means "no preference". A | |
160 | ;; simplistic master server might then decide to use its own Emacs; a | |
161 | ;; cleverer one might monitor which Emacs appears to be most in use, | |
162 | ;; and use that one.) At the API level this can be an optional | |
163 | ;; argument to the `gds-connect' procedure, and the Emacs GDS code | |
164 | ;; would obviously set this argument when starting a client from | |
165 | ;; within Emacs. | |
166 | ;; | |
167 | ;; We also want a strategy for continuing seamlessly if the master | |
168 | ;; server shuts down. | |
169 | ;; | |
170 | ;; - Each slave server will detect this as an error on the connection | |
171 | ;; to the master socket. Each server then tries to bind to the GDS | |
172 | ;; port again (a race which the OS will resolve), and if that fails, | |
173 | ;; connect again. The result of this is that there should be a new | |
174 | ;; master, and the others all slaves connected to the new master. | |
175 | ;; | |
176 | ;; - Each client will also detect this as an error on the connection | |
177 | ;; to the (master) server. Either the client should try to connect | |
178 | ;; again (perhaps after a short delay), or the reconnection can be | |
179 | ;; delayed until the next time that the client requires the server. | |
180 | ;; (Probably the latter, all done within `gds-read'.) | |
181 | ;; | |
182 | ;; (Historical note: Before this master-slave idea, clients were | |
183 | ;; identified within gds-server.scm and gds*.el by an ID which was | |
184 | ;; actually the file descriptor of their connection to the server. | |
185 | ;; That is no good in the new scheme, because each client's ID must | |
186 | ;; persist when the master server changes, so we now use the client's | |
187 | ;; PID instead. We didn't use PID before because the client/server | |
188 | ;; code was written to be completely asynchronous, which made it | |
189 | ;; tricky for the server to discover each client's PID and associate | |
190 | ;; it with a particular connection. Now we solve that problem by | |
191 | ;; handling the initial protocol exchange synchronously.) | |
192 | (define (run-slave-server port) | |
193 | 'not-implemented) |