impl-acl.lisp

   1 ;;; -*- Mode:Lisp; Syntax:Common-lisp; Package: modlisp; Base:10 -*-
   2
   3 (in-package #:modlisp)
   4
   5 (eval-when (compile load eval)
   6   (require :socket))
   7
   8 (defun make-socket-server (name function port &key wait (format :text))
   9   (let* ((listener (socket:make-socket
  10                     :connect :passive
  11                     :local-port port
  12                     :address-family
  13                     (if (stringp port)
  14                         :file
  15                         (if (or (null port) (integerp port))
  16                             :internet
  17                             (error "illegal value for port: ~s" port)))
  18                     :format format))
  19          (proc (mp::process-run-function name
  20                  #'(lambda ()
  21                      (start-socket-server listener function
  22                                           :wait wait)))))
  23     (values proc listener)))
  24
  25 (defun worker-process (stream function conn count)
  26   (unwind-protect
  27     #+ignore
  28     (funcall function conn)
  29
  30     (excl:errorset (close conn) nil)))
  31
  32 (defun start-socket-server (passive-socket function &key wait)
  33   ;; internal function run in the server lightweight process
  34   ;; that continually processes the connection.
  35   ;; This code is careful to ensure that the sockets are
  36   ;; properly closed something abnormal happens.
  37   (unwind-protect
  38       (loop (let ((connection (socket:accept-connection passive-socket)))
  39               (if wait
  40                   (unwind-protect
  41                       (funcall connection function)
  42                     (excl:errorset (close connection) nil))
  43                 (let ((f function)
  44                       (c connection)
  45                       (name (next-worker-name))
  46                   (mp:process-run-function
  47                    name
  48                     #'(lambda ()
  49                         (unwind-protect
  50                              (apache-command-issuer connection function)
  51                           #+ignore
  52                           (handler-case
  53                               (apache-command-issuer function connection)
  54                             (error (e)
  55                               #+ignore
  56                               (format t "~&Error ~A [~A]~%" e name))
  57                             (:no-error ()
  58                               #+ignore
  59                               (format t "~&~A ended" name)))
  60                             (excl:errorset (close connection) nil)))
  61                       )))))
  62     (ignore-errors (close passive-socket))))