taskmaster.lisp

   1 ;;; -*- Mode: LISP; Syntax: COMMON-LISP; Base: 10 -*-
   2 ;;; $Header$
   3
   4 ;;; Copyright (c) 2004-2009, Dr. Edmund Weitz.  All rights reserved.
   5
   6 ;;; Redistribution and use in source and binary forms, with or without
   7 ;;; modification, are permitted provided that the following conditions
   8 ;;; are met:
   9
  10 ;;;   * Redistributions of source code must retain the above copyright
  11 ;;;     notice, this list of conditions and the following disclaimer.
  12
  13 ;;;   * Redistributions in binary form must reproduce the above
  14 ;;;     copyright notice, this list of conditions and the following
  15 ;;;     disclaimer in the documentation and/or other materials
  16 ;;;     provided with the distribution.
  17
  18 ;;; THIS SOFTWARE IS PROVIDED BY THE AUTHOR 'AS IS' AND ANY EXPRESSED
  19 ;;; OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED
  20 ;;; WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE
  21 ;;; ARE DISCLAIMED.  IN NO EVENT SHALL THE AUTHOR BE LIABLE FOR ANY
  22 ;;; DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL
  23 ;;; DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE
  24 ;;; GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS
  25 ;;; INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY,
  26 ;;; WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING
  27 ;;; NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS
  28 ;;; SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
  29
  30 (in-package :hunchentoot)
  31
  32 (defclass taskmaster ()
  33   ((acceptor :accessor taskmaster-acceptor
  34              :documentation "A backpointer to the acceptor instance
  35 this taskmaster works for."))
  36   (:documentation "An instance of this class is responsible for
  37 distributing the work of handling requests for its acceptor.  This is
  38 an \"abstract\" class in the sense that usually only instances of
  39 subclasses of TASKMASTER will be used."))
  40
  41 (defgeneric execute-acceptor (taskmaster)
  42   (:documentation "This is a callback called by the acceptor once it
  43 has performed all initial processing to start listening for incoming
  44 connections \(see START-LISTENING).  It usually calls the
  45 ACCEPT-CONNECTIONS method of the acceptor, but depending on the
  46 taskmaster instance the method might be called from a new thread."))
  47
  48 (defgeneric handle-incoming-connection (taskmaster socket)
  49   (:documentation "This function is called by the acceptor to start
  50 processing of requests on a new incoming connection.  SOCKET is the
  51 usocket instance that represents the new connection \(or a socket
  52 handle on LispWorks).  The taskmaster starts processing requests on
  53 the incoming connection by calling the PROCESS-CONNECTION method of
  54 the acceptor instance.  The SOCKET argument is passed to
  55 PROCESS-CONNECTION as an argument."))
  56
  57 (defgeneric shutdown (taskmaster)
  58   (:documentation "Shuts down the taskmaster, i.e. frees all resources
  59 that were set up by it.  For example, a multi-threaded taskmaster
  60 might terminate all threads that are currently associated with it.
  61 This function is called by the acceptor's STOP method."))
  62
  63 (defclass single-threaded-taskmaster (taskmaster)
  64   ()
  65   (:documentation "A taskmaster that runs synchronously in the thread
  66 where the START function was invoked \(or in the case of LispWorks in
  67 the thread started by COMM:START-UP-SERVER).  This is the simplest
  68 possible taskmaster implementation in that its methods do nothing but
  69 calling their acceptor \"sister\" methods - EXECUTE-ACCEPTOR calls
  70 ACCEPT-CONNECTIONS, HANDLE-INCOMING-CONNECTION calls
  71 PROCESS-CONNECTION."))
  72
  73 (defmethod execute-acceptor ((taskmaster single-threaded-taskmaster))
  74   ;; in a single-threaded environment we just call ACCEPT-CONNECTIONS
  75   (accept-connections (taskmaster-acceptor taskmaster)))
  76
  77 (defmethod handle-incoming-connection ((taskmaster single-threaded-taskmaster) socket)
  78   ;; in a single-threaded environment we just call PROCESS-CONNECTION
  79   (process-connection (taskmaster-acceptor taskmaster) socket))
  80
  81 (defclass one-thread-per-connection-taskmaster (taskmaster)
  82   (#-:lispworks
  83    (acceptor-process :accessor acceptor-process
  84                      :documentation "A process that accepts incoming
  85 connections and hands them off to new processes for request
  86 handling."))
  87   (:documentation "A taskmaster that starts one thread for listening
  88 to incoming requests and one thread for each incoming connection.
  89
  90 This is the default taskmaster implementation for multi-threaded Lisp
  91 implementations."))
  92
  93 ;; usocket implementation
  94
  95 #-:lispworks
  96 (defmethod shutdown ((taskmaster taskmaster))
  97   taskmaster)
  98
  99 #-:lispworks
 100 (defmethod shutdown ((taskmaster one-thread-per-connection-taskmaster))
 101   ;; just wait until the acceptor process has finished, then return
 102   (loop
 103    (unless (bt:thread-alive-p (acceptor-process taskmaster))
 104      (return))
 105    (sleep 1))
 106   taskmaster)
 107
 108 #-:lispworks
 109 (defmethod execute-acceptor ((taskmaster one-thread-per-connection-taskmaster))
 110   (setf (acceptor-process taskmaster)
 111         (bt:make-thread (lambda ()
 112                           (accept-connections (taskmaster-acceptor taskmaster)))
 113                         :name (format nil "Hunchentoot listener \(~A:~A)"
 114                                       (or (acceptor-address (taskmaster-acceptor taskmaster)) "*")
 115                                       (acceptor-port (taskmaster-acceptor taskmaster))))))
 116
 117 #-:lispworks
 118 (defun client-as-string (socket)
 119   "A helper function which returns the client's address and port as a
 120 string and tries to act robustly in the presence of network problems."
 121   (let ((address (usocket:get-peer-address socket))
 122         (port (usocket:get-peer-port socket)))
 123     (when (and address port)
 124       (format nil "~A:~A"
 125               (usocket:vector-quad-to-dotted-quad address)
 126               port))))
 127
 128 #-:lispworks
 129 (defmethod handle-incoming-connection ((taskmaster one-thread-per-connection-taskmaster) socket)
 130   (bt:make-thread (lambda ()
 131                     (process-connection (taskmaster-acceptor taskmaster) socket))
 132                   :name (format nil "Hunchentoot worker \(client: ~A)" (client-as-string socket))))
 133
 134 ;; LispWorks implementation
 135
 136 #+:lispworks
 137 (defmethod shutdown ((taskmaster taskmaster))
 138   (when-let (process (acceptor-process (taskmaster-acceptor taskmaster)))
 139     ;; kill the main acceptor process, see LW documentation for
 140     ;; COMM:START-UP-SERVER
 141     (mp:process-kill process))
 142   taskmaster)
 143
 144 #+:lispworks
 145 (defmethod execute-acceptor ((taskmaster one-thread-per-connection-taskmaster))
 146   (accept-connections (taskmaster-acceptor taskmaster)))
 147
 148 #+:lispworks
 149 (defmethod handle-incoming-connection ((taskmaster one-thread-per-connection-taskmaster) handle)
 150   (incf *worker-counter*)
 151   ;; check if we need to perform a global GC
 152   (when (and *cleanup-interval*
 153              (zerop (mod *worker-counter* *cleanup-interval*)))
 154     (when *cleanup-function*
 155       (funcall *cleanup-function*)))
 156   (mp:process-run-function (format nil "Hunchentoot worker \(client: ~{~A:~A~})"
 157                                    (multiple-value-list
 158                                     (get-peer-address-and-port handle)))
 159                            nil #'process-connection
 160                            (taskmaster-acceptor taskmaster) handle))