server.lisp

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