Merge branch 'ossau-gds-dev'

[bpt/guile.git] / module / ice-9 / gds-server.scm

diff --git a/module/ice-9/gds-server.scm b/module/ice-9/gds-server.scm
index f597587..5ec8675 100644 (file)
--- a/module/ice-9/gds-server.scm
+++ b/module/ice-9/gds-server.scm
@@ -2,19 +2,19 @@
 
 ;;; 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 2.1 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., 59 Temple Place, Suite 330, Boston, MA 02111-1307 USA
+;;;; 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))
@@ -36,38 +36,31 @@
 
 (define connection->id (make-object-property))
 
-(define (run-server port-or-path)
+(define (run-server unix-socket-name tcp-port)
 
-  (or (integer? port-or-path)
-      (string? port-or-path)
-      (error "port-or-path should be an integer (port number) or a string (file name)"
-            port-or-path))
+  (let ((unix-server (socket PF_UNIX SOCK_STREAM 0))
+       (tcp-server (socket PF_INET SOCK_STREAM 0)))
 
-  (let ((server (socket (if (integer? port-or-path) PF_INET PF_UNIX)
-                       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)
 
-    ;; Initialize server socket.
-    (if (integer? port-or-path)
-       (begin
-         (setsockopt server SOL_SOCKET SO_REUSEADDR 1)
-         (bind server AF_INET INADDR_ANY port-or-path))
-       (begin
-         (catch #t
-                (lambda () (delete-file port-or-path))
-                (lambda _ #f))
-         (bind server AF_UNIX port-or-path)))
-
-    ;; Start listening.
-    (listen 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 server)
-              (accept-new-client))
+             ((eq? port unix-server)
+              (accept-new-client unix-server))
+             ((eq? port tcp-server)
+              (accept-new-client tcp-server))
              (else
               (do-read-from-client port))))
 
@@ -86,7 +79,7 @@
              (trc "client not found")))        
        clients)
 
-      (define (accept-new-client)
+      (define (accept-new-client server)
         (let ((new-port (car (accept server))))
          ;; Read the client's ID.
          (let ((name-form (read new-port)))
@@ -122,8 +115,10 @@
       ;;(trc 'readable-sockets readable-sockets)
 
       (if (null? readable-sockets)
-         (loop clients (car (select (cons (current-input-port)
-                                          (cons server clients))
+         (loop clients (car (select (cons* (current-input-port)
+                                           unix-server
+                                           tcp-server
+                                           clients)
                                     '()
                                     '())))
          (loop (do-read (car readable-sockets)) (cdr readable-sockets))))))