guile/module/ice-9/gds-server.scm

;;;; Guile Debugger UI server

;;; Copyright (C) 2003 Free Software Foundation, Inc.
;;;
;;;; This library is free software; you can redistribute it and/or
;;;; modify it under the terms of the GNU Lesser General Public
;;;; License as published by the Free Software Foundation; either
;;;; version 3 of the License, or (at your option) any later version.
;;;; 
;;;; This library is distributed in the hope that it will be useful,
;;;; but WITHOUT ANY WARRANTY; without even the implied warranty of
;;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the GNU
;;;; Lesser General Public License for more details.
;;;; 
;;;; You should have received a copy of the GNU Lesser General Public
;;;; License along with this library; if not, write to the Free Software
;;;; Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA

(define-module (ice-9 gds-server)
  #:export (run-server))

;; UI is normally via a pipe to Emacs, so make sure to flush output
;; every time we write.
(define (write-to-ui form)
  (write form)
  (newline)
  (force-output))

(define (trc . args)
  (write-to-ui (cons '* args)))

(define (with-error->eof proc port)
  (catch #t
	 (lambda () (proc port))
	 (lambda args the-eof-object)))

(define connection->id (make-object-property))

(define (run-server unix-socket-name tcp-port)

  (let ((unix-server (socket PF_UNIX SOCK_STREAM 0))
	(tcp-server (socket PF_INET SOCK_STREAM 0)))

    ;; Bind and start listening on the Unix domain socket.
    (false-if-exception (delete-file unix-socket-name))
    (bind unix-server AF_UNIX unix-socket-name)
    (listen unix-server 5)

    ;; Bind and start listening on the TCP socket.
    (setsockopt tcp-server SOL_SOCKET SO_REUSEADDR 1)
    (false-if-exception (bind tcp-server AF_INET INADDR_ANY tcp-port))
    (listen tcp-server 5)

    ;; Main loop.
    (let loop ((clients '()) (readable-sockets '()))

      (define (do-read port)
	(cond ((eq? port (current-input-port))
	       (do-read-from-ui))
	      ((eq? port unix-server)
	       (accept-new-client unix-server))
	      ((eq? port tcp-server)
	       (accept-new-client tcp-server))
	      (else
	       (do-read-from-client port))))

      (define (do-read-from-ui)
	(trc "reading from ui")
	(let* ((form (with-error->eof read (current-input-port)))
	       (client (assq-ref (map (lambda (port)
					(cons (connection->id port) port))
				      clients)
				 (car form))))
	  (with-error->eof read-char (current-input-port))
	  (if client
	      (begin
		(write (cdr form) client)
		(newline client))
	      (trc "client not found")))	
	clients)

      (define (accept-new-client server)
        (let ((new-port (car (accept server))))
	  ;; Read the client's ID.
	  (let ((name-form (read new-port)))
	    ;; Absorb the following newline character.
	    (read-char new-port)
	    ;; Check that we have a name form.
	    (or (eq? (car name-form) 'name)
		(error "Invalid name form:" name-form))
	    ;; Store an association from the connection to the ID.
	    (set! (connection->id new-port) (cadr name-form))
	    ;; Pass the name form on to Emacs.
	    (write-to-ui (cons (connection->id new-port) name-form)))
	  ;; Add the new connection to the set that we select on.
          (cons new-port clients)))

      (define (do-read-from-client port)
	(trc "reading from client")
	(let ((next-char (with-error->eof peek-char port)))
	  ;;(trc 'next-char next-char)
	  (cond ((eof-object? next-char)
		 (write-to-ui (list (connection->id port) 'closed))
		 (close port)
		 (delq port clients))
		((char=? next-char #\()
		 (write-to-ui (cons (connection->id port)
				    (with-error->eof read port)))
		 clients)
		(else
		 (with-error->eof read-char port)
		 clients))))

      ;;(trc 'clients clients)
      ;;(trc 'readable-sockets readable-sockets)

      (if (null? readable-sockets)
	  (loop clients (car (select (cons* (current-input-port)
					    unix-server
					    tcp-server
					    clients)
				     '()
				     '())))
	  (loop (do-read (car readable-sockets)) (cdr readable-sockets))))))

;; What happens if there are multiple copies of Emacs running on the
;; same machine, and they all try to start up the GDS server?  They
;; can't all listen on the same TCP port, so the short answer is that
;; all of them except the first will get an EADDRINUSE error when
;; trying to bind.
;;
;; We want to be able to handle this scenario, though, so that Scheme
;; code can be evaluated, and help invoked, in any of those Emacsen.
;; So we introduce the idea of a "slave server".  When a new GDS
;; server gets an EADDRINUSE bind error, the implication is that there
;; is already a GDS server running, so the new server instead connects
;; to the existing one (by issuing a connect to the GDS port number).
;;
;; Let's call the first server the "master", and the new one the
;; "slave".  In principle the master can now proxy any GDS client
;; connections through to the slave, so long as there is sufficient
;; information in the protocol for it to decide when and how to do
;; this.
;;
;; The basic information and mechanism that we need for this is as
;; follows.
;;
;; - A unique ID for each Emacs; this can be each Emacs's PID.  When a
;; slave server connects to the master, it announces itself by sending
;; the protocol (emacs ID).
;;
;; - A way for a client to indicate which Emacs it wants to use.  At
;; the protocol level, this is an extra argument in the (name ...)
;; protocol.  (The absence of this argument means "no preference".  A
;; simplistic master server might then decide to use its own Emacs; a
;; cleverer one might monitor which Emacs appears to be most in use,
;; and use that one.)  At the API level this can be an optional
;; argument to the `gds-connect' procedure, and the Emacs GDS code
;; would obviously set this argument when starting a client from
;; within Emacs.
;;
;; We also want a strategy for continuing seamlessly if the master
;; server shuts down.
;;
;; - Each slave server will detect this as an error on the connection
;; to the master socket.  Each server then tries to bind to the GDS
;; port again (a race which the OS will resolve), and if that fails,
;; connect again.  The result of this is that there should be a new
;; master, and the others all slaves connected to the new master.
;;
;; - Each client will also detect this as an error on the connection
;; to the (master) server.  Either the client should try to connect
;; again (perhaps after a short delay), or the reconnection can be
;; delayed until the next time that the client requires the server.
;; (Probably the latter, all done within `gds-read'.)
;;
;; (Historical note: Before this master-slave idea, clients were
;; identified within gds-server.scm and gds*.el by an ID which was
;; actually the file descriptor of their connection to the server.
;; That is no good in the new scheme, because each client's ID must
;; persist when the master server changes, so we now use the client's
;; PID instead.  We didn't use PID before because the client/server
;; code was written to be completely asynchronous, which made it
;; tricky for the server to discover each client's PID and associate
;; it with a particular connection.  Now we solve that problem by
;; handling the initial protocol exchange synchronously.)
(define (run-slave-server port)
  'not-implemented)