r5284: *** empty log message ***

[kmrcl.git] / listener.lisp

diff --git a/listener.lisp b/listener.lisp
index dfd70f490985ffed9c1cb3d33a60a4d31fba0a86..19c7b0c308542bbaf2b8b527abeae7cf19f8b240 100644 (file)
--- a/listener.lisp
+++ b/listener.lisp
@@ -7,7 +7,7 @@
 ;;;; Programmer:    Kevin M. Rosenberg
 ;;;; Date Started:  Jun 2003
 ;;;;
-;;;; $Id: listener.lisp,v 1.4 2003/07/11 02:37:33 kevin Exp $
+;;;; $Id: listener.lisp,v 1.5 2003/07/11 06:58:32 kevin Exp $
 ;;;; *************************************************************************
 
 (in-package #:kmrcl)
@@ -40,6 +40,8 @@
    (number-fixed-workers :initform nil :accessor number-fixed-workers
                         :initarg :number-fixed-workers)
    (catch-errors :initform nil :accessor catch-errors :initarg :catch-errors)
+   (remote-host-checker :initform nil :accessor remote-host-checker
+                       :initarg :remote-host-checker)
    (format :initform :text :accessor listener-format :initarg :format)))
 
 (defclass fixed-worker ()
@@ -176,25 +178,36 @@
                  (setf (workers listener)
                        (remove self (workers listener)))))))))
 
+(defun accept-and-check-tcp-connection (listener)
+  (multiple-value-bind (conn socket) (accept-tcp-connection (socket listener))
+    (when (and (remote-host-checker listener)
+              (not (funcall (remote-host-checker listener)
+                            (remote-host socket))))
+      (cmsg-c :thread "Deny connection from ~A" (remote-host conn))
+      (errorset (close-active-socket conn) nil)
+      (setq conn nil))
+    conn))
+
 (defun start-socket-server (listener)
   (unwind-protect
       (loop 
-       (let ((connection (accept-tcp-connection (socket listener))))
-        (if (wait listener)
-            (unwind-protect
-                 (apply (listener-function listener)
-                        connection
-                        (function-args listener))
-              (progn
-                (errorset (finish-output connection) nil)
-                (errorset (close-active-socket connection) nil)))
-            (let ((worker (make-instance 'worker :listener listener
-                                         :connection connection
-                                         :name (next-worker-name
-                                                (base-name listener)))))
-              (setf (process worker)
-                    (make-process (name worker) (thread-fun worker)))
-              (push worker (workers listener))))))
+       (let ((connection (accept-and-check-tcp-connection listener)))
+        (when connection
+          (if (wait listener)
+              (unwind-protect
+                   (apply (listener-function listener)
+                          connection
+                          (function-args listener))
+                (progn
+                  (errorset (finish-output connection) nil)
+                  (errorset (close-active-socket connection) nil)))
+              (let ((worker (make-instance 'worker :listener listener
+                                           :connection connection
+                                           :name (next-worker-name
+                                                  (base-name listener)))))
+                (setf (process worker)
+                      (make-process (name worker) (thread-fun worker)))
+                (push worker (workers listener)))))))
     (errorset (close-passive-socket (socket listener)) nil)))
 
 #+lispworks
@@ -234,26 +247,28 @@
 
 (defun fixed-worker (name listener)
   (loop 
-   (let ((connection (accept-tcp-connection (socket listener))))
-     (flet ((do-work ()
-             (apply (listener-function listener)
-                    connection
-                    (function-args listener))))
-       (unwind-protect
-           (handler-case
-               (if (catch-errors listener)
-                   (handler-case
-                       (if (timeout listener)
-                           (with-timeout ((timeout listener))
+   (let ((connection (accept-and-check-tcp-connection listener)))
+     (when connection
+       (flet ((do-work ()
+               (apply (listener-function listener)
+                      connection
+                      (function-args listener))))
+        (unwind-protect
+             (handler-case
+                 (if (catch-errors listener)
+                     (handler-case
+                         (if (timeout listener)
+                             (with-timeout ((timeout listener))
+                               (do-work))
                              (do-work))
+                       (error (e)
+                         (cmsg "Error ~A [~A]" e name)))
+                     (if (timeout listener)
+                         (with-timeout ((timeout listener))
                            (do-work))
-                     (error (e)
-                       (cmsg "Error ~A [~A]" e name)))
-                   (if (timeout listener)
-                       (with-timeout ((timeout listener))
-                         (do-work))
-                       (do-work)))
-             (error (e)
-               (format t "Error: ~A" e)))
-        (errorset (finish-output connection) nil)
-        (errorset (close connection) nil))))))
+                         (do-work)))
+               (error (e)
+                 (format t "Error: ~A" e)))
+          (errorset (finish-output connection) nil)
+          (errorset (close connection) nil)))))))
+