base.lisp

   1 ;;;; -*- Mode: Lisp; Syntax: ANSI-Common-Lisp; Base: 10; Package: modlisp -*-
   2 ;;;; *************************************************************************
   3 ;;;; FILE IDENTIFICATION
   4 ;;;;
   5 ;;;; Name:          base.lisp
   6 ;;;; Purpose:       Utility functions for modlisp package
   7 ;;;; Programmer:    Kevin M. Rosenberg
   8 ;;;; Date Started:  Dec 2002
   9 ;;;;
  10 ;;;; $Id: base.lisp,v 1.5 2003/07/05 22:59:56 kevin Exp $
  11 ;;;; *************************************************************************
  12
  13 (in-package #:modlisp)
  14
  15 (defun modlisp-start (&key (port +default-apache-port+)
  16                            (function 'demo-apache-command-processor)
  17                            (function-args nil))
  18   (let ((listener (make-instance 'listener)))
  19     (handler-case
  20         (make-socket-server (next-server-name) function port listener
  21                             :format :text :wait nil
  22                             :function-args function-args)
  23       (error (e)
  24         (format t "~&Error while trying to start modlisp server~&  ~A" e)
  25         (decf *listener-count*)
  26         (values nil nil))
  27       (:no-error (process socket)
  28         (setf (process listener) process)
  29         (setf (socket listener) socket)
  30         (push listener *active-listeners*)
  31         listener))))
  32
  33 (defun modlisp-stop (listener)
  34   (unless listener
  35     (cmsg "listener is NIL in modlisp-stop")
  36     (return-from modlisp-stop))
  37   (dolist (worker (workers listener))
  38     (close-active-socket (socket worker))
  39     (destroy-process (process worker)))
  40   (setf (workers listener) nil)
  41   (with-slots (process socket) listener
  42     (handler-case
  43           (destroy-process process)
  44       (error (e)
  45         (format t "~&Error while trying to kill modlisp server~&  ~A" e)))
  46     (when socket
  47       (ignore-errors (close-passive-socket socket))))
  48   (setq *active-listeners* (remove listener *active-listeners*)))
  49
  50 (defun next-server-name ()
  51   (format nil "modlisp-socket-server-~d" (incf *listener-count*)))
  52
  53 (defun next-worker-name ()
  54   (format nil "modlisp-worker-~d" (incf *worker-count*)))
  55
  56 (let ((*number-server-requests* 0)
  57       (*number-worker-requests* 0)
  58       (*close-apache-socket* t))
  59
  60   (defun apache-command-issuer (*apache-socket* processor-fun &rest args)
  61     "generates commands from apache, issues commands to processor-fun"
  62     (unwind-protect
  63          (progn
  64            (setq *number-worker-requests* 0)
  65            (do ((command (read-apache-command) (read-apache-command)))
  66                ((null command) 'done)
  67              (apply processor-fun command args)
  68              (force-output *apache-socket*)
  69              (incf *number-worker-requests*)
  70              (incf *number-server-requests*)
  71              (when *close-apache-socket*
  72                (return))))
  73       (close *apache-socket*)))
  74
  75   (defun get-number-worker-requests ()
  76     *number-worker-requests*)
  77
  78   (defun get-number-server-requests ()
  79     *number-server-requests*)
  80
  81   (defun set-close-apache-socket (close?)
  82     (setq *close-apache-socket* close?))
  83
  84   ) ;; closure
  85
  86 (defun read-apache-command ()
  87   (ignore-errors
  88     (let* ((header (read-apache-header))
  89           (content-length (cdr (assoc "content-length" header :test #'equal)))
  90           (content (when content-length
  91                      (make-string
  92                       (parse-integer content-length :junk-allowed t)))))
  93      (when content
  94        (read-sequence content *apache-socket*)
  95        (push (cons "posted-content" content) header))
  96      header)))
  97
  98 (defun read-apache-header ()
  99   (loop for key = (read-line *apache-socket* nil nil)
 100                         while (and key
 101                                    (string-not-equal key "end")
 102                                    (> (length key) 1))
 103                       for value = (read-line *apache-socket* nil nil)
 104                       collect (cons key value)))
 105
 106 (defun write-header-line (key value)
 107   (write-string key *apache-socket*)
 108   (write-char #\NewLine *apache-socket*)
 109   (write-string value *apache-socket*)
 110   (write-char #\NewLine *apache-socket*))
 111
 112 (defun header-value (command key)
 113   (cdr (assoc key command :test #'string=)))
 114