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