X-Git-Url: http://git.kpe.io/?p=kmrcl.git;a=blobdiff_plain;f=listener.lisp;h=19c7b0c308542bbaf2b8b527abeae7cf19f8b240;hp=dfd70f490985ffed9c1cb3d33a60a4d31fba0a86;hb=6e84de6e7bff9079d0b6ba62a3c85d2eb98f2eb4;hpb=0dc565c13310ce9f59b42b4e4bdd9167e24ca756

diff --git a/listener.lisp b/listener.lisp
index dfd70f4..19c7b0c 100644
--- 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)))))))
+