;;;; Methods, classes, functions for sockets. Protocol-specific stuff
;;;; is deferred to inet.lisp, unix.lisp, etc
-#|| <h2>SOCKETs</h2>
-
-|#
-
(eval-when (:load-toplevel :compile-toplevel :execute)
+
(defclass socket ()
((file-descriptor :initarg :descriptor
- :reader socket-file-descriptor)
- (family :initform (error "No socket family") :reader socket-family)
- (protocol :initarg :protocol :reader socket-protocol)
- (type :initarg :type :reader socket-type)
- (stream))))
-
+ :reader socket-file-descriptor)
+ (family :initform (error "No socket family")
+ :reader socket-family)
+ (protocol :initarg :protocol
+ :reader socket-protocol
+ :documentation "Protocol used by the socket. If a
+keyword, the symbol-name of the keyword will be passed to
+GET-PROTOCOL-BY-NAME downcased, and the returned value used as
+protocol. Other values are used as-is.")
+ (type :initarg :type
+ :reader socket-type
+ :documentation "Type of the socket: :STREAM or :DATAGRAM.")
+ (stream))
+ (:documentation "Common base class of all sockets, not meant to be
+directly instantiated.")))
+
(defmethod print-object ((object socket) stream)
(print-unreadable-object (object stream :type t :identity t)
(princ "descriptor " stream)
(defmethod shared-initialize :after ((socket socket) slot-names
- &key protocol type
- &allow-other-keys)
+ &key protocol type
+ &allow-other-keys)
(let* ((proto-num
- (cond ((and protocol (keywordp protocol))
- (get-protocol-by-name (string-downcase (symbol-name protocol))))
- (protocol protocol)
- (t 0)))
- (fd (or (and (slot-boundp socket 'file-descriptor)
- (socket-file-descriptor socket))
- (sockint::socket (socket-family socket)
- (ecase type
- ((:datagram) sockint::sock-dgram)
- ((:stream) sockint::sock-stream))
- proto-num))))
+ (cond ((and protocol (keywordp protocol))
+ (get-protocol-by-name (string-downcase (symbol-name protocol))))
+ (protocol protocol)
+ (t 0)))
+ (fd (or (and (slot-boundp socket 'file-descriptor)
+ (socket-file-descriptor socket))
+ (sockint::socket (socket-family socket)
+ (ecase type
+ ((:datagram) sockint::sock-dgram)
+ ((:stream) sockint::sock-stream))
+ proto-num))))
(if (= fd -1) (socket-error "socket"))
(setf (slot-value socket 'file-descriptor) fd
- (slot-value socket 'protocol) proto-num
- (slot-value socket 'type) type)
+ (slot-value socket 'protocol) proto-num
+ (slot-value socket 'type) type)
(sb-ext:finalize socket (lambda () (sockint::close fd)))))
\f
+(defgeneric make-sockaddr-for (socket &optional sockaddr &rest address)
+ (:documentation "Return a Socket Address object suitable for use with SOCKET.
+When SOCKADDR is passed, it is used instead of a new object."))
+
+(defgeneric free-sockaddr-for (socket sockaddr)
+ (:documentation "Deallocate a Socket Address object that was
+created for SOCKET."))
+
+(defmacro with-sockaddr-for ((socket sockaddr &optional sockaddr-args) &body body)
+ `(let ((,sockaddr (apply #'make-sockaddr-for ,socket nil ,sockaddr-args)))
+ (unwind-protect (progn ,@body)
+ (free-sockaddr-for ,socket ,sockaddr))))
+
;; we deliberately redesign the "bind" interface: instead of passing a
;; sockaddr_something as second arg, we pass the elements of one as
;; multiple arguments.
-(defgeneric socket-bind (socket &rest address))
+(defgeneric socket-bind (socket &rest address)
+ (:documentation "Bind SOCKET to ADDRESS, which may vary according to
+socket family. For the INET family, pass ADDRESS and PORT as two
+arguments; for FILE address family sockets, pass the filename string.
+See also bind(2)"))
+
(defmethod socket-bind ((socket socket)
&rest address)
- "Bind SOCKET to ADDRESS, which may vary according to socket family. For
-the INET family, pass ADDRESS and PORT as two arguments; for FILE address
-family sockets, pass the filename string. See also bind(2)"
- (let ((sockaddr (apply #'make-sockaddr-for socket nil address)))
- (if (= (sb-sys:without-gcing
- (sockint::bind (socket-file-descriptor socket)
- (sockint::array-data-address sockaddr)
- (size-of-sockaddr socket)))
+ (with-sockaddr-for (socket sockaddr address)
+ (if (= (sockint::bind (socket-file-descriptor socket)
+ sockaddr
+ (size-of-sockaddr socket))
-1)
(socket-error "bind"))))
\f
+(defgeneric socket-accept (socket)
+ (:documentation "Perform the accept(2) call, returning a
+newly-created connected socket and the peer address as multiple
+values"))
+
(defmethod socket-accept ((socket socket))
- "Perform the accept(2) call, returning a newly-created connected socket
-and the peer address as multiple values"
- (let* ((sockaddr (make-sockaddr-for socket))
- (fd (sb-sys:without-gcing
- (sockint::accept (socket-file-descriptor socket)
- (sockint::array-data-address sockaddr)
- (size-of-sockaddr socket)))))
- (apply #'values
- (if (= fd -1)
- (socket-error "accept")
- (let ((s (make-instance (class-of socket)
- :type (socket-type socket)
- :protocol (socket-protocol socket)
- :descriptor fd)))
- (sb-ext:finalize s (lambda () (sockint::close fd)))))
- (multiple-value-list (bits-of-sockaddr socket sockaddr)))))
-
-(defgeneric socket-connect (socket &rest address))
+ (with-sockaddr-for (socket sockaddr)
+ (let ((fd (sockint::accept (socket-file-descriptor socket)
+ sockaddr
+ (size-of-sockaddr socket))))
+ (cond
+ ((and (= fd -1)
+ (member (sb-unix::get-errno)
+ (list sockint::EAGAIN sockint::EINTR)))
+ nil)
+ ((= fd -1) (socket-error "accept"))
+ (t (apply #'values
+ (let ((s (make-instance (class-of socket)
+ :type (socket-type socket)
+ :protocol (socket-protocol socket)
+ :descriptor fd)))
+ (sb-ext:finalize s (lambda () (sockint::close fd))))
+ (multiple-value-list (bits-of-sockaddr socket sockaddr))))))))
+
+(defgeneric socket-connect (socket &rest address)
+ (:documentation "Perform the connect(2) call to connect SOCKET to a
+ remote PEER. No useful return value."))
+
(defmethod socket-connect ((socket socket) &rest peer)
- "Perform the connect(2) call to connect SOCKET to a remote PEER. No useful return value"
- (let* ((sockaddr (apply #'make-sockaddr-for socket nil peer)))
- (if (= (sb-sys:without-gcing
- (sockint::connect (socket-file-descriptor socket)
- (sockint::array-data-address sockaddr)
- (size-of-sockaddr socket)))
- -1)
- (socket-error "connect") )))
+ (with-sockaddr-for (socket sockaddr peer)
+ (if (= (sockint::connect (socket-file-descriptor socket)
+ sockaddr
+ (size-of-sockaddr socket))
+ -1)
+ (socket-error "connect"))))
+
+(defgeneric socket-peername (socket)
+ (:documentation "Return the socket's peer; depending on the address
+ family this may return multiple values"))
(defmethod socket-peername ((socket socket))
- "Return the socket's peer; depending on the address family this may return multiple values"
- (let* ((sockaddr (make-sockaddr-for socket)))
- (when (= (sb-sys:without-gcing
- (sockint::getpeername (socket-file-descriptor socket)
- (sockint::array-data-address sockaddr)
- (size-of-sockaddr socket)))
- -1)
+ (with-sockaddr-for (socket sockaddr)
+ (when (= (sockint::getpeername (socket-file-descriptor socket)
+ sockaddr
+ (size-of-sockaddr socket))
+ -1)
(socket-error "getpeername"))
(bits-of-sockaddr socket sockaddr)))
+(defgeneric socket-name (socket)
+ (:documentation "Return the address (as vector of bytes) and port
+ that the socket is bound to, as multiple values."))
+
(defmethod socket-name ((socket socket))
- "Return the address (as vector of bytes) and port that the socket is bound to, as multiple values"
- (let* ((sockaddr (make-sockaddr-for socket)))
- (when (= (sb-sys:without-gcing
- (sockint::getsockname (socket-file-descriptor socket)
- (sockint::array-data-address sockaddr)
- (size-of-sockaddr socket)))
- -1)
+ (with-sockaddr-for (socket sockaddr)
+ (when (= (sockint::getsockname (socket-file-descriptor socket)
+ sockaddr
+ (size-of-sockaddr socket))
+ -1)
(socket-error "getsockname"))
(bits-of-sockaddr socket sockaddr)))
;;; allows us to read from an unconnected socket into a buffer, and
;;; to learn who the sender of the packet was
-(defmethod socket-receive ((socket socket) buffer length
- &key
- oob peek waitall
- (element-type 'character))
- "Read LENGTH octets from SOCKET into BUFFER (or a freshly-consed buffer if
+(defgeneric socket-receive (socket buffer length
+ &key
+ oob peek waitall element-type)
+ (:documentation "Read LENGTH octets from SOCKET into BUFFER (or a freshly-consed buffer if
NIL), using recvfrom(2). If LENGTH is NIL, the length of BUFFER is
used, so at least one of these two arguments must be non-NIL. If
BUFFER is supplied, it had better be of an element type one octet wide.
Returns the buffer, its length, and the address of the peer
that sent it, as multiple values. On datagram sockets, sets MSG_TRUNC
so that the actual packet length is returned even if the buffer was too
-small"
- (let ((flags
- (logior (if oob sockint::MSG-OOB 0)
- (if peek sockint::MSG-PEEK 0)
- (if waitall sockint::MSG-WAITALL 0)
- sockint::MSG-NOSIGNAL ;don't send us SIGPIPE
- (if (eql (socket-type socket) :datagram)
- sockint::msg-TRUNC 0)))
- (sockaddr (make-sockaddr-for socket)))
- (unless (or buffer length)
- (error "Must supply at least one of BUFFER or LENGTH"))
- (unless buffer
- (setf buffer (make-array length :element-type element-type)))
- (sb-alien:with-alien ((sa-len (array (sb-alien:unsigned 32) 2)))
- (setf (sb-alien:deref sa-len 0) (size-of-sockaddr socket))
- (sb-sys:without-gcing
- (let ((len
- (sockint::recvfrom (socket-file-descriptor socket)
- (sockint::array-data-address buffer)
- (or length (length buffer))
- flags
- (sockint::array-data-address sockaddr)
- (sb-alien:cast sa-len (* integer)))))
- (when (= len -1) (socket-error "recvfrom"))
- (apply #'values buffer len (multiple-value-list
- (bits-of-sockaddr socket sockaddr))))))))
-
+small"))
+(defmethod socket-receive ((socket socket) buffer length
+ &key
+ oob peek waitall
+ (element-type 'character))
+ (with-sockaddr-for (socket sockaddr)
+ (let ((flags
+ (logior (if oob sockint::MSG-OOB 0)
+ (if peek sockint::MSG-PEEK 0)
+ (if waitall sockint::MSG-WAITALL 0)
+ #+linux sockint::MSG-NOSIGNAL ;don't send us SIGPIPE
+ (if (eql (socket-type socket) :datagram)
+ sockint::msg-TRUNC 0))))
+ (unless (or buffer length)
+ (error "Must supply at least one of BUFFER or LENGTH"))
+ (unless length
+ (setf length (length buffer)))
+ (when buffer (setf element-type (array-element-type buffer)))
+ (unless (or (subtypep element-type 'character)
+ (subtypep element-type 'integer))
+ (error "Buffer element-type must be either a character or an integer subtype."))
+ (unless buffer
+ (setf buffer (make-array length :element-type element-type)))
+ ;; really big FIXME: This whole copy-buffer thing is broken.
+ ;; doesn't support characters more than 8 bits wide, or integer
+ ;; types that aren't (unsigned-byte 8).
+ (let ((copy-buffer (sb-alien:make-alien (array (sb-alien:unsigned 8) 1) length)))
+ (unwind-protect
+ (sb-alien:with-alien ((sa-len sockint::socklen-t (size-of-sockaddr socket)))
+ (let ((len
+ (sockint::recvfrom (socket-file-descriptor socket)
+ copy-buffer
+ length
+ flags
+ sockaddr
+ (sb-alien:addr sa-len))))
+ (cond
+ ((and (= len -1)
+ (member (sb-unix::get-errno)
+ (list sockint::EAGAIN sockint::EINTR)))
+ nil)
+ ((= len -1) (socket-error "recvfrom"))
+ (t (loop for i from 0 below len
+ do (setf (elt buffer i)
+ (cond
+ ((or (eql element-type 'character) (eql element-type 'base-char))
+ (code-char (sb-alien:deref (sb-alien:deref copy-buffer) i)))
+ (t (sb-alien:deref (sb-alien:deref copy-buffer) i)))))
+ (apply #'values buffer len (multiple-value-list
+ (bits-of-sockaddr socket sockaddr)))))))
+ (sb-alien:free-alien copy-buffer))))))
+
+(defmacro with-vector-sap ((name vector) &body body)
+ `(sb-sys:with-pinned-objects (,vector)
+ (let ((,name (sb-sys:vector-sap ,vector)))
+ ,@body)))
+
+(defgeneric socket-send (socket buffer length
+ &key
+ address
+ external-format
+ oob eor dontroute dontwait nosignal
+ #+linux confirm #+linux more)
+ (:documentation
+ "Send LENGTH octets from BUFFER into SOCKET, using sendto(2). If BUFFER
+is a string, it will converted to octets according to EXTERNAL-FORMAT. If
+LENGTH is NIL, the length of the octet buffer is used. The format of ADDRESS
+depends on the socket type (for example for INET domain sockets it would
+be a list of an IP address and a port). If no socket address is provided,
+send(2) will be called instead. Returns the number of octets written."))
+
+(defmethod socket-send ((socket socket) buffer length
+ &key
+ address
+ (external-format :default)
+ oob eor dontroute dontwait nosignal
+ #+linux confirm #+linux more)
+ (let* ((flags
+ (logior (if oob sockint::MSG-OOB 0)
+ (if eor sockint::MSG-EOR 0)
+ (if dontroute sockint::MSG-DONTROUTE 0)
+ (if dontwait sockint::MSG-DONTWAIT 0)
+ (if nosignal sockint::MSG-NOSIGNAL 0)
+ #+linux (if confirm sockint::MSG-CONFIRM 0)
+ #+linux (if more sockint::MSG-MORE 0)))
+ (buffer (etypecase buffer
+ (string
+ (sb-ext:string-to-octets buffer
+ :external-format external-format
+ :null-terminate nil))
+ ((simple-array (unsigned-byte 8))
+ buffer)
+ ((array (unsigned-byte 8))
+ (make-array (length buffer)
+ :element-type '(unsigned-byte 8)
+ :initial-contents buffer))))
+ (len (with-vector-sap (buffer-sap buffer)
+ (unless length
+ (setf length (length buffer)))
+ (if address
+ (with-sockaddr-for (socket sockaddr address)
+ (sb-alien:with-alien ((sa-len sockint::socklen-t
+ (size-of-sockaddr socket)))
+ (sockint::sendto (socket-file-descriptor socket)
+ buffer-sap
+ length
+ flags
+ sockaddr
+ sa-len)))
+ (sockint::send (socket-file-descriptor socket)
+ buffer-sap
+ length
+ flags)))))
+ (cond
+ ((and (= len -1)
+ (member (sb-unix::get-errno)
+ (list sockint::EAGAIN sockint::EINTR)))
+ nil)
+ ((= len -1)
+ (socket-error "sendto"))
+ (t len))))
+
+(defgeneric socket-listen (socket backlog)
+ (:documentation "Mark SOCKET as willing to accept incoming connections. BACKLOG
+defines the maximum length that the queue of pending connections may
+grow to before new connection attempts are refused. See also listen(2)"))
(defmethod socket-listen ((socket socket) backlog)
- "Mark SOCKET as willing to accept incoming connections. BACKLOG
-defines the maximum length that the queue of pending connections may
-grow to before new connection attempts are refused. See also listen(2)"
(let ((r (sockint::listen (socket-file-descriptor socket) backlog)))
(if (= r -1)
(socket-error "listen"))))
+(defgeneric socket-open-p (socket)
+ (:documentation "Return true if SOCKET is open; otherwise, return false.")
+ (:method ((socket t)) (error 'type-error
+ :datum socket :expected-type 'socket)))
+
+(defmethod socket-open-p ((socket socket))
+ (if (slot-boundp socket 'stream)
+ (open-stream-p (slot-value socket 'stream))
+ (/= -1 (socket-file-descriptor socket))))
+
+(defgeneric socket-close (socket)
+ (:documentation "Close SOCKET. May throw any kind of error that
+write(2) would have thrown. If SOCKET-MAKE-STREAM has been called,
+calls CLOSE on that stream instead"))
+
(defmethod socket-close ((socket socket))
- "Close SOCKET. May throw any kind of error that write(2) would have
-thrown. If SOCKET-MAKE-STREAM has been called, calls CLOSE on that
-stream instead"
;; the close(2) manual page has all kinds of warning about not
;; checking the return value of close, on the grounds that an
;; earlier write(2) might have returned successfully w/o actually
;; descriptor). Presumably this is an oversight and we could also
;; get anything that write(2) would have given us.
- ;; What we do: we catch EBADF. It should only ever happen if
- ;; (a) someone's closed the socket already (stream closing seems
- ;; to have this effect) or (b) the caller is messing around with
- ;; socket internals. That's not supported, dude
-
- (if (slot-boundp socket 'stream)
- (close (slot-value socket 'stream)) ;; closes socket as well
- (handler-case
- (if (= (sockint::close (socket-file-descriptor socket)) -1)
- (socket-error "close"))
- (bad-file-descriptor-error (c) (declare (ignore c)) nil)
- (:no-error (c) (declare (ignore c)) nil))))
-
-(defmethod socket-make-stream ((socket socket) &rest args)
- "Find or create a STREAM that can be used for IO on SOCKET (which
-must be connected). ARGS are passed onto SB-SYS:MAKE-FD-STREAM."
+ ;; note that if you have a socket _and_ a stream on the same fd,
+ ;; the socket will avoid doing anything to close the fd in case
+ ;; the stream has done it already - if so, it may have been
+ ;; reassigned to some other file, and closing it would be bad
+
+ (let ((fd (socket-file-descriptor socket)))
+ (cond ((eql fd -1) ; already closed
+ nil)
+ ((slot-boundp socket 'stream)
+ (unwind-protect (close (slot-value socket 'stream)) ;; closes fd
+ (setf (slot-value socket 'file-descriptor) -1)
+ (slot-makunbound socket 'stream)))
+ (t
+ (sb-ext:cancel-finalization socket)
+ (handler-case
+ (if (= (sockint::close fd) -1)
+ (socket-error "close"))
+ (bad-file-descriptor-error (c) (declare (ignore c)) nil)
+ (:no-error (c)
+ (declare (ignore c))
+ (setf (slot-value socket 'file-descriptor) -1)
+ nil))))))
+
+
+(defgeneric socket-make-stream (socket &rest args)
+ (:documentation "Find or create a STREAM that can be used for IO on
+SOCKET (which must be connected). ARGS are passed onto
+SB-SYS:MAKE-FD-STREAM."))
+
+(defmethod socket-make-stream ((socket socket) &rest args)
(let ((stream
- (and (slot-boundp socket 'stream) (slot-value socket 'stream))))
+ (and (slot-boundp socket 'stream) (slot-value socket 'stream))))
(unless stream
(setf stream (apply #'sb-sys:make-fd-stream
- (socket-file-descriptor socket) args))
+ (socket-file-descriptor socket)
+ :name "a constant string"
+ :dual-channel-p t
+ args))
(setf (slot-value socket 'stream) stream)
(sb-ext:cancel-finalization socket))
stream))
(define-condition socket-error (error)
((errno :initform nil
- :initarg :errno
- :reader socket-error-errno)
+ :initarg :errno
+ :reader socket-error-errno)
(symbol :initform nil :initarg :symbol :reader socket-error-symbol)
(syscall :initform "outer space" :initarg :syscall :reader socket-error-syscall))
(:report (lambda (c s)
(socket-error-syscall c)
(or (socket-error-symbol c) (socket-error-errno c))
#+cmu (sb-unix:get-unix-error-msg num)
- #+sbcl (sb-int:strerror num))))))
+ #+sbcl (sb-int:strerror num)))))
+ (:documentation "Common base class of socket related conditions."))
;;; watch out for slightly hacky symbol punning: we use both the value
;;; and the symbol-name of sockint::efoo
`(progn
(define-condition ,name (socket-error)
((symbol :reader socket-error-symbol :initform (quote ,symbol))))
+ (export ',name)
(push (cons ,symbol (quote ,name)) *conditions-for-errno*)))
(defparameter *conditions-for-errno* nil)
;;; this needs the rest of the list adding to it, really. They also
-;;; need
-;;; - conditions to be exported in the DEFPACKAGE form
-;;; - symbols to be added to constants.ccon
+;;; need symbols to be added to constants.ccon
;;; I haven't yet thought of a non-kludgey way of keeping all this in
;;; the same place
(define-socket-condition sockint::EADDRINUSE address-in-use-error)
(define-socket-condition sockint::EAGAIN interrupted-error)
(define-socket-condition sockint::EBADF bad-file-descriptor-error)
(define-socket-condition sockint::ECONNREFUSED connection-refused-error)
+(define-socket-condition sockint::ETIMEDOUT operation-timeout-error)
(define-socket-condition sockint::EINTR interrupted-error)
(define-socket-condition sockint::EINVAL invalid-argument-error)
(define-socket-condition sockint::ENOBUFS no-buffers-error)
(define-socket-condition sockint::EPROTONOSUPPORT protocol-not-supported-error)
(define-socket-condition sockint::ESOCKTNOSUPPORT socket-type-not-supported-error)
(define-socket-condition sockint::ENETUNREACH network-unreachable-error)
-
+(define-socket-condition sockint::ENOTCONN not-connected-error)
(defun condition-for-errno (err)
(or (cdr (assoc err *conditions-for-errno* :test #'eql)) 'socket-error))
-
+
#+cmu
(defun socket-error (where)
;; Peter's debian/x86 cmucl packages (and sbcl, derived from them)
#+sbcl
(defun socket-error (where)
+ ;; FIXME: Our Texinfo documentation extracter need at least his to spit
+ ;; out the signature. Real documentation would be better...
+ ""
(let* ((errno (sb-unix::get-errno))
(condition (condition-for-errno errno)))
(error condition :errno errno :syscall where)))
+(defgeneric bits-of-sockaddr (socket sockaddr)
+ (:documentation "Return protocol-dependent bits of parameter
+SOCKADDR, e.g. the Host/Port if SOCKET is an inet socket."))
+(defgeneric size-of-sockaddr (socket)
+ (:documentation "Return the size of a sockaddr object for SOCKET."))
projects / sbcl.git / blobdiff