;; An attempt to rewrite connect-to-inet-socket in such a way that
;; connection attempts that take a long time will not be stuck in the
;; connect(2) system call preventing CMUCL from running other lisp
;; threads.
;;
;;
;; The strategy here is to put the socket in non-blocking mode, and
;; then call connect, which should immediately return.  Then there are
;; three cases to handle:
;;
;;   I.   The connect failed immediately.
;;   II.  The connect succeeded immediately.
;;   III. The connect returned without finishing.
;;
;; Cases I and II are simple enough, we just return the socket or
;; signal an error.
;;
;; In case III, we call system:wait-until-fd-is-usable to block just
;; the current thread until the socket is writeable (which signals
;; that the connect has finished, one way or the other).
;;
;; Once wait-until-fd-is-usable returns, we put the socket back into
;; blocking mode and try to determine whether the connect succeeded or
;; failed (and why it failed).  I used an approach described at
;; <http://cr.yp.to/docs/connect.html>, which is attributed to Douglas
;; C. Schmidt and Ken Keys.
;;
;; I first call getpeername, and if it returns 0 the connect
;; succeeded, otherwise it failed.  If it failed, I try to read a
;; single character from the socket.  I know it can't work, but it
;; should cause errno set to the real reason for the failure.
;;
;; If this works, and is robust, I don't see any reason for it not to
;; replace the connect-to-inet-socket from CMUCL.


(defun connect-to-inet-socket (host port &optional (kind :stream))
  "The host may be an address string or an IP address in host order."
  (let ((addr (if (stringp host)
		(host-entry-addr (or (lookup-host-entry host)
				     (error "Unknown host: ~S." host)))
                host))
        (socket (create-inet-socket kind)))
    (labels ((set-blocking (socket)
               (unix:unix-fcntl socket unix:f-setfl
                                (logior (unix:unix-fcntl socket unix:f-getfl 0)
                                        unix:fndelay)))
             (unset-blocking (socket)
               (unix:unix-fcntl socket unix:f-setfl
                                (logandc2 (unix:unix-fcntl socket unix:f-getfl 0)
                                          unix:fndelay)))
	     (dotted-quad (ipaddr)
	       (let ((naddr (htonl addr)))
		 (format nil "~D.~D.~D.~D"
			 (ldb (byte 8 0) naddr)
			 (ldb (byte 8 8) naddr)
			 (ldb (byte 8 16) naddr)
			 (ldb (byte 8 24) naddr))))
	     (connect-error (addr)
	       (error "Error connecting socket to [~A:~A]: ~A"
		      addr port (unix:get-unix-error-msg))))
      (set-blocking socket)
      (with-alien ((sockaddr inet-sockaddr)
                   (length (alien:array unsigned 1)))
        (setf (slot sockaddr 'family) af-inet)
        (setf (slot sockaddr 'port) (htons port))
        (setf (slot sockaddr 'addr) (htonl addr))
        (let ((retval (unix:unix-connect socket
                                         (alien-sap sockaddr)
                                         (alien-size inet-sockaddr :bytes))))
          (cond ((< retval -1)
		 ;; connect failed.
                 (unix:unix-close socket)
                 (connect-error (if (stringp host) host (dotted-quad addr))))
		((= retval -1)
		 ;; connect is in progress.
                 (system:wait-until-fd-usable socket :output)
                 (unset-blocking socket)
		 ;; OK, it's done, check whether it worked.
                 (when (minusp
			(unix:unix-getpeername socket (alien-sap sockaddr)
					       (alien-sap length)))
		   (unix:unix-close socket)
		   ;; It didn't, so let's find out why.
                   (unix:unix-read socket (alien-sap length) 1)
		   (connect-error (if (stringp host) host (dotted-quad addr))))
                 socket)
                (T
		 ;; connect succeeded.
                 (unset-blocking socket)
                 socket)))))))