(require 'sb-bsd-sockets)
(defparameter *server-side-socket* nil)
(defparameter *client-side-socket* nil)
;; The server accepts a connection and does not read from it.
(defun frozen-server ()
(let ((listen-sock (make-instance 'sb-bsd-sockets:inet-socket
:type :stream :protocol :tcp)))
(unwind-protect
(progn
(setf (sb-bsd-sockets:sockopt-reuse-address listen-sock) t)
(sb-bsd-sockets:socket-bind listen-sock '(127 0 0 1) 8080)
(sb-bsd-sockets:socket-listen listen-sock 1)
(format t "server listening...~%")
(setq *server-side-socket*
(sb-bsd-sockets:socket-accept listen-sock))
(format t "server accepted a connecton~%"))
(sb-bsd-sockets:socket-close listen-sock))))
(sb-thread:make-thread 'frozen-server
:name "test server")
;; Client side: connect to the server and
;; from within of with-deadline constantly write
;; to server. Gets blocked as
;; the server does not read, and deadline does not help.
(progn
(setq *client-side-socket*
(make-instance 'sb-bsd-sockets:inet-socket
:type :stream :protocol :tcp))
(sb-bsd-sockets:socket-connect *client-side-socket*
'(127 0 0 1) 8080)
(format t "connected to server~%")
(let ((stream (sb-bsd-sockets:socket-make-stream *client-side-socket*
:input t
:buffering :none
:output t))
(msg "0123456789")
(count 0))
(sb-sys:with-deadline (:seconds 2)
(loop
(dotimes (i 10000)
(write-string msg stream)
(incf count))
(finish-output stream)
(format t "~A bytes written by client~%" (* count (length msg)))))))
;;; cleanup
(ignore-errors (sb-bsd-sockets:socket-shutdown *server-side-socket* :direction :io))
;; this unblocks the client:
(ignore-errors (sb-bsd-sockets:socket-shutdown *client-side-socket* :direction :io))
;; BTW, the error signalled to client
;; depends on :buffering parameter of the stream:
;; - SB-SYS:DEADLINE-TIMEOUT in case of :buffering :full (the default)
;; - SB-INT:BROKEN-PIPE in case of :buffering :none