1 ;;;; -*- Mode: Lisp; Syntax: ANSI-Common-Lisp; Base: 10; Package: modlisp -*-
2 ;;;; *************************************************************************
3 ;;;; FILE IDENTIFICATION
6 ;;;; Purpose: Utility functions for modlisp package
7 ;;;; Programmer: Kevin M. Rosenberg
8 ;;;; Date Started: Dec 2002
10 ;;;; $Id: base.lisp,v 1.2 2003/07/04 22:41:06 kevin Exp $
11 ;;;; *************************************************************************
13 (in-package #:modlisp)
16 (let ((*listener-socket* nil)
17 (*listener-process* nil))
19 (defun modlisp-start (&key (port +default-apache-port+)
20 (function 'demo-apache-command-processor))
22 (make-socket-server (next-server-name) function port
23 :format :text :wait nil)
25 (format t "Error ~A" e)
26 (decf *listener-count*)
28 (:no-error (process socket)
29 (setq *listener-socket* socket)
30 (setq *listener-process* process)
33 (defun modlisp-stop ()
34 (when *listener-process*
35 (format t "~&; killing process ~d~%" *listener-process*)
36 #+sbcl (sb-thread:destory-thread *listener-process*)
37 #+allegro (mp:process-kill *listener-process*)
38 #+allegro (mp:process-allow-schedule)
39 #+lispworks (mp:process-kill *listener-process*)
40 #+cmucl (mp:destroy process *listener-process*)
41 (setq *listener-process* nil))
42 (when *listener-socket*
43 (ignore-errors (close *listener-socket*))
44 (setq *listener-socket* nil)))
48 (defun next-server-name ()
49 (format nil "modlisp-socket-server-~d" (incf *listener-count*)))
51 (defun next-worker-name ()
52 (format nil "modlisp-worker-~d" (incf *worker-count*)))
55 (defun apache-command-issuer (*apache-socket* processor-fun)
56 "generates commands from apache, issues commands to processor-fun"
57 (let ((*close-apache-socket* t))
59 (loop for *apache-nb-use-socket* from 0
60 for command = (get-apache-command)
62 do (funcall processor-fun command)
63 (force-output *apache-socket*)
64 until *close-apache-socket*)
65 (close *apache-socket*))))
67 (defun get-apache-command ()
69 (let* ((header (loop for key = (read-line *apache-socket* nil nil)
71 (string-not-equal key "end")
73 for value = (read-line *apache-socket* nil nil)
74 collect (cons key value)))
75 (content-length (cdr (assoc "content-length" header :test #'equal)))
76 (content (when content-length
78 (parse-integer content-length :junk-allowed t)))))
80 (read-sequence content *apache-socket*)
81 (push (cons "posted-content" content) header))
84 (defun write-header-line (key value)
85 (write-string key *apache-socket*)
86 (write-char #\NewLine *apache-socket*)
87 (write-string value *apache-socket*)
88 (write-char #\NewLine *apache-socket*))
90 (defun header-value (command key)
91 (cdr (assoc key command :test #'string=)))
94 ;;; Default (demo) processor
96 (defun demo-apache-command-processor (command)
97 "Sample function to process an apache command"
98 (if (equal (header-value command "url") "/asp/fixed")
100 (debug-request command)))
102 (defun fixed-request ()
103 (let ((html (fixed-html)))
104 (write-header-line "Status" "200 OK")
105 (write-header-line "Content-Type" "text/html")
106 (write-header-line "Content-Length" (format nil "~d" (length html)))
107 (write-header-line "Keep-Socket" "1")
108 (write-string "end" *apache-socket*)
109 (write-char #\NewLine *apache-socket*)
110 (write-string html *apache-socket*)
111 (setq *close-apache-socket* nil)) )
113 (defun debug-request (command)
114 (let ((html (debug-table command)))
115 (write-header-line "Status" "200 OK")
116 (write-header-line "Content-Type" "text/html")
117 (write-header-line "Keep-Socket" "0")
118 (write-string "end" *apache-socket*)
119 (write-char #\NewLine *apache-socket*)
120 (write-string html *apache-socket*)
121 (setq *close-apache-socket* t)) )
123 (defun debug-table (command)
124 (with-output-to-string (s)
125 (write-string "<!DOCTYPE HTML PUBLIC \"-//IETF//DTD HTML//EN\">
129 <tr><t colspan=\"2\">mod_lisp debug</th></tr>
130 <tr><th>Key</th><th>Value</th></tr>" s)
131 (format s "<TR bgcolor=\"#F0F0c0\"><TD>apache-nb-use-socket</TD><TD>~a</TD></TR>" *apache-nb-use-socket*)
132 (loop for (key . value) in command do
133 (format s "<tr><td>~a</td><td>~a</td></tr>" key value))
134 (write-string "</tbody></table></body></html>" s)))
137 "<!DOCTYPE HTML PUBLIC \"-//IETF//DTD HTML//EN\">
138 <html><head></head><body><h1>mod_lisp</h1>
139 <p>This is a constant html string sent by mod_lisp</p></body></html>")