;;;; 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)
(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 ()
(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
(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)))))))
+