From 315ebc6354619483aa1be1124eb3736cee6f7ab7 Mon Sep 17 00:00:00 2001 From: "Kevin M. Rosenberg" Date: Sat, 5 Jul 2003 00:53:54 +0000 Subject: [PATCH] r5233: *** empty log message *** --- base.lisp | 131 +++++++++++++++++++------------------------- debian/control | 2 +- impl-cmucl.lisp | 32 ++++++----- impl-lispworks.lisp | 29 ++++++---- modlisp.asd | 10 +++- package.lisp | 11 ++-- utils.lisp | 16 ++++-- variables.lisp | 23 ++++---- 8 files changed, 126 insertions(+), 128 deletions(-) diff --git a/base.lisp b/base.lisp index 15ff3e1..6b63c4d 100644 --- a/base.lisp +++ b/base.lisp @@ -7,7 +7,7 @@ ;;;; Programmer: Kevin M. Rosenberg ;;;; Date Started: Dec 2002 ;;;; -;;;; $Id: base.lisp,v 1.2 2003/07/04 22:41:06 kevin Exp $ +;;;; $Id: base.lisp,v 1.3 2003/07/05 00:51:04 kevin Exp $ ;;;; ************************************************************************* (in-package #:modlisp) @@ -22,7 +22,7 @@ (make-socket-server (next-server-name) function port :format :text :wait nil) (error (e) - (format t "Error ~A" e) + (format t "~&Error while trying to start modlisp server~& ~A" e) (decf *listener-count*) nil) (:no-error (process socket) @@ -32,18 +32,24 @@ (defun modlisp-stop () (when *listener-process* - (format t "~&; killing process ~d~%" *listener-process*) - #+sbcl (sb-thread:destory-thread *listener-process*) - #+allegro (mp:process-kill *listener-process*) - #+allegro (mp:process-allow-schedule) - #+lispworks (mp:process-kill *listener-process*) - #+cmucl (mp:destroy process *listener-process*) - (setq *listener-process* nil)) - (when *listener-socket* + (format t "~&; killing modlisp server process ~A~%" *listener-process*) + (handler-case + (progn + #+sbcl (sb-thread:destroy-thread *listener-process*) + #+cmucl (mp:destroy-process *listener-process*) + #+allegro (mp:process-kill *listener-process*) + #+allegro (mp:process-allow-schedule) + #+lispworks (mp:process-kill *listener-process*)) + (error (e) + (format t "~&Error while trying to kill modlisp server~& ~A" e)) + (:no-error (res) + (declare (ignore res)) + (setq *listener-process* nil)))) + (when *listener-socket* (ignore-errors (close *listener-socket*)) (setq *listener-socket* nil))) - ) + ) ;; closure (defun next-server-name () (format nil "modlisp-socket-server-~d" (incf *listener-count*))) @@ -51,27 +57,39 @@ (defun next-worker-name () (format nil "modlisp-worker-~d" (incf *worker-count*))) - -(defun apache-command-issuer (*apache-socket* processor-fun) - "generates commands from apache, issues commands to processor-fun" - (let ((*close-apache-socket* t)) +(let ((*number-server-requests* 0) + (*number-worker-requests* 0) + (*close-apache-socket* t)) + + (defun apache-command-issuer (*apache-socket* processor-fun) + "generates commands from apache, issues commands to processor-fun" (unwind-protect - (loop for *apache-nb-use-socket* from 0 - for command = (get-apache-command) - while command - do (funcall processor-fun command) - (force-output *apache-socket*) - until *close-apache-socket*) - (close *apache-socket*)))) + (progn + (setq *number-worker-requests* 0) + (do ((command (read-apache-command) (read-apache-command))) + ((null command) 'done) + (funcall processor-fun command) + (force-output *apache-socket*) + (incf *number-worker-requests*) + (incf *number-server-requests*) + (when *close-apache-socket* + (return)))) + (close *apache-socket*))) + + (defun get-number-worker-requests () + *number-worker-requests*) + + (defun get-number-server-requests () + *number-server-requests*) + + (defun set-close-apache-socket (close?) + (setq *close-apache-socket* close?)) + + ) ;; closure -(defun get-apache-command () +(defun read-apache-command () (ignore-errors - (let* ((header (loop for key = (read-line *apache-socket* nil nil) - while (and key - (string-not-equal key "end") - (> (length key) 1)) - for value = (read-line *apache-socket* nil nil) - collect (cons key value))) + (let* ((header (read-apache-header)) (content-length (cdr (assoc "content-length" header :test #'equal))) (content (when content-length (make-string @@ -81,6 +99,14 @@ (push (cons "posted-content" content) header)) header))) +(defun read-apache-header () + (loop for key = (read-line *apache-socket* nil nil) + while (and key + (string-not-equal key "end") + (> (length key) 1)) + for value = (read-line *apache-socket* nil nil) + collect (cons key value))) + (defun write-header-line (key value) (write-string key *apache-socket*) (write-char #\NewLine *apache-socket*) @@ -90,50 +116,3 @@ (defun header-value (command key) (cdr (assoc key command :test #'string=))) - -;;; Default (demo) processor - -(defun demo-apache-command-processor (command) - "Sample function to process an apache command" - (if (equal (header-value command "url") "/asp/fixed") - (fixed-request) - (debug-request command))) - -(defun fixed-request () - (let ((html (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*) - (setq *close-apache-socket* nil)) ) - -(defun debug-request (command) - (let ((html (debug-table command))) - (write-header-line "Status" "200 OK") - (write-header-line "Content-Type" "text/html") - (write-header-line "Keep-Socket" "0") - (write-string "end" *apache-socket*) - (write-char #\NewLine *apache-socket*) - (write-string html *apache-socket*) - (setq *close-apache-socket* t)) ) - -(defun debug-table (command) - (with-output-to-string (s) - (write-string " - - - -mod_lisp debug -" s) - (format s "" *apache-nb-use-socket*) - (loop for (key . value) in command do - (format s "" key value)) - (write-string "
KeyValue
apache-nb-use-socket~a
~a~a
" s))) - -(defun fixed-html () - " -

mod_lisp

-

This is a constant html string sent by mod_lisp

") diff --git a/debian/control b/debian/control index b726ddc..32e5585 100644 --- a/debian/control +++ b/debian/control @@ -7,7 +7,7 @@ Standards-Version: 3.5.10.0 Package: cl-modlisp Architecture: all -Depends: ${shlibs:Depends}, common-lisp-controller (>= 3.37),libapache-mod-lisp,cl-kmrcl +Depends: ${shlibs:Depends}, common-lisp-controller (>= 3.37),libapache-mod-lisp,cl-kmrcl Description: Common Lisp interface to the Apache mod-lisp module cl-modlisp provides a Common Lisp interface to the mod-lisp Apache module. The package has support for CMUCL, SBCL, CLISP, AllegroCL, and Lispworks. diff --git a/impl-cmucl.lisp b/impl-cmucl.lisp index fc45602..c98a05e 100644 --- a/impl-cmucl.lisp +++ b/impl-cmucl.lisp @@ -4,19 +4,21 @@ (defun make-socket-server (name function port &key wait (format :text)) - (mp:make-process - (lambda () (make-apache-listener port function)) - :name name)) + (let ((listener (ext:create-inet-listener port))) + (values + (mp:make-process + (lambda () (start-socket-server listener function)) + :name name) + listener))) -(defun make-apache-listener (port function) - (let ((socket (ext:create-inet-listener port))) - (unwind-protect - (loop - (mp:process-wait-until-fd-usable socket :input) - (multiple-value-bind (new-fd remote-host) - (ext:accept-tcp-connection socket) - (let ((stream (sys:make-fd-stream new-fd :input t :output t))) - (mp:make-process - (lambda () (apache-command-issuer stream function)) - :name (next-worker-name))))) - (unix:unix-close socket)))) +(defun start-socket-server (listener function) + (unwind-protect + (loop + (mp:process-wait-until-fd-usable listener :input) + (multiple-value-bind (new-fd remote-host) + (ext:accept-tcp-connection listener) + (let ((stream (sys:make-fd-stream new-fd :input t :output t))) + (mp:make-process + (lambda () (apache-command-issuer stream function)) + :name (next-worker-name))))) + (unix:unix-close listener))) diff --git a/impl-lispworks.lisp b/impl-lispworks.lisp index 351b35f..86dfc57 100644 --- a/impl-lispworks.lisp +++ b/impl-lispworks.lisp @@ -4,13 +4,22 @@ (require "comm") -(defun make-socket-server (name port function &key wait (format :text)) - (comm:start-up-server - :function (lambda (handle) - (let ((stream (make-instance 'comm:socket-stream :socket handle - :direction :io - :element-type 'base-char))) - (mp:process-run-function - (next-worker-name) '() - 'apache-command-issuer stream function))) - :service port :process-name name)) +(defvar *processor*) +(let ((*processor* nil)) + + (defun make-socket-server (name function port &key wait (format :text)) + (setq *processor* function) + (values + (comm:start-up-server + :service port + :process-name name + :function 'socket-worker) + nil)) + + (defun socket-worker (socket) + (let ((stream (make-instance 'comm:socket-stream :socket socket + :direction :io + :element-type 'base-char))) + (mp:process-run-function + (next-worker-name) '() + 'apache-command-issuer stream *processor*)))) diff --git a/modlisp.asd b/modlisp.asd index 95a75b7..88d51fb 100644 --- a/modlisp.asd +++ b/modlisp.asd @@ -7,15 +7,18 @@ ;;;; Programmer: Kevin M. Rosenberg ;;;; Date Started: Dec 2002 ;;;; -;;;; $Id: modlisp.asd,v 1.2 2003/07/04 22:41:06 kevin Exp $ +;;;; $Id: modlisp.asd,v 1.3 2003/07/05 00:51:04 kevin Exp $ ;;;; ************************************************************************* (defpackage #:modlisp-system (:use #:cl #:asdf)) (in-package #:modlisp-system) +#+(and sbcl (not sb-thread)) +(error "This package requires the multitasking version of sbcl") + #+(or allegro clisp cmu lispworks sbcl) (defsystem modlisp - :depends-on (:kmrcl #+sbcl :sb-bsd-sockets) + :depends-on (#+sbcl :sb-bsd-sockets) :components ((:file "package") (:file "variables" :depends-on ("package")) @@ -31,4 +34,5 @@ #+cmu "impl-cmucl" #+lispworks "impl-lispworks" #+sbcl "impl-sbcl")) - (:file "utils" :depends-on ("base")))) + (:file "utils" :depends-on ("base")) + (:file "demo" :depends-on ("utils")))) diff --git a/package.lisp b/package.lisp index 931262d..b09c706 100644 --- a/package.lisp +++ b/package.lisp @@ -7,7 +7,7 @@ ;;;; Programmer: Kevin M. Rosenberg ;;;; Date Started: Dec 2002 ;;;; -;;;; $Id: package.lisp,v 1.1 2003/07/04 19:52:32 kevin Exp $ +;;;; $Id: package.lisp,v 1.2 2003/07/05 00:51:04 kevin Exp $ ;;;; ************************************************************************* (in-package #:cl-user) @@ -17,17 +17,18 @@ (:use #:cl #:kmrcl) (:export - ;; data-structures.lisp + ;; variables.lisp #:*apache-socket* - #:*close-apache-socket* - #:*apache-nb-use-socket* ;; base.lisp #:modlisp-start #:modlisp-stop #:header-value #:write-header-line - + #:get-number-worker-requests + #:get-number-server-requests + #:set-close-apache-socket + ;; utils.lisp #:output-html-page #:output-xml-page diff --git a/utils.lisp b/utils.lisp index 04376fd..064e362 100644 --- a/utils.lisp +++ b/utils.lisp @@ -7,7 +7,7 @@ ;;;; Programmer: Kevin M. Rosenberg ;;;; Date Started: Dec 2002 ;;;; -;;;; $Id: utils.lisp,v 1.1 2003/07/04 19:52:32 kevin Exp $ +;;;; $Id: utils.lisp,v 1.2 2003/07/05 00:51:04 kevin Exp $ ;;;; ************************************************************************* (in-package #:modlisp) @@ -46,17 +46,17 @@ (write-string "end" *apache-socket*) (write-char #\NewLine *apache-socket*) (write-string ,outstr *apache-socket*) - (setq *close-apache-socket* nil)) + (set-close-apache-socket nil)) (t (finish-output *apache-socket*) - (setq *close-apache-socket* t))) + (set-close-apache-socket t))) ,result))) (defun redirect-to-location (url) (write-header-line "Status" "302 Redirect") (write-header-line "Location" url) (write-char #\NewLine *apache-socket*) - (setq *close-apache-socket* t)) + (set-close-apache-socket t)) (defun output-ml-page (format html) (write-header-line "Status" "200 OK") @@ -66,7 +66,7 @@ (write-string "end" *apache-socket*) (write-char #\NewLine *apache-socket*) (write-string html *apache-socket*) - (setq *close-apache-socket* nil)) + (set-close-apache-socket nil)) (defun output-html-page (str) (output-ml-page :html str)) @@ -84,6 +84,10 @@ (when (= 2 (length name-val-list)) (destructuring-bind (name val) name-val-list (push (cons (kmrcl:ensure-keyword name) - (decode-uri-query-string val)) + (kmrcl:decode-uri-query-string val)) alist)))))))) + + + + diff --git a/variables.lisp b/variables.lisp index 2edf38b..6c040c0 100644 --- a/variables.lisp +++ b/variables.lisp @@ -7,7 +7,7 @@ ;;;; Programmer: Kevin M. Rosenberg ;;;; Date Started: Dec 2002 ;;;; -;;;; $Id: variables.lisp,v 1.1 2003/07/04 22:41:06 kevin Exp $ +;;;; $Id: variables.lisp,v 1.2 2003/07/05 00:51:04 kevin Exp $ ;;;; ************************************************************************* (in-package #:modlisp) @@ -18,22 +18,21 @@ (defvar *worker-count* 0 "used to name workers") -(defvar *listener-socket* - "Socket for the listener") - -(defvar *listener-proc* nil - "Process for the listener") - (defconstant +default-apache-port+ 20123 "Default port for listen") (defvar *apache-socket* nil "the socket stream to apache") -(defvar *close-apache-socket* nil - "set to T if you want to close the socket to apache after -the current command") +(defvar *listener-socket* + "Socket for the listener") + +(defvar *listener-process* nil + "Process for the listener") + +(defvar *number-server-requests*) +(defvar *number-worker-requests*) +(defvar *close-apache-socket*) + -(defvar *apache-nb-use-socket* 0 - "the number of requests sent in this socket") -- 2.34.1