server.lisp

   1 ;;; -*- Mode:Lisp; Syntax:Common-lisp; Package: modlisp; Base:10 -*-
   2
   3 (in-package #:modlisp)
   4
   5
   6 (defun make-socket-server (name function port listener
   7                            &key wait (format :text) function-args)
   8   (let* ((passive-socket (create-inet-listener port :format format))
   9          (proc (make-process name
  10                              #'(lambda ()
  11                                  (start-socket-server
  12                                   passive-socket function listener
  13                                   :wait wait
  14                                   :function-args function-args)))))
  15     (values proc passive-socket)))
  16
  17
  18 (defmethod initialize-instance :after
  19            ((self worker) &key listener socket func name function-args
  20             &allow-other-keys)
  21   (unless socket
  22     (error "socket not provided to modlisp-worker"))
  23   (setf (slot-value self 'listener) listener)
  24   (setf (slot-value self 'func) func)
  25   (setf (slot-value self 'function-args) function-args)
  26   (setf (slot-value self 'thread-fun)
  27     #'(lambda ()
  28         (unwind-protect
  29             (handler-case
  30                 (apply #'apache-command-issuer socket func function-args)
  31               (error (e)
  32                 (cmsg "Error ~A [~A]" e name)
  33                 ;;(error e)
  34                 ))
  35           (progn
  36             (errorset (close-active-socket socket) nil)
  37             (cmsg-c :threads "~A ended" name)
  38             (setf (workers listener)
  39               (remove self (workers listener))))))))
  40
  41 (defun start-socket-server (passive-socket function listener
  42                             &key wait function-args)
  43   (unwind-protect
  44       (loop
  45        (let ((connection (accept-tcp-connection passive-socket)))
  46           (if wait
  47               (unwind-protect
  48                   (funcall connection function)
  49                 (errorset (close connection) nil))
  50             (let ((worker (make-instance 'worker :listener listener
  51                                          :func function
  52                                          :function-args function-args
  53                                          :name (next-worker-name)
  54                                          :socket connection)))
  55               (setf (process worker)
  56                 (make-process (name worker) (thread-fun worker)))
  57               (push worker (workers listener))))))
  58     (errorset (close-passive-socket passive-socket) nil)))