PoC hunchentoot/usocket is exhausting our available file descriptors

usocket-debug.lisp

;; v1 ::
;; neither https://github.com/lemoinem/hunchentoot/issues/1
;; nor https://github.com/lemoinem/hunchentoot/issues/2
;; are fixed in this version.

(cl:in-package :cl-user)

(defpackage usocket-debug
  (:nicknames ud)
  (:shadow #:timeout)
  (:use #:cl #:usocket #:alexandria #:bordeaux-threads))

(in-package :ud)

(declaim (optimize debug))

(defvar *max-processing*)
(defvar *max-accepted*)
(defvar *timeout*)

(defvar *use-thread*)

(defvar *current-accepted*)
(defvar *wait-lock*)
(defvar *count-lock*)
(defvar *condition-variable-wait*)

(defun start (&key (port 8080) (timeout .5) (max-processing 100) (max-accepted nil max-accepted-supplied-p) (use-thread t))
  (with-server-socket (listener (socket-listen *wildcard-host* port :reuse-address t))
    (setf *use-thread* use-thread
          *timeout* timeout
          *current-accepted* 0
          *max-processing* max-processing
          *max-accepted* (if max-accepted-supplied-p
                             (or max-accepted *max-processing*) ;; If explicit nil: equals *max-processing*
                             (+ *max-processing* 20)) ;; else *max-processing* + 20
          *count-lock* (make-lock "cond-lock")
          *wait-lock* (make-lock "wait-lock")
          *condition-variable-wait* (make-condition-variable))
    (when (> *max-processing* *max-accepted*)
      (error "*max-accepted* must be greater than or equal to *max-processing*."))
    (loop
       (when (wait-for-input listener :ready-only t)
         (when-let (socket (handler-case (socket-accept listener)
                             (connection-aborted-error ())))
           (handle-incoming-connection socket))))))

(defun my-make-thread (function &key name)
  (if *use-thread*
      (make-thread function :name name)
      (funcall function)))

(defun handle-incoming-connection (socket)
  (cond ((not *use-thread*)
         (create-request-handler-thread socket))
        ((>= *current-accepted* *max-accepted*)
         (too-many-requests-not-closing-stream socket))
        ((>= *current-accepted* *max-processing*)
         (wait-for-free-connection)
         (increment-request-count)
         (create-request-handler-thread socket))
        (t
         (increment-request-count)
         (create-request-handler-thread socket))))

(defun create-request-handler-thread (socket)
  (handler-bind
      ((error (lambda (c)
                (decrement-request-count)
                (format t "Error while creating thread for connection: ~A~%" c)
                (return-from create-request-handler-thread))))
    (let ((name (format nil "Client thread ~A:~A~%"
                        (get-peer-address socket)
                        (get-peer-port socket))))
      (my-make-thread
       (lambda ()
         (unwind-protect
              (handler-bind
                  ((error
                    ;; abort if there's an error which isn't caught inside
                    (lambda (c)
                      (format t "Error while processing connection: ~A~%" c)))
                   (warning
                    ;; log all warnings which aren't caught inside
                    (lambda (c)
                      (format t "Warning while processing connection: ~A~%" c))))
                (with-mapped-conditions ()
                  (let ((stream (socket-stream socket)))
                    (unwind-protect
                         (progn
                           (sleep *timeout*)
                           (format stream "OK~%"))
                      (when stream
                        (close stream :abort t))))))
           (decrement-request-count)))
       :name name))))


(defun too-many-requests-not-closing-stream (socket)
  (format t "Too many connections~%")
  (format (socket-stream socket) "Too many connections~%"))

(defun too-many-requests (socket)
  (format t "Too many connections~%")
  (let ((stream (socket-stream socket)))
    (unwind-protect
         (format stream "Too many connections~%")
      (when stream
        (close stream :abort t)))))

(defun increment-request-count ()
  (with-lock-held (*count-lock*)
    (incf *current-accepted*)))

(defun decrement-request-count ()
  (prog1
      (with-lock-held (*count-lock*)
        (decf *current-accepted*))
    (when (< *current-accepted* *max-processing*)
      (note-free-connection))))

(defun note-free-connection ()
  (with-lock-held (*wait-lock*)
    (condition-notify *condition-variable-wait*)))

(defun wait-for-free-connection ()
  "Wait for a connection to be freed up"
  (with-lock-held (*wait-lock*)
    (loop until (< *current-accepted* *max-processing*)
       do (condition-wait *condition-variable-wait* *wait-lock*))))