- ((self worker) &key listener connection name &allow-other-keys)
- (unless connection
- (error "connection not provided to modlisp-worker"))
- (setf (slot-value self 'listener) listener)
- (setf (slot-value self 'name) name)
- (setf (slot-value self 'connection) connection)
- (setf (slot-value self 'thread-fun)
- #'(lambda ()
- (unwind-protect
- (if (catch-errors listener)
- (handler-case
- (apply (listener-function listener)
- connection
- (function-args listener))
- (error (e)
- (cmsg "Error ~A [~A]" e name)))
- (apply (listener-function listener)
- connection
- (function-args listener)))
- (progn
- (errorset (close-active-socket connection) nil)
- (cmsg-c :threads "~A ended" name)
- (setf (workers listener)
- (remove self (workers listener))))))))
+ ((self worker) &key listener connection socket name &allow-other-keys)
+ (flet ((do-work ()
+ (apply (listener-function listener)
+ connection
+ (function-args listener))))
+ (unless connection
+ (error "connection not provided to modlisp-worker"))
+ (unless socket
+ (error "socket not provided to modlisp-worker"))
+ (setf (slot-value self 'listener) listener)
+ (setf (slot-value self 'name) name)
+ (setf (slot-value self 'connection) connection)
+ (setf (slot-value self 'socket) socket)
+ (setf (slot-value self 'thread-fun)
+ #'(lambda ()
+ (unwind-protect
+ (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))
+ (do-work)))
+ (progn
+ (errorset (finish-output connection) nil)
+ (errorset (close-active-socket socket) t)
+ (cmsg-c :threads "~A ended" name)
+ (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 socket) nil)
+ (setq conn nil socket nil))
+ (values conn socket)))