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.4 2003/07/05 22:54:00 kevin Exp $
11 ;;;; *************************************************************************
13 (in-package #:modlisp)
15 (defun destroy-process (process)
16 #+sbcl (sb-thread:destroy-thread process)
17 #+cmucl (mp:destroy-process process)
18 #+allegro (mp:process-kill process)
19 #+lispworks (mp:process-kill process)
22 (defun close-socket (sock)
23 (ignore-errors (close sock)))
26 (defun modlisp-start (&key (port +default-apache-port+)
27 (function 'demo-apache-command-processor)
29 (let ((listener (make-instance 'listener)))
31 (make-socket-server (next-server-name) function port listener
32 :format :text :wait nil
33 :function-args function-args)
35 (format t "~&Error while trying to start modlisp server~& ~A" e)
36 (decf *listener-count*)
38 (:no-error (process socket)
39 (setf (process listener) process)
40 (setf (socket listener) socket)
41 (push listener *active-listeners*)
44 (defun modlisp-stop (listener)
46 (cmsg "listener is NIL in modlisp-stop")
47 (return-from modlisp-stop))
48 (dolist (worker (workers listener))
49 (close-socket (socket worker))
50 (destroy-process (process worker)))
51 (setf (workers listener) nil)
52 (with-slots (process socket) listener
54 (destroy-process process)
56 (format t "~&Error while trying to kill modlisp server~& ~A" e)))
58 (ignore-errors (close-socket socket))))
59 (setq *active-listeners* (remove listener *active-listeners*)))
61 (defun next-server-name ()
62 (format nil "modlisp-socket-server-~d" (incf *listener-count*)))
64 (defun next-worker-name ()
65 (format nil "modlisp-worker-~d" (incf *worker-count*)))
67 (let ((*number-server-requests* 0)
68 (*number-worker-requests* 0)
69 (*close-apache-socket* t))
71 (defun apache-command-issuer (*apache-socket* processor-fun &rest args)
72 "generates commands from apache, issues commands to processor-fun"
75 (setq *number-worker-requests* 0)
76 (do ((command (read-apache-command) (read-apache-command)))
77 ((null command) 'done)
78 (apply processor-fun command args)
79 (force-output *apache-socket*)
80 (incf *number-worker-requests*)
81 (incf *number-server-requests*)
82 (when *close-apache-socket*
84 (close *apache-socket*)))
86 (defun get-number-worker-requests ()
87 *number-worker-requests*)
89 (defun get-number-server-requests ()
90 *number-server-requests*)
92 (defun set-close-apache-socket (close?)
93 (setq *close-apache-socket* close?))
97 (defun read-apache-command ()
99 (let* ((header (read-apache-header))
100 (content-length (cdr (assoc "content-length" header :test #'equal)))
101 (content (when content-length
103 (parse-integer content-length :junk-allowed t)))))
105 (read-sequence content *apache-socket*)
106 (push (cons "posted-content" content) header))
109 (defun read-apache-header ()
110 (loop for key = (read-line *apache-socket* nil nil)
112 (string-not-equal key "end")
114 for value = (read-line *apache-socket* nil nil)
115 collect (cons key value)))
117 (defun write-header-line (key value)
118 (write-string key *apache-socket*)
119 (write-char #\NewLine *apache-socket*)
120 (write-string value *apache-socket*)
121 (write-char #\NewLine *apache-socket*))
123 (defun header-value (command key)
124 (cdr (assoc key command :test #'string=)))