;;;; 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) ,@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)))