modlisp-clisp.lisp

;;; -*- Mode:Lisp; Syntax:Common-lisp; Package:MODLISP; Base:10 -*-

;; modlisp-clisp.lisp
;; adapted from modlisp-acl.lisp

;; Original CLISP adaption by Rachel Richard <rr@u.washington.edu>
;; Changes by Nils Kassube <nika@kassube.de> on 2001-11-24:
;;
;; - replaced :lisp by :ext for CLISP's new naming convention,
;;   works now with recent CLISP distributions
;; - added modlisp-server to the :export line

(in-package :user)

(provide :modlisp)

(eval-when (compile load eval)
  (defpackage :modlisp
    (:nicknames :lph)
    (:use :cl)
    (:export modlisp-server)
    ))

(in-package :modlisp)

;;;;;
;;;
;;; First part adapted from server.cl
;;;
;;;;;

(defvar *server-count* 0)	; used to name servers

(defun make-socket-server (&key (name (format nil "socket server ~d "
					      (incf *server-count*)))
				port
				function
				wait
				(format :text))
  ;;
  ;; create a server process with the given name, listening on the
  ;; given port, running the given function on each connection that
  ;; comes in, and possibly waiting for that function's completion before
  ;; accepting a new connection.
  ;;
  ;; name - a string naming the server process -- if nil, then this
  ;;	function will create a name.
  ;; port - if nil then an internet domain port number will be chosen
  ;;	    by the operating system.   If a number is given then that
  ;;	    port will be used (or an error will be signalled if it
  ;;	    is already in use).    If port is a string then a unix
  ;;	    domain port will be used.  (this will not work on Windows).
  ;; function - the function to run when a connection is made.  This
  ;;	    function must take one argument which is the stream used
  ;;	    used for reading from and writing to the process that connected
  ;;	    to this socket.
  ;; wait - if true, then the function will be run in the server process
  ;;	    and thus the server won't accept a new connection until
  ;;	    the function finishes.
  ;; format  - :text (the default) or :binary.   This determes what kind
  ;;	    of data can sent to and read from the socket stream.
  ;;
  ;;
  ;;
  ;; The return value is the port number on which the server is
  ;;	listening.
  ;;
  (let ((passive-socket (ext:socket-server port) ;

))

	(start-socket-server passive-socket
			     :function function
			     :wait wait)
(ext:socket-server-port passive-socket)))

(defun start-socket-server (passive-socket &key function wait)
  ;; internal function run in the server lightweight process
  ;; that continually processes the connection.
  ;; This code is careful to ensure that the sockets are
  ;; properly closed something abnormal happens.
  (unwind-protect
      (loop (let ((connection  (ext:socket-accept passive-socket)))
	      (if wait
		 (progn
		   (unwind-protect
			  (funcall function connection)
			  (handler-case (values-list (cons t
							   (multiple-value-list
							    (close connection))))
					(error (condition) (declare (ignore-if-unused condition))
					       nil))))


			   (unwind-protect
			       (funcall function connection)
			    	  (handler-case (values-list (cons t
							   (multiple-value-list
							    (close connection))))
					(error (condition) (declare (ignore-if-unused condition))
					       nil)))

		 )))

    	  (handler-case (values-list (cons t
							   (multiple-value-list
							    (close passive-socket))))
					(error (condition) (declare (ignore-if-unused condition))
					       nil))))


;;;;;
;;;
;;; Second part adapted from mod-lisp.lisp
;;;
;;;;;

(defconstant +apache-port+ 3000)
(defvar *apache-socket* nil) ;the socket to apache
(defvar *close-apache-socket* nil) ;set to t if you want to close the socket to apache
(defvar *apache-nb-use-socket* 0) ;the number of requests sent in this socket

(defun modlisp-server (&optional (port +apache-port+))

  (make-socket-server :name "test"
		      :port port
		      :function 'apache-listen))

(defun apache-listen (*apache-socket*)
   (let ((*close-apache-socket* t))
    (unwind-protect
	(loop for *apache-nb-use-socket* from 0
	    for command = (get-apache-command)
	    while command
	    do (process-apache-command command)
	  (force-output *apache-socket*)
	    until *close-apache-socket*)
      (close *apache-socket*))))

(defun get-apache-command ()
  (ignore-errors
   (let* ((header (loop for key = (read-line *apache-socket* nil nil)
		    while (and key (string-not-equal key "end"))
		    collect (cons key (read-line *apache-socket* nil nil)) )))
     (let* ((content-length (cdr (assoc "content-length" header :test #'equal)))
	  (content (when content-length (make-string (parse-integer content-length :junk-allowed t)))))

     (when content
       (read-sequence content *apache-socket*)
       (push (cons "posted-content" content) header))
     header))))

(defun process-apache-command (command)
  (let ((html (if (equal (cdr (assoc "url" command :test #'string=))
			 "/modlisp/fixed")
		  (debug-table command)
		(fixed-html))))
    (write-header-line "Status" "200 OK")
    (write-header-line "Content-Type" "text/html")
    (write-header-line "Content-Length" (format nil "~d" (length html)))
    (write-header-line "Keep-Socket" "1")
    (write-string "end" *apache-socket*)
    (write-char #\NewLine *apache-socket*)
    (write-string html *apache-socket*)
    (setf *close-apache-socket* nil)))

(defun debug-table (command)
  (with-output-to-string (s)
   (write-string "<!DOCTYPE HTML PUBLIC \"-//IETF//DTD HTML//EN\">
<HTML><HEAD></HEAD><BODY><TABLE bgcolor=\"#c0c0c0\">
<TR bgcolor=\"yellow\"><TH COLSPAN=2>CLISP + mod_lisp 2.0 + apache + Linux</TH></TR>
<TR bgcolor=\"yellow\"><TH>Key</TH><TH>Value</TH></TR>" s)
   (format s "<TR bgcolor=\"#F0F0c0\"><TD>apache-nb-use-socket</TD><TD>~a</TD></TR>"  *apache-nb-use-socket*)
   (loop for (key . value) in command do
	 (format s "<TR bgcolor=\"#F0F0c0\"><TD>~a</TD><TD>~a</TD></TR>" key value))
   (write-string "</TABLE></BODY></HTML>" s)))


(defun fixed-html ()
  "<!DOCTYPE HTML PUBLIC \"-//IETF//DTD HTML//EN\">
<HTML><HEAD></HEAD><BODY><H1>mod_lisp 2.0</H1><P>This is a constant
  html string sent by mod_lisp 2.0 + CLISP + apache + Linux</P>
</BODY></HTML>")

(defun write-header-line (key value)
  (write-string key *apache-socket*)
  (write-char #\NewLine *apache-socket*)
  (write-string value *apache-socket*)
  (write-char #\NewLine *apache-socket*))