131 lines
3.9 KiB
Common Lisp
131 lines
3.9 KiB
Common Lisp
;;;; CLASH --- The Common Lisp Adaptable Simple HTTP server
|
|
;;;; This is copyrighted software. See documentation for terms.
|
|
;;;;
|
|
;;;; simple-cmu.cl --- Simple HTTP-Server driver for CMU CL
|
|
;;;;
|
|
;;;; Checkout Tag: $Name$
|
|
;;;; $Id$
|
|
|
|
(in-package :CLASH)
|
|
|
|
;;;; %File Description:
|
|
;;;;
|
|
;;;; Simple MP and EVENT-driven drivers for CMU CL
|
|
;;;;
|
|
|
|
|
|
;;; Connection handling
|
|
|
|
(defun ip-address-string (address)
|
|
(format nil "~D.~D.~D.~D"
|
|
(ldb (byte 8 24) address)
|
|
(ldb (byte 8 16) address)
|
|
(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)))
|
|
(unwind-protect
|
|
(progn
|
|
(setf (process-name *current-process*)
|
|
(format nil
|
|
"HTTP connection listener on port ~D with server ~A"
|
|
port server))
|
|
(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)))))
|
|
|
|
#+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))
|
|
|