;;;; 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)
(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 ()
(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)
(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
(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)))))))
+
projects / kmrcl.git / blobdiff