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                 (if (catch-errors listener)
  27                     (handler-case
  28                         (apply (listener-function listener)
  29                                connection
  30                                (function-args listener))
  31                       (error (e)
  32                         (cmsg "Error ~A [~A]" e name)))
  33                   (apply (listener-function listener)
  34                          connection
  35                          (function-args listener)))
  36           (progn
  37             (errorset (close-active-socket connection) nil)
  38             (cmsg-c :threads "~A ended" name)
  39             (setf (workers listener)
  40                   (remove self (workers listener))))))))
  41
  42 (defun start-socket-server (listener)
  43   (unwind-protect
  44       (loop
  45        (let ((connection (accept-tcp-connection (socket listener))))
  46          (if (wait listener)
  47              (unwind-protect
  48                   (apply (listener-function listener)
  49                          connection
  50                          (function-args listener))
  51                (errorset (close connection) nil))
  52              (let ((worker (make-instance 'worker :listener listener
  53                                           :connection connection
  54                                           :name (next-worker-name))))
  55               (setf (process worker)
  56                 (make-process (name worker) (thread-fun worker)))
  57               (push worker (workers listener))))))
  58     (errorset (close-passive-socket (socket listener)) nil)))