[Small-cl-src] prefork-example-simple.lisp

[Thomas F. Burdick]

;;;; prefork-example-simple.lisp
;;;;
;;;; This is a simple example of writing a preforking Unix server using SBCL.
;;;; This file was written to demonstrate the basic techniques of writing a
;;;; preforking server for educational purposes.  For a more nuanced example,
;;;; see prefork-example-realistic.lisp
;;;;
;;;; Because it uses fork(2) and waitpid(2), this file requires a
;;;; patched version of the sb-posix contrib module for SBCL.  A patch
;;;; against SBCL-0.8.8 is available separately.
;;;;
;;;; We also assumes a BSD-like system, due to its use of flock(2) for
;;;; serialization.

;;;; Copyright (C) 2004, Thomas F. Burdick
;;;; 
;;;; Permission is hereby granted, free of charge, to any person obtaining a
;;;; copy of this software and associated documentation files (the "Software"),
;;;; to deal in the Software without restriction, including without limitation
;;;; the rights to use, copy, modify, merge, publish, distribute, sublicense,
;;;; and/or sell copies of the Software, and to permit persons to whom the
;;;; Software is furnished to do so, subject to the following conditions:
;;;; 
;;;; The above copyright notice and this permission notice shall be included in 
;;;; all copies or substantial portions of the Software.
;;;; 
;;;; THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR 
;;;; IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, 
;;;; FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE 
;;;; AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER 
;;;; LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING 
;;;; FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS 
;;;; IN THE SOFTWARE.

(eval-when (:compile-toplevel :load-toplevel :execute)
  (require :sb-posix)
  (require :sb-bsd-sockets))

(defpackage :prefork-example-simple
  (:use :cl :sb-bsd-sockets))

(in-package :prefork-example-simple)

;;; In this simple example, the parent sets up a server socket, forks
;;; +NCHILDREN+ child processes, then just sits there, and periodically reaps
;;; and reforks any child processes that die.
;;;
;;; The child processes wait for incoming connections.  Not all Unixes serialize
;;; `accept's in the kernel, so we need to handle this ourselves.  We do this by
;;; acquiring an exclusive file lock around the call to accept(2).  We use
;;; flock(2) to do this, but we could just as well use fcntl(2) or SysV
;;; semaphores.


;;;
;;; The Parent
;;; 

(defconstant +nchildren+ 8)
(defconstant +backlog+ 16)

(declaim (type (simple-array (or integer null)) *children*))
(defvar *children* (make-array +nchildren+ :initial-element nil)
  "the PIDs of our children")

(defvar *childp* nil "True in child processes.")

(defvar *server-socket* nil)
(defvar *lock* nil)

(defun start-server ()
  "The main loop of the parent process."
  (setup)
  (unwind-protect
       (progn (fork-children)
	      (loop
		 ;; We call SERVE-EVENT here to let other Lisp applications
		 ;; run, eg, SLIME.
		 (sb-sys:serve-event 60)
		 ;; Periodically reap any dead processes.
		 (reap-children)))
    (unless *childp* (stop-server))))

(defun stop-server ()
  (kill-children)
  (teardown-lock)
  (socket-close *server-socket*))

(defun setup ()
  "Set up sockets and locks so the parent can begin forking."
  (setup-lock)
  (setup-parent-signal-handlers)
  (when *server-socket* (socket-close *server-socket*))
  (setf *server-socket* (make-instance 'inet-socket :type :stream :protocol :tcp))
  (setf (sockopt-reuse-address *server-socket*) t)
  (socket-bind *server-socket* (make-inet-address "127.0.0.1") 1978)
  (socket-listen *server-socket* +backlog+))


;;;
;;; The child
;;; 

(defun child-main ()
  "Get in the queue to accept, serve the request, loop."
  (setup-child-signal-handlers)
  (loop for socket = (serial-accept *server-socket*)
        for stream = (socket-make-stream socket :input t :output t)
        for client-id = (read-line stream)
        for message = (read stream)
        do (format stream "Hello ~A, this is PID ~D~%~S"
		   client-id (sb-posix:getpid) message)
           (finish-output stream)
           (socket-close socket)))

;;;
;;; Forking and reaping
;;; 

(defun fork-children ()
  (dotimes (i +nchildren+)
    (fork-one-child i)))

(defun fork-one-child (index)
  (labels ((child ()
	     (unwind-protect
		  (progn (setf *children* (vector)
			       *childp* t)
			 (child-main))
	       (sb-ext:quit)))
	   (parent (pid)
	     (setf (aref *children* index) pid)))
    (let ((pid (sb-posix:fork)))
      (if (zerop pid) (child) (parent pid)))))

(defun reap-children ()
  "Unix is sick."
  (when (every #'null *children*) (return-from reap-children))
  (loop for pid = (ignore-errors (sb-posix:waitpid 0 sb-posix::wnohang))
        while pid do
        (let ((index (position pid *children*)))
	  (when index
	    (warn "Reaping child process ~D" pid)
	    (fork-one-child index)))))

(defun kill-children ()
  "Unix is sick."
  (unless *childp*
    (loop for pid across *children*
	  for index upfrom 0
          when pid do (handler-case (sb-posix:kill pid sb-posix::sigterm)
			(sb-posix:syscall-error (error)
			  (warn "Could not kill PID ~D: ~A" pid error)
			  (setf (aref *children* index) nil))))
    (loop for pid across *children*
          for index upfrom 0
          when pid do (ignore-errors (sb-posix:waitpid pid 0))
	              (setf (aref *children* index) nil))))

;;;
;;; Signals
;;; 

(defun setup-child-signal-handlers ()
  (sb-sys:enable-interrupt sb-unix:sigterm (signal-handler 'sb-ext:quit))
  (sb-sys:ignore-interrupt sb-unix:sigint))
   
(defun setup-parent-signal-handlers ()
  (sb-sys:enable-interrupt sb-unix:sigterm (signal-handler 'terminate-gracefully)))

(defun terminate-gracefully ()
  (kill-children)
  (sb-ext:quit))

(defun signal-handler (function)
  "Return a signal hander function that will funcall FUNCTION."
  (check-type function (or function symbol))
  (lambda (signal code scp)
    (declare (ignore signal code scp))
    (funcall function)))

;;; Locking
;;;
;;; We serialize the child processes access to the server socket by acquiring an
;;; exclusive file lock around the call to accept.  The advantage of this is
;;; it's really simple and the kernel takes care of everything for us.  The
;;; disadvantage is that the parent process doesn't know what's happening, so it
;;; can't intervene to add or remove child processes.

(defmacro with-lock (fd-spec &body forms)
  (let ((=fd (gensym)))
    `(let ((,=fd ,fd-spec))
       (unwind-protect (progn (flock ,=fd :exclusive)
			      , at forms)
	 (flock ,=fd :unlock)))))

(defun serial-accept (socket)
  (with-lock *lock*
    (socket-accept socket)))

(defun setup-lock ()
  (let ((lock-file (format nil "/tmp/~D.lock" (sb-posix:getpid))))
    (unless *lock* (setf *lock* (open lock-file :if-does-not-exist :create)))))

(defun teardown-lock ()
  (when *lock*
    (delete-file *lock*)
    (close *lock*)
    (setf *lock* nil)))

;; I didn't patch SB-POSIX to add flock(2) because it isn't POSIX, it's just a
;; convenient BSD function.

(defmacro defconstant-once (name form &optional doc)
  `(defconstant ,name (if (boundp ',name)
			  (symbol-value ',name)
			  ,form)
     ,doc))

(defconstant-once +flock-table+
   #((:shared 1) (:exclusive 2) (:nonblocking 4) (:unlock 8)))

(defun flock (fd-spec &rest options)
  "Perform flock(2) on the FD or FILE-STREAM given as FD-SPEC.  OPTIONS are taken from +FLOCK-TABLE+"
  (let* ((options
	  (reduce #'logior options
		  :key (lambda (option)
			 (or (second (find option +flock-table+ :key #'first))
			     (error "Unknown flock option: ~S" option)))
		  :initial-value 0))
	 (fd (etypecase fd-spec
	       (sb-alien:int fd-spec)
	       (file-stream (sb-sys:fd-stream-fd fd-spec)))))
    (sb-alien:alien-funcall
     (sb-alien:extern-alien
      "flock" (function sb-alien:int sb-alien:int sb-alien:int))
     fd options)))