diff --git a/clash.asd b/clash.asd index ab30865..cd78c11 100644 --- a/clash.asd +++ b/clash.asd @@ -26,6 +26,8 @@ :pathname "" :components ((:file "package") (:file "utility" :depends-on ("package")) + #+sbcl + (:file "sbcl-locking" :depends-on ("package")) #+cmu (:file "cmu-locking" :depends-on ("package")) #+lispworks4.1 @@ -82,7 +84,9 @@ "server"))) :depends-on ("base")) (:module "drivers" - :components (#+cmu + :components (#+sbcl + (:file "simple-sbcl") + #+cmu (:file "simple-cmu") #+lispworks4.1 (:file "simple-lwl") diff --git a/src/drivers/simple-sbcl.lisp b/src/drivers/simple-sbcl.lisp new file mode 100644 index 0000000..74d9a71 --- /dev/null +++ b/src/drivers/simple-sbcl.lisp @@ -0,0 +1,154 @@ +;;;; CLASH --- The Common Lisp Adaptable Simple HTTP server +;;;; This is copyrighted software. See documentation for terms. +;;;; +;;;; simple-sbcl.cl --- Simple HTTP-Server driver for SBCL +;;;; +;;;; Checkout Tag: $Name$ +;;;; $Id$ + +(in-package :CLASH) + +;;;; %File Description: +;;;; +;;;; Simple SB-THREAD and SERVE-EVENT-driven drivers for SBCL +;;;; + + +;;; Connection handling + +(defun ip-address-string (address) + (format nil "~D.~D.~D.~D" + (aref address 0) + (aref address 1) + (aref address 2) + (aref address 3))) + +(defclass sbcl-connection (connection) + ((binary-address :initarg :binary-address) + (stream :initarg :stream :reader connection-stream))) + +(defmethod initialize-instance :after + ((instance sbcl-connection) &rest initargs &key socket) + (declare (ignore initargs)) + (setf (slot-value instance 'stream) + (sb-bsd-sockets:socket-make-stream + socket + :input t :output t + #-SB-THREAD :buffering #-SB-THREAD :none + #-SB-THREAD :serve-events #-SB-THREAD t + :allow-other-keys t))) + +(defmethod connection-address ((connection sbcl-connection)) + (ip-address-string (slot-value connection 'binary-address))) + +(defmethod connection-hostname ((connection sbcl-connection)) + (let* ((address (slot-value connection 'binary-address)) + (host-entry (sb-bsd-sockets:get-host-by-address address))) + (if host-entry + (sb-bsd-sockets:host-ent-name host-entry) + (ip-address-string address)))) + +(defmethod close-connection ((connection sbcl-connection)) + (ignore-errors + (let ((stream (connection-stream connection))) + (finish-output stream) + (close stream)))) + +;;; Event-driven handler + +#-SB-THREAD +(defvar *fd-handlers* (make-hash-table)) + +#-SB-THREAD +(defvar *fd-addresses* (make-hash-table)) + +#-SB-THREAD +(defvar *fd-sockets* (make-hash-table)) + +#-SB-THREAD +(defun start-http-listener (port server &key reuse-address) + (labels ((read-handler (socket-fd) + (let ((address (gethash socket-fd *fd-addresses*)) + (socket (gethash socket-fd *fd-sockets*))) + (sb-sys:remove-fd-handler (gethash socket-fd *fd-handlers*)) + (remhash socket-fd *fd-handlers*) + (remhash socket-fd *fd-addresses*) + (remhash socket-fd *fd-sockets*) + (serve-connection server + (make-instance 'sbcl-connection + :socket socket + :binary-address address)))) + (accept-handler (listener-fd) + (multiple-value-bind (socket remote-host) + (sb-bsd-sockets:socket-accept (gethash listener-fd *fd-sockets*)) + (let ((socket-fd (sb-bsd-sockets:socket-file-descriptor socket))) + (setf (gethash socket-fd *fd-addresses*) remote-host + (gethash socket-fd *fd-sockets*) socket + (gethash socket-fd *fd-handlers*) + (sb-sys:add-fd-handler socket-fd :input #'read-handler)))))) + (let ((socket (make-instance 'sb-bsd-sockets:inet-socket + :type :stream :protocol :tcp))) + (setf (sb-bsd-sockets:sockopt-reuse-address socket) reuse-address) + (sb-bsd-sockets:socket-bind socket #(0 0 0 0) port) + (sb-bsd-sockets:socket-listen socket 10) + (let ((socket-fd (sb-bsd-sockets:socket-file-descriptor socket))) + (setf (gethash socket-fd *fd-sockets*) socket + (gethash socket-fd *fd-handlers*) + (sb-sys:add-fd-handler socket-fd :input #'accept-handler)))))) + +#-SB-THREAD +(defun initialize-clash (&optional idle-process) + (declare (ignore idle-process)) + t) + +;;; +;;; Todo: SB-THREAD support +;;; + +#| +#+SB-THREAD +(defun http-listener (port server reuse-address) + (let ((fd (ext:create-inet-listener port :stream + :reuse-address reuse-address))) + (unwind-protect + (progn + (setf (process-name *current-process*) + (format nil + "HTTP connection listener on port ~D with server ~A" + port server)) + #+CLASH-DEBUG + (format t "~&;;; Started lisp connection listener on ~ + port ~d for server ~A~%" port server) + (loop + ;; Wait for new connection + (process-wait-until-fd-usable fd :input) + #+CLASH-DEBUG + (format t "~&;;; At ~D Got Connection...~%" + (get-internal-real-time)) + (multiple-value-bind (new-fd remote-host) + (ext:accept-tcp-connection fd) + #+CLASH-DEBUG + (format t "~&;;; At ~D Have Connection...~%" + (get-internal-real-time)) + (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)) + (make-process + #'(lambda () + (serve-connection server connection)) + :name (format nil "HTTP connection from ~A" + (connection-hostname connection))))))) + (when fd (unix:unix-close fd))))) + +#+SB-THREAD +(defun start-http-listener (port server &key reuse-address) + (make-process #'(lambda () (http-listener port server reuse-address)))) + +#+SB-THREAD +(defun initialize-clash (&optional (idle-process mp::*initial-process*)) + (setf mp::*idle-process* idle-process)) +|# diff --git a/src/sbcl-locking.lisp b/src/sbcl-locking.lisp new file mode 100644 index 0000000..9e81f2d --- /dev/null +++ b/src/sbcl-locking.lisp @@ -0,0 +1,28 @@ +;;;; CLASH --- The Common Lisp Adaptable Simple HTTP server +;;;; This is copyrighted software. See documentation for terms. +;;;; +;;;; sbcl-locking.cl --- Platform independent locking primitives +;;;; +;;;; Checkout Tag: $Name$ +;;;; $Id$ + +(in-package :CLASH) + +;;;; %File Description: +;;;; +;;;; +;;;; + +;;; Locking primitives for SBCL + +(defmacro pop-atomically (place) + #+SB-THREAD + `(sb-ext:atomic-pop ,place) + #-SB-THREAD + `(pop ,place)) + +(defmacro push-atomically (value place) + #+SB-THREAD + `(sb-ext:atomic-push ,value ,place) + #-SB-THREAD + `(push ,value ,place))