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
39(define (run-server port-or-path)
40
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)))
49
50    ;; Initialize server socket.
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.
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)
194