guile18/ice-9/gds-server.scm

   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)