Add initial support for SBCL, currently restricted to SERVE-EVENT.

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")

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))
+|#

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))