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.4 2003/07/05 22:54:00 kevin Exp $
  11 ;;;; *************************************************************************
  12
  13 (in-package #:modlisp)
  14
  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)
  20   )
  21
  22 (defun close-socket (sock)
  23   (ignore-errors (close sock)))
  24
  25
  26 (defun modlisp-start (&key (port +default-apache-port+)
  27                            (function 'demo-apache-command-processor)
  28                            (function-args nil))
  29   (let ((listener (make-instance 'listener)))
  30     (handler-case
  31         (make-socket-server (next-server-name) function port listener
  32                             :format :text :wait nil
  33                             :function-args function-args)
  34       (error (e)
  35         (format t "~&Error while trying to start modlisp server~&  ~A" e)
  36         (decf *listener-count*)
  37         (values nil nil))
  38       (:no-error (process socket)
  39         (setf (process listener) process)
  40         (setf (socket listener) socket)
  41         (push listener *active-listeners*)
  42         listener))))
  43
  44 (defun modlisp-stop (listener)
  45   (unless 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
  53     (handler-case
  54           (destroy-process process)
  55       (error (e)
  56         (format t "~&Error while trying to kill modlisp server~&  ~A" e)))
  57     (when socket
  58       (ignore-errors (close-socket socket))))
  59   (setq *active-listeners* (remove listener *active-listeners*)))
  60
  61 (defun next-server-name ()
  62   (format nil "modlisp-socket-server-~d" (incf *listener-count*)))
  63
  64 (defun next-worker-name ()
  65   (format nil "modlisp-worker-~d" (incf *worker-count*)))
  66
  67 (let ((*number-server-requests* 0)
  68       (*number-worker-requests* 0)
  69       (*close-apache-socket* t))
  70
  71   (defun apache-command-issuer (*apache-socket* processor-fun &rest args)
  72     "generates commands from apache, issues commands to processor-fun"
  73     (unwind-protect
  74          (progn
  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*
  83                (return))))
  84       (close *apache-socket*)))
  85
  86   (defun get-number-worker-requests ()
  87     *number-worker-requests*)
  88
  89   (defun get-number-server-requests ()
  90     *number-server-requests*)
  91
  92   (defun set-close-apache-socket (close?)
  93     (setq *close-apache-socket* close?))
  94
  95   ) ;; closure
  96
  97 (defun read-apache-command ()
  98   (ignore-errors
  99     (let* ((header (read-apache-header))
 100           (content-length (cdr (assoc "content-length" header :test #'equal)))
 101           (content (when content-length
 102                      (make-string
 103                       (parse-integer content-length :junk-allowed t)))))
 104      (when content
 105        (read-sequence content *apache-socket*)
 106        (push (cons "posted-content" content) header))
 107      header)))
 108
 109 (defun read-apache-header ()
 110   (loop for key = (read-line *apache-socket* nil nil)
 111                         while (and key
 112                                    (string-not-equal key "end")
 113                                    (> (length key) 1))
 114                       for value = (read-line *apache-socket* nil nil)
 115                       collect (cons key value)))
 116
 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*))
 122
 123 (defun header-value (command key)
 124   (cdr (assoc key command :test #'string=)))
 125