taskmaster.lisp 1 ;;; -*- Mode: LISP; Syntax: COMMON-LISP; Base: 10 -*-
2
3 ;;; Copyright (c) 2004-2010, Dr. Edmund Weitz. All rights reserved.
4
5 ;;; Redistribution and use in source and binary forms, with or without
6 ;;; modification, are permitted provided that the following conditions
7 ;;; are met:
8
9 ;;; * Redistributions of source code must retain the above copyright
10 ;;; notice, this list of conditions and the following disclaimer.
11
12 ;;; * Redistributions in binary form must reproduce the above
13 ;;; copyright notice, this list of conditions and the following
14 ;;; disclaimer in the documentation and/or other materials
15 ;;; provided with the distribution.
16
17 ;;; THIS SOFTWARE IS PROVIDED BY THE AUTHOR 'AS IS' AND ANY EXPRESSED
18 ;;; OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED
19 ;;; WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE
20 ;;; ARE DISCLAIMED. IN NO EVENT SHALL THE AUTHOR BE LIABLE FOR ANY
21 ;;; DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL
22 ;;; DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE
23 ;;; GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS
24 ;;; INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY,
25 ;;; WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING
26 ;;; NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS
27 ;;; SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
28
29 (in-package :hunchentoot)
30
31 (defclass taskmaster ()
32 ((acceptor :accessor taskmaster-acceptor
33 :documentation "A backpointer to the acceptor instance
34 this taskmaster works for."))
35 (:documentation "An instance of this class is responsible for
36 distributing the work of handling requests for its acceptor. This is
37 an \"abstract\" class in the sense that usually only instances of
38 subclasses of TASKMASTER will be used."))
39
40 (defgeneric execute-acceptor (taskmaster)
41 (:documentation "This is a callback called by the acceptor once it
42 has performed all initial processing to start listening for incoming
43 connections \(see START-LISTENING). It usually calls the
44 ACCEPT-CONNECTIONS method of the acceptor, but depending on the
45 taskmaster instance the method might be called from a new thread."))
46
47 (defgeneric handle-incoming-connection (taskmaster socket)
48 (:documentation "This function is called by the acceptor to start
49 processing of requests on a new incoming connection. SOCKET is the
50 usocket instance that represents the new connection \(or a socket
51 handle on LispWorks). The taskmaster starts processing requests on
52 the incoming connection by calling the PROCESS-CONNECTION method of
53 the acceptor instance. The SOCKET argument is passed to
54 PROCESS-CONNECTION as an argument."))
55
56 (defgeneric shutdown (taskmaster)
57 (:documentation "Shuts down the taskmaster, i.e. frees all resources
58 that were set up by it. For example, a multi-threaded taskmaster
59 might terminate all threads that are currently associated with it.
60 This function is called by the acceptor's STOP method."))
61
62 (defgeneric create-request-handler-thread (taskmaster socket)
63 (:documentation
64 "Create a new thread in which to process the request.
65 This thread will call PROCESS-CONNECTION to process the request."))
66
67 (defgeneric too-many-taskmaster-requests (taskmaster socket)
68 (:documentation
69 "Signal a \"too many requests\" error, just prior to closing the connection."))
70
71 (defgeneric taskmaster-max-thread-count (taskmaster)
72 (:documentation
73 "The maximum number of request threads this taskmaster will simultaneously
74 run before refusing or queueing new connections requests. If the value
75 is null, then there is no limit.")
76 (:method ((taskmaster taskmaster))
77 "Default method -- no limit on the number of threads."
78 nil))
79
80 (defgeneric taskmaster-max-accept-count (taskmaster)
81 (:documentation
82 "The maximum number of connections this taskmaster will accept before refusing
83 new connections. If supplied, this must be greater than MAX-THREAD-COUNT.
84 The number of queued requests is the difference between MAX-ACCEPT-COUNT
85 and MAX-THREAD-COUNT.")
86 (:method ((taskmaster taskmaster))
87 "Default method -- no limit on the number of connections."
88 nil))
89
90 (defgeneric taskmaster-thread-count (taskmaster)
91 (:documentation
92 "Returns the current number of taskmaster requests.")
93 (:method ((taskmaster taskmaster))
94 "Default method -- claim there is one connection thread."
95 1))
96
97 (defgeneric increment-taskmaster-thread-count (taskmaster)
98 (:documentation
99 "Atomically increment the number of taskmaster requests.")
100 (:method ((taskmaster taskmaster))
101 "Default method -- do nothing."
102 nil))
103
104 (defgeneric decrement-taskmaster-thread-count (taskmaster)
105 (:documentation
106 "Atomically decrement the number of taskmaster requests")
107 (:method ((taskmaster taskmaster))
108 "Default method -- do nothing."
109 nil))
110
111 (defgeneric start-thread (taskmaster thunk &key name)
112 (:documentation
113 "Start a name thread in which to call the THUNK, in the context of the given TASKMASTER.
114 Keyword arguments provide TASKMASTER-dependent options.
115 Return a thread object.
116
117 Hunchentoot taskmaster methods will call it with the taskmaster as the context,
118 allowing hunchentoot extensions to define specialized methods that may e.g.
119 wrap the thunk within a proper set of bindings and condition handlers.")
120 (:method ((taskmaster t) thunk &key name)
121 #-lispworks
122 (bt:make-thread thunk :name name)
123 #+lispworks
124 (mp:process-run-function name nil thunk)))
125
126
127 (defclass single-threaded-taskmaster (taskmaster)
128 ()
129 (:documentation "A taskmaster that runs synchronously in the thread
130 where the START function was invoked \(or in the case of LispWorks in
131 the thread started by COMM:START-UP-SERVER). This is the simplest
132 possible taskmaster implementation in that its methods do nothing but
133 calling their acceptor \"sister\" methods - EXECUTE-ACCEPTOR calls
134 ACCEPT-CONNECTIONS, HANDLE-INCOMING-CONNECTION calls
135 PROCESS-CONNECTION."))
136
137 (defmethod execute-acceptor ((taskmaster single-threaded-taskmaster))
138 ;; in a single-threaded environment we just call ACCEPT-CONNECTIONS
139 (accept-connections (taskmaster-acceptor taskmaster)))
140
141 (defmethod handle-incoming-connection ((taskmaster single-threaded-taskmaster) socket)
142 ;; in a single-threaded environment we just call PROCESS-CONNECTION
143 (process-connection (taskmaster-acceptor taskmaster) socket))
144
145 (defvar *default-max-thread-count* 100)
146 (defvar *default-max-accept-count* (+ *default-max-thread-count* 20))
147
148
149 (defclass multi-threaded-taskmaster (taskmaster)
150 ((acceptor-process
151 :accessor acceptor-process
152 :documentation
153 "A process that accepts incoming connections and hands them off to new processes
154 for request handling."))
155 (:documentation "An abstract class for taskmasters that use multiple threads.
156 For a concrete class to instantiate, use one-thread-per-connection-taskmaster."))
157
158 (defmethod execute-acceptor ((taskmaster multi-threaded-taskmaster))
159 (setf (acceptor-process taskmaster)
160 (start-thread
161 taskmaster
162 (lambda () (accept-connections (taskmaster-acceptor taskmaster)))
163 :name (format nil "hunchentoot-listener-~A:~A"
164 (or (acceptor-address (taskmaster-acceptor taskmaster)) "*")
165 (acceptor-port (taskmaster-acceptor taskmaster))))))
166
167
168 ;; You might think it would be nice to provide a taskmaster that takes
169 ;; threads out of a thread pool. There are two things to consider:
170 ;; - On a 2010-ish Linux box, thread creation takes less than 250 microseconds.
171 ;; - Bordeaux Threads doesn't provide a way to "reset" and restart a thread,
172 ;; and it's not clear how many Lisp implementations can do this.
173 ;; If you're still interested, use the quux-hunchentoot extension to hunchentoot.
174
175 (defclass one-thread-per-connection-taskmaster (multi-threaded-taskmaster)
176 (;; Support for bounding the number of threads we'll create
177 (max-thread-count
178 :type (or integer null)
179 :initarg :max-thread-count
180 :initform nil
181 :accessor taskmaster-max-thread-count
182 :documentation
183 "The maximum number of request threads this taskmaster will simultaneously
184 run before refusing or queueing new connections requests. If the value
185 is null, then there is no limit.")
186 (thread-count
187 :type integer
188 :initform 0
189 :accessor taskmaster-thread-count
190 :documentation
191 "The number of taskmaster processing threads currently running.")
192 (thread-count-lock
193 :initform (make-lock "taskmaster-thread-count")
194 :reader taskmaster-thread-count-lock
195 :documentation
196 "In the absence of 'atomic-incf', we need this to atomically
197 increment and decrement the request count.")
198 (max-accept-count
199 :type (or integer null)
200 :initarg :max-accept-count
201 :initform nil
202 :accessor taskmaster-max-accept-count
203 :documentation
204 "The maximum number of connections this taskmaster will accept before refusing
205 new connections. If supplied, this must be greater than MAX-THREAD-COUNT.
206 The number of queued requests is the difference between MAX-ACCEPT-COUNT
207 and MAX-THREAD-COUNT.")
208 (accept-count
209 :type integer
210 :initform 0
211 :accessor taskmaster-accept-count
212 :documentation
213 "The number of connection currently accepted by the taskmaster. These
214 connections are not ensured to be processed, thay may be waiting for an
215 empty processing slot or rejected because the load is too heavy.")
216 (accept-count-lock
217 :initform (make-lock "taskmaster-accept-count")
218 :reader taskmaster-accept-count-lock
219 :documentation
220 "In the absence of 'atomic-incf', we need this to atomically
221 increment and decrement the accept count.")
222 (wait-queue
223 :initform (make-condition-variable)
224 :reader taskmaster-wait-queue
225 :documentation
226 "A queue that we use to wait for a free connection.")
227 (wait-lock
228 :initform (make-lock "taskmaster-thread-lock")
229 :reader taskmaster-wait-lock
230 :documentation
231 "The lock for the connection wait queue.")
232 (worker-thread-name-format
233 :type (or string null)
234 :initarg :worker-thread-name-format
235 :initform "hunchentoot-worker-~A"
236 :accessor taskmaster-worker-thread-name-format))
237 (:default-initargs
238 :max-thread-count *default-max-thread-count*
239 :max-accept-count *default-max-accept-count*)
240 (:documentation "A taskmaster that starts one thread for listening
241 to incoming requests and one new thread for each incoming connection.
242
243 If MAX-THREAD-COUNT is null, a new thread will always be created for
244 each request.
245
246 If MAX-THREAD-COUNT is supplied, the number of request threads is
247 limited to that. Furthermore, if MAX-ACCEPT-COUNT is not supplied, an
248 HTTP 503 will be sent if the thread limit is exceeded. Otherwise, if
249 MAX-ACCEPT-COUNT is supplied, it must be greater than MAX-THREAD-COUNT;
250 in this case, requests are accepted up to MAX-ACCEPT-COUNT, and only
251 then is HTTP 503 sent.
252
253 It is important to note that MAX-ACCEPT-COUNT and the HTTP 503 behavior
254 described above is racing with the acceptor listen backlog. If we are receiving
255 requests faster than threads can be spawned and 503 sent, the requests will be
256 silently rejected by the kernel.
257
258 In a load-balanced environment with multiple Hunchentoot servers, it's
259 reasonable to provide MAX-THREAD-COUNT but leave MAX-ACCEPT-COUNT null.
260 This will immediately result in HTTP 503 when one server is out of
261 resources, so the load balancer can try to find another server.
262
263 In an environment with a single Hunchentoot server, it's reasonable
264 to provide both MAX-THREAD-COUNT and a somewhat larger value for
265 MAX-ACCEPT-COUNT. This will cause a server that's almost out of
266 resources to wait a bit; if the server is completely out of resources,
267 then the reply will be HTTP 503.
268
269 This is the default taskmaster implementation for multi-threaded Lisp
270 implementations."))
271
272 (defmethod initialize-instance :after ((taskmaster one-thread-per-connection-taskmaster) &rest init-args)
273 "Ensure the if MAX-ACCEPT-COUNT is supplied, that it is greater than MAX-THREAD-COUNT."
274 (declare (ignore init-args))
275 (when (taskmaster-max-accept-count taskmaster)
276 (unless (taskmaster-max-thread-count taskmaster)
277 (parameter-error "MAX-THREAD-COUNT must be supplied if MAX-ACCEPT-COUNT is supplied"))
278 (unless (> (taskmaster-max-accept-count taskmaster) (taskmaster-max-thread-count taskmaster))
279 (parameter-error "MAX-ACCEPT-COUNT must be greater than MAX-THREAD-COUNT"))))
280
281 (defmethod increment-taskmaster-accept-count ((taskmaster one-thread-per-connection-taskmaster))
282 (when (taskmaster-max-accept-count taskmaster)
283 (with-lock-held ((taskmaster-accept-count-lock taskmaster))
284 (incf (taskmaster-accept-count taskmaster)))))
285
286 (defmethod decrement-taskmaster-accept-count ((taskmaster one-thread-per-connection-taskmaster))
287 (when (taskmaster-max-accept-count taskmaster)
288 (with-lock-held ((taskmaster-accept-count-lock taskmaster))
289 (decf (taskmaster-accept-count taskmaster)))))
290
291 (defmethod increment-taskmaster-thread-count ((taskmaster one-thread-per-connection-taskmaster))
292 (when (taskmaster-max-thread-count taskmaster)
293 (with-lock-held ((taskmaster-thread-count-lock taskmaster))
294 (incf (taskmaster-thread-count taskmaster)))))
295
296 (defmethod decrement-taskmaster-thread-count ((taskmaster one-thread-per-connection-taskmaster))
297 (when (taskmaster-max-thread-count taskmaster)
298 (prog1
299 (with-lock-held ((taskmaster-thread-count-lock taskmaster))
300 (decf (taskmaster-thread-count taskmaster))
301 (decrement-taskmaster-accept-count taskmaster))
302 (when (and (taskmaster-max-accept-count taskmaster)
303 (< (taskmaster-thread-count taskmaster) (taskmaster-max-accept-count taskmaster)))
304 (note-free-connection taskmaster)))))
305
306 (defmethod note-free-connection ((taskmaster one-thread-per-connection-taskmaster))
307 "Note that a connection has been freed up"
308 (with-lock-held ((taskmaster-wait-lock taskmaster))
309 (condition-variable-signal (taskmaster-wait-queue taskmaster))))
310
311 (defmethod wait-for-free-connection ((taskmaster one-thread-per-connection-taskmaster))
312 "Wait for a connection to be freed up"
313 (with-lock-held ((taskmaster-wait-lock taskmaster))
314 (loop until (< (taskmaster-thread-count taskmaster) (taskmaster-max-thread-count taskmaster))
315 do (condition-variable-wait (taskmaster-wait-queue taskmaster) (taskmaster-wait-lock taskmaster)))))
316
317 (defmethod too-many-taskmaster-requests ((taskmaster one-thread-per-connection-taskmaster) socket)
318 (declare (ignore socket))
319 (acceptor-log-message (taskmaster-acceptor taskmaster)
320 :warning "Can't handle a new request, too many request threads already"))
321
322 (defmethod create-request-handler-thread ((taskmaster one-thread-per-connection-taskmaster) socket)
323 "Create a thread for handling a single request"
324 ;; we are handling all conditions here as we want to make sure that
325 ;; the acceptor process never crashes while trying to create a
326 ;; worker thread; one such problem exists in
327 ;; GET-PEER-ADDRESS-AND-PORT which can signal socket conditions on
328 ;; some platforms in certain situations.
329 (handler-case*
330 (start-thread
331 taskmaster
332 (lambda () (handle-incoming-connection% taskmaster socket))
333 :name (format nil (taskmaster-worker-thread-name-format taskmaster) (client-as-string socket)))
334 (error (cond)
335 ;; need to bind *ACCEPTOR* so that LOG-MESSAGE* can do its work.
336 (let ((*acceptor* (taskmaster-acceptor taskmaster)))
337 (ignore-errors
338 (close (make-socket-stream socket *acceptor*) :abort t))
339 (log-message* *lisp-errors-log-level*
340 "Error while creating worker thread for new incoming connection: ~A" cond)))))
341
342 ;;; usocket implementation
343
344 #-:lispworks
345 (defmethod shutdown ((taskmaster taskmaster))
346 taskmaster)
347
348 #-:lispworks
349 (defmethod shutdown ((taskmaster one-thread-per-connection-taskmaster))
350 ;; just wait until the acceptor process has finished, then return
351 (bt:join-thread (acceptor-process taskmaster))
352 taskmaster)
353
354 #-:lispworks
355 (defmethod handle-incoming-connection ((taskmaster one-thread-per-connection-taskmaster) socket)
356 (create-request-handler-thread taskmaster socket))
357
358 #-lispworks
359 (defmethod handle-incoming-connection% ((taskmaster one-thread-per-connection-taskmaster) socket)
360 ;; Here's the idea, with the stipulations given in ONE-THREAD-PER-CONNECTION-TASKMASTER
361 ;; - If MAX-THREAD-COUNT is null, just start a taskmaster
362 ;; - If the connection count will exceed MAX-ACCEPT-COUNT or if MAX-ACCEPT-COUNT
363 ;; is null and the connection count will exceed MAX-THREAD-COUNT,
364 ;; return an HTTP 503 error to the client
365 ;; - Otherwise if we're between MAX-THREAD-COUNT and MAX-ACCEPT-COUNT,
366 ;; wait until the connection count drops, then handle the request
367 ;; - Otherwise, increment THREAD-COUNT and start a taskmaster
368 (increment-taskmaster-accept-count taskmaster)
369 (flet ((process-connection% (acceptor socket)
370 (increment-taskmaster-thread-count taskmaster)
371 (unwind-protect
372 (process-connection acceptor socket)
373 (decrement-taskmaster-thread-count taskmaster))))
374 (cond ((null (taskmaster-max-thread-count taskmaster))
375 ;; No limit on number of requests, just start a taskmaster
376 (process-connection (taskmaster-acceptor taskmaster) socket))
377 ((if (taskmaster-max-accept-count taskmaster)
378 (>= (taskmaster-accept-count taskmaster) (taskmaster-max-accept-count taskmaster))
379 (>= (taskmaster-thread-count taskmaster) (taskmaster-max-thread-count taskmaster)))
380 ;; Send HTTP 503 to indicate that we can't handle the request right now
381 (too-many-taskmaster-requests taskmaster socket)
382 (send-service-unavailable-reply taskmaster socket))
383 ((and (taskmaster-max-accept-count taskmaster)
384 (>= (taskmaster-thread-count taskmaster) (taskmaster-max-thread-count taskmaster)))
385 ;; Wait for a request to finish, then carry on
386 (wait-for-free-connection taskmaster)
387 (process-connection% (taskmaster-acceptor taskmaster) socket))
388 (t
389 ;; We're within both limits, just start a taskmaster
390 (process-connection% (taskmaster-acceptor taskmaster) socket)))))
391
392 (defun send-service-unavailable-reply (taskmaster socket)
393 "A helper function to send out a quick error reply, before any state
394 is set up via PROCESS-REQUEST."
395 (let* ((acceptor (taskmaster-acceptor taskmaster))
396 (*acceptor* acceptor)
397 (*hunchentoot-stream* (make-socket-stream socket acceptor)))
398 (unwind-protect
399 (with-conditions-caught-and-logged ()
400 (with-mapped-conditions ()
401 (let* ((*hunchentoot-stream* (initialize-connection-stream acceptor *hunchentoot-stream*))
402 (*reply* (make-instance (acceptor-reply-class acceptor)))
403 (*request* (acceptor-make-request acceptor socket)))
404 (with-character-stream-semantics
405 (send-response acceptor
406 (flex:make-flexi-stream *hunchentoot-stream* :external-format :iso-8859-1)
407 +http-service-unavailable+
408 :content (acceptor-status-message acceptor +http-service-unavailable+))))))
409 (decrement-taskmaster-accept-count taskmaster)
410 (when *hunchentoot-stream*
411 (ignore-errors*
412 (finish-output *hunchentoot-stream*))
413 (ignore-errors*
414 (close *hunchentoot-stream* :abort t))))))
415
416 (defun client-as-string (socket)
417 "A helper function which returns the client's address and port as a
418 string and tries to act robustly in the presence of network problems."
419 #-:lispworks
420 (let ((address (usocket:get-peer-address socket))
421 (port (usocket:get-peer-port socket)))
422 (when (and address port)
423 (format nil "~A:~A"
424 (usocket:vector-quad-to-dotted-quad address)
425 port)))
426 #+:lispworks
427 (multiple-value-bind (address port)
428 (comm:get-socket-peer-address socket)
429 (when (and address port)
430 (format nil "~A:~A"
431 (comm:ip-address-string address)
432 port))))
433
434 ;; LispWorks implementation
435
436 #+:lispworks
437 (defmethod shutdown ((taskmaster taskmaster))
438 (when-let (process (acceptor-process (taskmaster-acceptor taskmaster)))
439 ;; kill the main acceptor process, see LW documentation for
440 ;; COMM:START-UP-SERVER
441 (mp:process-kill process))
442 taskmaster)
443
444 #+:lispworks
445 (defmethod handle-incoming-connection ((taskmaster one-thread-per-connection-taskmaster) socket)
446 (incf *worker-counter*)
447 ;; check if we need to perform a global GC
448 (when (and *cleanup-interval*
449 (zerop (mod *worker-counter* *cleanup-interval*)))
450 (when *cleanup-function*
451 (funcall *cleanup-function*)))
452 (create-request-handler-thread taskmaster socket))
453
454 #+:lispworks
455 (defmethod handle-incoming-connection% ((taskmaster one-thread-per-connection-taskmaster) socket)
456 (increment-taskmaster-accept-count taskmaster)
457 (flet ((process-connection% (acceptor socket)
458 (increment-taskmaster-thread-count taskmaster)
459 (unwind-protect
460 (process-connection acceptor socket)
461 (decrement-taskmaster-thread-count taskmaster))))
462 (cond ((null (taskmaster-max-thread-count taskmaster))
463 ;; No limit on number of requests, just start a taskmaster
464 (process-connection (taskmaster-acceptor taskmaster) socket))
465 ((if (taskmaster-max-accept-count taskmaster)
466 (>= (taskmaster-accept-count taskmaster) (taskmaster-max-accept-count taskmaster))
467 (>= (taskmaster-thread-count taskmaster) (taskmaster-max-thread-count taskmaster)))
468 ;; Send HTTP 503 to indicate that we can't handle the request right now
469 (too-many-taskmaster-requests taskmaster socket)
470 (send-service-unavailable-reply taskmaster socket))
471 ((and (taskmaster-max-accept-count taskmaster)
472 (>= (taskmaster-thread-count taskmaster) (taskmaster-max-thread-count taskmaster)))
473 ;; Lispworks doesn't have condition variables, so punt
474 (too-many-taskmaster-requests taskmaster socket)
475 (send-service-unavailable-reply taskmaster socket))
476 (t
477 ;; We're within both limits, just start a taskmaster
478 (process-connection% (taskmaster-acceptor taskmaster) socket)))))
479