OSCL/CLASH
2
0
Fork 0
Code Issues Pull Requests Packages Projects Releases Wiki Activity

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

Browse Source
This commit is contained in:
Pierre R. Mai
2012-11-18 02:12:43 +01:00
parent a5585fac6c
commit 57f5619329
3 changed files with 187 additions and 1 deletions
Download Patch File Download Diff File Expand all files Collapse all files

6
clash.asd
View File

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

154
src/drivers/simple-sbcl.lisp Normal file
View File

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

28
src/sbcl-locking.lisp Normal file
View File

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