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.1 2003/07/04 19:52:32 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 'sample-process-apache-command))
22 (make-socket-server (next-server-name) function port :format :text
25 (format t "Error ~A" e)
26 (decf *listener-count*)
28 (:no-error (proc socket)
29 (setq *listener-socket* socket)
30 (setq *listener-proc* proc)
33 (defun modlisp-stop ()
35 (format t "~&; killing ~d~%" *listener-proc*)
36 #+sbcl (sb-unix:unix-kill *listener-proc* :sigalrm)
37 #+allegro (mp:process-kill *listener-proc*)
38 #+allegro (mp:process-allow-schedule)
40 (setq *listener-proc* nil)
41 (when *listener-socket*
42 (ignore-errors (close *listener-socket*))
43 (setq *listener-socket* nil)))
47 (defun next-server-name ()
48 (format nil "modlisp-socket-server-~d" (incf *listener-count*)))
50 (defun next-worker-name ()
51 (format nil "modlisp-worker-~d" (incf *worker-count*)))
54 (defun apache-command-issuer (*apache-socket*
56 (processor-fun 'demo-apache-command-processor))
57 "generates commands from apache, issues commands to processor-fun"
58 (let ((*close-apache-socket* t))
60 (loop for *apache-nb-use-socket* from 0
61 for command = (get-apache-command)
63 do (funcall processor-fun command)
64 (force-output *apache-socket*)
65 until *close-apache-socket*)
66 (close *apache-socket*))))
68 (defun get-apache-command ()
70 (let* ((header (loop for key = (read-line *apache-socket* nil nil)
72 (string-not-equal key "end")
74 for value = (read-line *apache-socket* nil nil)
75 collect (cons key value)))
76 (content-length (cdr (assoc "content-length" header :test #'equal)))
77 (content (when content-length
79 (parse-integer content-length :junk-allowed t)))))
81 (read-sequence content *apache-socket*)
82 (push (cons "posted-content" content) header))
85 (defun write-header-line (key value)
86 (write-string key *apache-socket*)
87 (write-char #\NewLine *apache-socket*)
88 (write-string value *apache-socket*)
89 (write-char #\NewLine *apache-socket*))
91 (defun header-value (command key)
92 (cdr (assoc key command :test #'string=)))
95 ;;; Default (demo) processor
97 (defun demo-apache-command-processor (command)
98 "Sample function to process an apache command"
99 (if (equal (header-value command "url") "/asp/fixed")
101 (debug-request command)))
103 (defun fixed-request ()
104 (let ((html (fixed-html)))
105 (write-header-line "Status" "200 OK")
106 (write-header-line "Content-Type" "text/html")
107 (write-header-line "Content-Length" (format nil "~d" (length html)))
108 (write-header-line "Keep-Socket" "1")
109 (write-string "end" *apache-socket*)
110 (write-char #\NewLine *apache-socket*)
111 (write-string html *apache-socket*)
112 (setq *close-apache-socket* nil)) )
114 (defun debug-request (command)
115 (let ((html (debug-table command)))
116 (write-header-line "Status" "200 OK")
117 (write-header-line "Content-Type" "text/html")
118 (write-header-line "Keep-Socket" "0")
119 (write-string "end" *apache-socket*)
120 (write-char #\NewLine *apache-socket*)
121 (write-string html *apache-socket*)
122 (setq *close-apache-socket* t)) )
124 (defun debug-table (command)
125 (with-output-to-string (s)
126 (write-string "<!DOCTYPE HTML PUBLIC \"-//IETF//DTD HTML//EN\">
127 <HTML><HEAD></HEAD><BODY><TABLE bgcolor=\"#c0c0c0\">
128 <TR bgcolor=\"yellow\"><TH COLSPAN=2>ACL 6.2 + mod_lisp 2.0 + apache + Linux</TH></TR>
129 <TR bgcolor=\"yellow\"><TH>Key</TH><TH>Value</TH></TR>" s)
130 (format s "<TR bgcolor=\"#F0F0c0\"><TD>apache-nb-use-socket</TD><TD>~a</TD></TR>" *apache-nb-use-socket*)
131 (loop for (key . value) in command do
132 (format s "<TR bgcolor=\"#F0F0c0\"><TD>~a</TD><TD>~a</TD></TR>" key value))
133 (write-string "</TABLE></BODY></HTML>" s)))
136 "<!DOCTYPE HTML PUBLIC \"-//IETF//DTD HTML//EN\">
137 <HTML><HEAD></HEAD><BODY><H1>mod_lisp 2.0</H1><P>This is a constant
138 html string sent by mod_lisp</P></BODY></HTML>")