(eval-when (:compile-toplevel :load-toplevel)
  (use-package :sb-thread)
  (use-package :sb-bsd-sockets))

(defvar *buffer-queue* (make-waitqueue))
(defvar *buffer-lock* (make-mutex :name "buffer lock"))

(defvar *buffer* ())

(defun read-buf ()
  (with-mutex (*buffer-lock*)
    (loop while (not *buffer*) do
         (condition-wait *buffer-queue* *buffer-lock*))
    (pop *buffer*)))

(defun write-buf (obj)
  (with-mutex (*buffer-lock*)
    (setf *buffer* (nconc *buffer* (list obj)))
    (condition-notify *buffer-queue*)))

(defmacro i-e (&body body)
  `(multiple-value-bind (value error)
       (ignore-errors ,@body)
     (when error
       (format t "ERR:~A~%" error)
       (force-output))
     (values value error)))

(defun accept-thread (server-socket)
  (unwind-protect
       (loop
          (handler-case
	      (let ((socket (socket-accept server-socket)))
                (cl-user::write-buf
                 (list
                  (socket-make-stream socket
                                      :input t :output t
                                      :element-type '(unsigned-byte 8)
                                      :auto-close t)
                  socket)))
	    (error (cond)
              (format t "accept: error ~s"  cond))))
    (i-e
      (socket-close server-socket))))

(defparameter *xxx-string* (format nil
                                   "HTTP/1.1 404 Not Found
Date: Thu, 31 Mar 2005 14:45:21 GMT
Server: Apache/1.3.33 (Debian GNU/Linux) mod_lisp/2.41
Connection: close
Content-Type: text/html; charset=iso-8859-1~a~a~a~a"
                                   #\return #\linefeed
                                   #\return #\linefeed))

(defparameter *xxx-byte-vec* (map '(vector (unsigned-byte 8))
                                  #'char-code *xxx-string*))

(declaim (notinline work))
(defun work (stream socket)
  (unwind-protect
       (i-e (write-sequence *xxx-byte-vec* stream))
    (i-e (socket-close socket))))

(defun worker-thread ()
  (loop
     (apply #'work (cl-user::read-buf))))

(defparameter *accept-thread* nil)
(defparameter *worker-threads* ())

(defun stop-server ()
  (i-e
    (when *accept-thread*
      (sb-thread:interrupt-thread *accept-thread* #'sb-ext:quit)
      (setq *accept-thread* nil)
      (sleep 1)))
  (dolist (worker *worker-threads*)
    (i-e
      (sb-thread:interrupt-thread worker #'sb-ext:quit))
    (setq *worker-threads* nil)))

(defun start-server ()
  (stop-server)
  (let ((server-socket (make-instance 'inet-socket :type :stream
                                      :protocol :tcp)))
    (setf (sockopt-reuse-address server-socket) t)
    (socket-bind server-socket #(0 0 0 0) 2002)
    (socket-listen server-socket 10)
    (setq *accept-thread*
          (sb-thread:make-thread #'(lambda () (accept-thread server-socket))))
    (dotimes (i 100)
      (push (sb-thread:make-thread #'worker-thread) *worker-threads*))))