diff --git a/src/drivers/simple-cmu.cl b/src/drivers/simple-cmu.cl index c88c8c1..c5d23d9 100644 --- a/src/drivers/simple-cmu.cl +++ b/src/drivers/simple-cmu.cl @@ -10,8 +10,11 @@ ;;;; %File Description: ;;;; +;;;; Simple MP and EVENT-driven drivers for CMU CL ;;;; -;;;; + + +;;; Connection handling (defun ip-address-string (address) (format nil "~D.~D.~D.~D" @@ -20,6 +23,68 @@ (ldb (byte 8 8) address) (ldb (byte 8 0) address))) +(defclass cmucl-connection (connection) + ((binary-address :initarg :binary-address) + (stream :initarg :stream :reader connection-stream))) + +(defmethod initialize-instance :after + ((instance cmucl-connection) &rest initargs &key socket) + (declare (ignore initargs)) + (setf (slot-value instance 'stream) + (sys:make-fd-stream socket :input t :output t + #-MP :buffering #-MP :none))) + +(defmethod connection-address ((connection cmucl-connection)) + (ip-address-string (slot-value connection 'binary-address))) + +(defmethod connection-hostname ((connection cmucl-connection)) + (let* ((address (slot-value connection 'binary-address)) + (host-entry (ext:lookup-host-entry address))) + (if host-entry + (ext:host-entry-name host-entry) + (ip-address-string address)))) + +(defmethod close-connection ((connection cmucl-connection)) + (ignore-errors + (let ((stream (connection-stream connection))) + (finish-output stream) + (close stream)))) + +;;; Event-driven handler + +#-MP +(defvar *fd-handlers* (make-hash-table)) + +#-MP +(defvar *fd-addresses* (make-hash-table)) + +#-MP +(defun start-http-listener (port server) + (labels ((read-handler (socket) + (let ((address (gethash socket *fd-addresses*))) + (system:remove-fd-handler (gethash socket *fd-handlers*)) + (remhash socket *fd-handlers*) + (remhash socket *fd-addresses*) + (serve-connection server + (make-instance 'cmucl-connection + :socket socket + :binary-address address)))) + (accept-handler (listener) + (multiple-value-bind (socket remote-host) + (ext:accept-tcp-connection listener) + (setf (gethash socket *fd-addresses*) remote-host + (gethash socket *fd-handlers*) + (system:add-fd-handler socket :input #'read-handler))))) + (let ((fd (ext:create-inet-listener port))) + (setf (gethash fd *fd-handlers*) + (system:add-fd-handler fd :input #'accept-handler))))) + +#-MP +(defun initialize-clash (&optional idle-process) + (declare (ignore idle-process)) + t) + +#+MP (defun http-listener (port server) (let ((fd (ext:create-inet-listener port))) (unless fd (error "Cannot bind port ~D." port)) @@ -42,10 +107,10 @@ #+CLASH-DEBUG (format t "~&;;; At ~D Have Connection...~%" (get-internal-real-time)) - (let* ((host-entry (ext:lookup-host-entry remote-host)) - (stream (sys:make-fd-stream new-fd :input t :output t)) - (connection (make-instance 'simple-connection - :stream stream))) + (let ((connection + (make-instance 'cmucl-connection + :socket new-fd + :binary-address remote-host))) #+CLASH-DEBUG (format t "~&;;; At ~D Established Connection...~%" (get-internal-real-time)) @@ -53,13 +118,13 @@ #'(lambda () (serve-connection server connection)) :name (format nil "HTTP connection from ~A" - (if host-entry - (ext:host-entry-name host-entry) - (ip-address-string remote-host)))))))) + (connection-hostname connection))))))) (when fd (unix:unix-close fd))))) +#+MP (defun start-http-listener (port server) (make-process #'(lambda () (http-listener port server)))) +#+MP (defun initialize-clash (&optional (idle-process mp::*initial-process*)) (setf mp::*idle-process* idle-process))