Opened 5 years ago

Last modified 5 years ago

#1314 new defect

Stress test failure for sockets

Reported by: jlawrence Owned by:
Priority: normal Milestone:
Component: Runtime (threads, GC) Version: trunk
Keywords: Cc:


;;; Multiple clients attempt to connect to a server simultaneously.
;;; The server is single-threaded, serving one connection at a time.

;;; For each +ping+ message the server receives, it sends back a
;;; +pong+ message. When the server receives an +end-ping+
;;; message--meaning the client has stopped sending--the server
;;; connection is closed. A new connection is then created to serve
;;; the next client.

;;; When all clients have finished, the +end-server+ message is sent;
;;; the server exits upon seeing it.

(defconstant +ping+ 44)
(defconstant +pong+ 55)
(defconstant +end-ping+ 66)
(defconstant +end-server+ 77)

(defun server (host port ready out)
  (with-open-stream (server (ccl:make-socket :connect :passive
                                             :local-host host
                                             :local-port port
                                             :reuse-address t
                                             :format :binary))
    (ccl:signal-semaphore ready)
    (loop (with-open-stream (stream (ccl:accept-connection server))
            (loop (let ((from-client (read-byte stream)))
                    (assert (or (= +ping+ from-client)
                                (= +end-server+ from-client)
                                (= +end-ping+ from-client)))
                    (write-byte +pong+ stream)
                    (finish-output stream)
                    (write-char #\. out)
                    (finish-output out)
                    (when (= +end-ping+ from-client)
                    (when (= +end-server+ from-client)
                      (return-from server))))))))

(defmacro with-client ((stream host port) &body body)
  `(with-open-stream (,stream (ccl:make-socket :remote-host ,host
                                               :remote-port ,port
                                               :format :binary))

(defun test (host port client-count message-count)
  (let ((ready (ccl:make-semaphore)))
    (ccl:process-run-function "server" #'server
                              host port ready *standard-output*)
    (ccl:wait-on-semaphore ready))
  (flet ((task ()
           (with-client (stream host port)
             (loop for count from 1 to message-count
                   do (write-byte (if (= count message-count)
                  (finish-output stream)
                  (assert (= +pong+ (read-byte stream)))))))
    (mapc #'ccl:join-process
          (loop repeat client-count
                collect (ccl:process-run-function "client" #'task))))
  (with-client (stream host port)
    (write-byte +end-server+ stream)
    (finish-output stream)
    (assert (= +pong+ (read-byte stream)))))

(defun run (&optional (client-count 100) (message-count 100))
  (loop (loop for port from 20000 below 64000
              do (test "localhost" port client-count message-count))))

32-bit Linux x86.

RUN will eventually (within a minute) cause "Connection reset by peer" errors. This happens on ccl-1.10 and trunk, however the former has a much longer time (on average) until error.

Change History (2)

comment:1 Changed 5 years ago by jlawrence

I forgot to mention ccl-1.11, which has the same problem.

comment:2 Changed 5 years ago by jlawrence

Adding :connect-timeout 900000 :input-timeout 900000 :output-timeout 900000 to the ccl:make-socket calls causes "Connection timed out" errors to be signaled instead, though the errors happen within minutes, long before the timeout given.

Note: See TracTickets for help on using tickets.