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

diff --git a/listener.lisp b/listener.lisp
index dfd70f4..0b31cef 100644
--- a/listener.lisp
+++ b/listener.lisp
@@ -7,7 +7,13 @@
 ;;;; Programmer:    Kevin M. Rosenberg
 ;;;; Date Started:  Jun 2003
 ;;;;
-;;;; $Id: listener.lisp,v 1.4 2003/07/11 02:37:33 kevin Exp $
+;;;; $Id$
+;;;;
+;;;; This file, part of KMRCL, is Copyright (c) 2002-2003 by Kevin M. Rosenberg
+;;;;
+;;;; KMRCL users are granted the rights to distribute and use this software
+;;;; as governed by the terms of the Lisp Lesser GNU Public License
+;;;; (http://opensource.franz.com/preamble.html), also known as the LLGPL.
 ;;;; *************************************************************************
 
 (in-package #:kmrcl)
@@ -40,6 +46,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 ()
@@ -67,41 +75,16 @@
   (case state
     (:start
      (when (member listener *active-listeners*)
-       (warn "~&listener already started")
-       (return-from init/listener listener))
-     (handler-case
-	 (progn
-	   (setf (name listener) (next-server-name (base-name listener)))
-	   (make-socket-server listener))
-       (error (e)
-	 (format t "~&Error while trying to start listener~&  ~A" e)
-	 (decf *listener-count*)
-	 nil)
-       (:no-error (res)
-	 (declare (ignore res))
-	 (push listener *active-listeners*)
-	 listener)))
+       (cmsg "~&listener ~A already initialized" listener)
+       (return-from init/listener))
+     (when (listener-startup listener)
+       (push listener *active-listeners*)
+       listener))
     (:stop
      (unless (member listener *active-listeners*)
-       (warn "~&listener is not in active list")
+       (cmsg "~&listener ~A is not in active list" listener)
        (return-from init/listener listener))
-     (dolist (worker (workers listener))
-       (when (and (typep worker 'worker)
-		  (connection worker))
-	 (errorset (close-active-socket
-		    (connection worker)) nil)
-	 (setf (connection worker) nil))
-       (when (process worker)
-	 (errorset (destroy-process (process worker)) nil)
-	 (setf (process worker) nil)))
-     (setf (workers listener) nil)
-     (with-slots (process socket) listener
-       (when socket
-	 (errorset (close-passive-socket socket) nil)
-	 (setf socket nil))
-       (when process
-	 (errorset (destroy-process process) nil)
-	 (setf process nil)))
+     (listener-shutdown listener)
      (setq *active-listeners* (remove listener *active-listeners*)))
     (:restart
      (init/listener listener :stop)
@@ -112,13 +95,46 @@
     (ignore-errors
        (init/listener listener :stop))))
 
+(defun listener-startup (listener)
+  (handler-case
+      (progn
+	(setf (name listener) (next-server-name (base-name listener)))
+	(make-socket-server listener))
+    (error (e)
+      (format t "~&Error while trying to start listener on port ~A~&  ~A" 
+	      (port listener) e)
+      (decf *listener-count*)
+      nil)
+    (:no-error (res)
+      (declare (ignore res))
+      listener)))
+
+(defun listener-shutdown (listener)
+  (dolist (worker (workers listener))
+    (when (and (typep worker 'worker)
+	       (connection worker))
+      (errorset (close-active-socket
+		 (connection worker)) nil)
+      (setf (connection worker) nil))
+    (when (process worker)
+      (errorset (destroy-process (process worker)) nil)
+      (setf (process worker) nil)))
+  (setf (workers listener) nil)
+  (with-slots (process socket) listener
+    (when socket
+      (errorset (close-passive-socket socket) nil)
+      (setf socket nil))
+    (when process
+      (errorset (destroy-process process) nil)
+      (setf process nil))))
+
 ;; Low-level functions
 
 (defun next-server-name (base-name)
-  (format nil "~A-socket-server-~D" base-name (incf *listener-count*))) 
+  (format nil "~D-~A-socket-server" (incf *listener-count*) base-name)) 
 
 (defun next-worker-name (base-name)
-  (format nil "~A-worker-~D" base-name (incf *worker-count*)))
+  (format nil "~D-~A-worker"  (incf *worker-count*) base-name))
 
 (defun make-socket-server (listener)
   #+lispworks
@@ -176,25 +192,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 +261,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)))))))
+