contrib/sb-bsd-sockets/sockets.lisp

   1 (in-package "SB-BSD-SOCKETS")
   2
   3 ;;;; Methods, classes, functions for sockets.  Protocol-specific stuff
   4 ;;;; is deferred to inet.lisp, unix.lisp, etc
   5
   6 (eval-when (:load-toplevel :compile-toplevel :execute)
   7 (defclass socket ()
   8   ((file-descriptor :initarg :descriptor
   9                     :reader socket-file-descriptor)
  10    (family :initform (error "No socket family")
  11            :reader socket-family)
  12    (protocol :initarg :protocol
  13              :reader socket-protocol
  14              :documentation "Protocol used by the socket. If a
  15 keyword, the symbol-name of the keyword will be passed to
  16 GET-PROTOCOL-BY-NAME downcased, and the returned value used as
  17 protocol. Other values are used as-is.")
  18    (type  :initarg :type
  19           :reader socket-type
  20           :documentation "Type of the socket: :STREAM or :DATAGRAM.")
  21    (stream))
  22   (:documentation "Common base class of all sockets, not ment to be
  23 directly instantiated.")))
  24
  25 (defmethod print-object ((object socket) stream)
  26   (print-unreadable-object (object stream :type t :identity t)
  27                            (princ "descriptor " stream)
  28                            (princ (slot-value object 'file-descriptor) stream)))
  29
  30
  31 (defmethod shared-initialize :after ((socket socket) slot-names
  32                                      &key protocol type
  33                                      &allow-other-keys)
  34   (let* ((proto-num
  35           (cond ((and protocol (keywordp protocol))
  36                  (get-protocol-by-name (string-downcase (symbol-name protocol))))
  37                 (protocol protocol)
  38                 (t 0)))
  39          (fd (or (and (slot-boundp socket 'file-descriptor)
  40                       (socket-file-descriptor socket))
  41                  (sockint::socket (socket-family socket)
  42                                   (ecase type
  43                                     ((:datagram) sockint::sock-dgram)
  44                                     ((:stream) sockint::sock-stream))
  45                                   proto-num))))
  46       (if (= fd -1) (socket-error "socket"))
  47       (setf (slot-value socket 'file-descriptor) fd
  48             (slot-value socket 'protocol) proto-num
  49             (slot-value socket 'type) type)
  50       (sb-ext:finalize socket (lambda () (sockint::close fd)))))
  51
  52 \f
  53
  54 (defgeneric make-sockaddr-for (socket &optional sockaddr &rest address)
  55   (:documentation "Return a Socket Address object suitable for use with SOCKET.
  56 When SOCKADDR is passed, it is used instead of a new object."))
  57
  58 (defgeneric free-sockaddr-for (socket sockaddr)
  59   (:documentation "Deallocate a Socket Address object that was
  60 created for SOCKET."))
  61
  62 (defmacro with-sockaddr-for ((socket sockaddr &optional sockaddr-args) &body body)
  63   `(let ((,sockaddr (apply #'make-sockaddr-for ,socket nil ,sockaddr-args)))
  64      (unwind-protect (progn ,@body)
  65        (free-sockaddr-for ,socket ,sockaddr))))
  66
  67 ;; we deliberately redesign the "bind" interface: instead of passing a
  68 ;; sockaddr_something as second arg, we pass the elements of one as
  69 ;; multiple arguments.
  70
  71 (defgeneric socket-bind (socket &rest address)
  72   (:documentation "Bind SOCKET to ADDRESS, which may vary according to
  73 socket family.  For the INET family, pass ADDRESS and PORT as two
  74 arguments; for FILE address family sockets, pass the filename string.
  75 See also bind(2)"))
  76
  77 (defmethod socket-bind ((socket socket)
  78                         &rest address)
  79   (with-sockaddr-for (socket sockaddr address)
  80     (if (= (sockint::bind (socket-file-descriptor socket)
  81                           sockaddr
  82                           (size-of-sockaddr socket))
  83            -1)
  84         (socket-error "bind"))))
  85
  86 \f
  87 (defgeneric socket-accept (socket)
  88   (:documentation "Perform the accept(2) call, returning a
  89 newly-created connected socket and the peer address as multiple
  90 values"))
  91
  92 (defmethod socket-accept ((socket socket))
  93   (with-sockaddr-for (socket sockaddr)
  94     (let ((fd (sockint::accept (socket-file-descriptor socket)
  95                                sockaddr
  96                                (size-of-sockaddr socket))))
  97       (cond
  98         ((and (= fd -1) (= sockint::EAGAIN (sb-unix::get-errno)))
  99          nil)
 100         ((= fd -1) (socket-error "accept"))
 101         (t (apply #'values
 102                   (let ((s (make-instance (class-of socket)
 103                               :type (socket-type socket)
 104                               :protocol (socket-protocol socket)
 105                               :descriptor fd)))
 106                     (sb-ext:finalize s (lambda () (sockint::close fd))))
 107                   (multiple-value-list (bits-of-sockaddr socket sockaddr))))))))
 108
 109 (defgeneric socket-connect (socket &rest address)
 110   (:documentation "Perform the connect(2) call to connect SOCKET to a
 111   remote PEER.  No useful return value."))
 112
 113 (defmethod socket-connect ((socket socket) &rest peer)
 114   (with-sockaddr-for (socket sockaddr peer)
 115     (if (= (sockint::connect (socket-file-descriptor socket)
 116                              sockaddr
 117                              (size-of-sockaddr socket))
 118            -1)
 119         (socket-error "connect"))))
 120
 121 (defgeneric socket-peername (socket)
 122   (:documentation "Return the socket's peer; depending on the address
 123   family this may return multiple values"))
 124
 125 (defmethod socket-peername ((socket socket))
 126   (with-sockaddr-for (socket sockaddr)
 127     (when (= (sockint::getpeername (socket-file-descriptor socket)
 128                                     sockaddr
 129                                     (size-of-sockaddr socket))
 130              -1)
 131       (socket-error "getpeername"))
 132     (bits-of-sockaddr socket sockaddr)))
 133
 134 (defgeneric socket-name (socket)
 135   (:documentation "Return the address (as vector of bytes) and port
 136   that the socket is bound to, as multiple values."))
 137
 138 (defmethod socket-name ((socket socket))
 139   (with-sockaddr-for (socket sockaddr)
 140     (when (= (sockint::getsockname (socket-file-descriptor socket)
 141                                    sockaddr
 142                                    (size-of-sockaddr socket))
 143              -1)
 144       (socket-error "getsockname"))
 145     (bits-of-sockaddr socket sockaddr)))
 146
 147
 148 ;;; There are a whole bunch of interesting things you can do with a
 149 ;;; socket that don't really map onto "do stream io", especially in
 150 ;;; CL which has no portable concept of a "short read".  socket-receive
 151 ;;; allows us to read from an unconnected socket into a buffer, and
 152 ;;; to learn who the sender of the packet was
 153
 154 (defgeneric socket-receive (socket buffer length
 155                             &key
 156                             oob peek waitall element-type)
 157   (:documentation "Read LENGTH octets from SOCKET into BUFFER (or a freshly-consed buffer if
 158 NIL), using recvfrom(2).  If LENGTH is NIL, the length of BUFFER is
 159 used, so at least one of these two arguments must be non-NIL.  If
 160 BUFFER is supplied, it had better be of an element type one octet wide.
 161 Returns the buffer, its length, and the address of the peer
 162 that sent it, as multiple values.  On datagram sockets, sets MSG_TRUNC
 163 so that the actual packet length is returned even if the buffer was too
 164 small"))
 165
 166 (defmethod socket-receive ((socket socket) buffer length
 167                            &key
 168                            oob peek waitall
 169                            (element-type 'character))
 170   (with-sockaddr-for (socket sockaddr)
 171     (let ((flags
 172            (logior (if oob sockint::MSG-OOB 0)
 173                    (if peek sockint::MSG-PEEK 0)
 174                    (if waitall sockint::MSG-WAITALL 0)
 175                    #+linux sockint::MSG-NOSIGNAL ;don't send us SIGPIPE
 176                    (if (eql (socket-type socket) :datagram)
 177                        sockint::msg-TRUNC 0))))
 178       (unless (or buffer length)
 179         (error "Must supply at least one of BUFFER or LENGTH"))
 180       (unless length
 181         (setf length (length buffer)))
 182       (when buffer (setf element-type (array-element-type buffer)))
 183       (unless (or (subtypep element-type 'character)
 184                   (subtypep element-type 'integer))
 185         (error "Buffer element-type must be either a character or an integer subtype."))
 186       (unless buffer
 187         (setf buffer (make-array length :element-type element-type)))
 188       ;; really big FIXME: This whole copy-buffer thing is broken.
 189       ;; doesn't support characters more than 8 bits wide, or integer
 190       ;; types that aren't (unsigned-byte 8).
 191       (let ((copy-buffer (sb-alien:make-alien (array (sb-alien:unsigned 8) 1) length)))
 192         (unwind-protect
 193             (sb-alien:with-alien ((sa-len sockint::socklen-t (size-of-sockaddr socket)))
 194               (let ((len
 195                      (sockint::recvfrom (socket-file-descriptor socket)
 196                                         copy-buffer
 197                                         length
 198                                         flags
 199                                         sockaddr
 200                                         (sb-alien:addr sa-len))))
 201                 (cond
 202                   ((and (= len -1) (= sockint::EAGAIN (sb-unix::get-errno))) nil)
 203                   ((= len -1) (socket-error "recvfrom"))
 204                   (t (loop for i from 0 below len
 205                            do (setf (elt buffer i)
 206                                     (cond
 207                                       ((or (eql element-type 'character) (eql element-type 'base-char))
 208                                        (code-char (sb-alien:deref (sb-alien:deref copy-buffer) i)))
 209                                       (t (sb-alien:deref (sb-alien:deref copy-buffer) i)))))
 210                      (apply #'values buffer len (multiple-value-list
 211                                                  (bits-of-sockaddr socket sockaddr)))))))
 212           (sb-alien:free-alien copy-buffer))))))
 213
 214 (defgeneric socket-listen (socket backlog)
 215   (:documentation "Mark SOCKET as willing to accept incoming connections.  BACKLOG
 216 defines the maximum length that the queue of pending connections may
 217 grow to before new connection attempts are refused.  See also listen(2)"))
 218
 219 (defmethod socket-listen ((socket socket) backlog)
 220   (let ((r (sockint::listen (socket-file-descriptor socket) backlog)))
 221     (if (= r -1)
 222         (socket-error "listen"))))
 223
 224 (defgeneric socket-close (socket)
 225   (:documentation "Close SOCKET.  May throw any kind of error that write(2) would have
 226 thrown.  If SOCKET-MAKE-STREAM has been called, calls CLOSE on that
 227 stream instead"))
 228
 229 (defmethod socket-close ((socket socket))
 230   ;; the close(2) manual page has all kinds of warning about not
 231   ;; checking the return value of close, on the grounds that an
 232   ;; earlier write(2) might have returned successfully w/o actually
 233   ;; writing the stuff to disk.  It then goes on to define the only
 234   ;; possible error return as EBADF (fd isn't a valid open file
 235   ;; descriptor).  Presumably this is an oversight and we could also
 236   ;; get anything that write(2) would have given us.
 237
 238   ;; note that if you have a socket _and_ a stream on the same fd,
 239   ;; the socket will avoid doing anything to close the fd in case
 240   ;; the stream has done it already - if so, it may have been
 241   ;; reassigned to some other file, and closing it would be bad
 242
 243   (let ((fd (socket-file-descriptor socket)))
 244     (cond ((eql fd -1) ; already closed
 245            nil)
 246           ((slot-boundp socket 'stream)
 247            (close (slot-value socket 'stream)) ;; closes fd
 248            (setf (slot-value socket 'file-descriptor) -1)
 249            (slot-makunbound socket 'stream))
 250           (t
 251            (sb-ext:cancel-finalization socket)
 252            (handler-case
 253                (if (= (sockint::close fd) -1)
 254                    (socket-error "close"))
 255              (bad-file-descriptor-error (c) (declare (ignore c)) nil)
 256              (:no-error (c)
 257                (declare (ignore c))
 258                (setf (slot-value socket 'file-descriptor) -1)
 259                nil))))))
 260
 261
 262 (defgeneric socket-make-stream (socket  &rest args)
 263     (:documentation "Find or create a STREAM that can be used for IO
 264 on SOCKET (which must be connected).  ARGS are passed onto
 265 SB-SYS:MAKE-FD-STREAM."))
 266
 267 (defmethod socket-make-stream ((socket socket)  &rest args)
 268   (let ((stream
 269          (and (slot-boundp socket 'stream) (slot-value socket 'stream))))
 270     (unless stream
 271       (setf stream (apply #'sb-sys:make-fd-stream
 272                           (socket-file-descriptor socket)
 273                           :name "a constant string"
 274                           :dual-channel-p t
 275                           args))
 276       (setf (slot-value socket 'stream) stream)
 277       (sb-ext:cancel-finalization socket))
 278     stream))
 279
 280 \f
 281
 282 ;;; Error handling
 283
 284 (define-condition socket-error (error)
 285   ((errno :initform nil
 286           :initarg :errno
 287           :reader socket-error-errno)
 288    (symbol :initform nil :initarg :symbol :reader socket-error-symbol)
 289    (syscall  :initform "outer space" :initarg :syscall :reader socket-error-syscall))
 290   (:report (lambda (c s)
 291              (let ((num (socket-error-errno c)))
 292                (format s "Socket error in \"~A\": ~A (~A)"
 293                        (socket-error-syscall c)
 294                        (or (socket-error-symbol c) (socket-error-errno c))
 295                        #+cmu (sb-unix:get-unix-error-msg num)
 296                        #+sbcl (sb-int:strerror num)))))
 297   (:documentation "Common base class of socket related conditions."))
 298
 299 ;;; watch out for slightly hacky symbol punning: we use both the value
 300 ;;; and the symbol-name of sockint::efoo
 301
 302 (defmacro define-socket-condition (symbol name)
 303   `(progn
 304      (define-condition ,name (socket-error)
 305        ((symbol :reader socket-error-symbol :initform (quote ,symbol))))
 306      (export ',name)
 307      (push (cons ,symbol (quote ,name)) *conditions-for-errno*)))
 308
 309 (defparameter *conditions-for-errno* nil)
 310 ;;; this needs the rest of the list adding to it, really.  They also
 311 ;;; need symbols to be added to constants.ccon
 312 ;;; I haven't yet thought of a non-kludgey way of keeping all this in
 313 ;;; the same place
 314 (define-socket-condition sockint::EADDRINUSE address-in-use-error)
 315 (define-socket-condition sockint::EAGAIN interrupted-error)
 316 (define-socket-condition sockint::EBADF bad-file-descriptor-error)
 317 (define-socket-condition sockint::ECONNREFUSED connection-refused-error)
 318 (define-socket-condition sockint::ETIMEDOUT operation-timeout-error)
 319 (define-socket-condition sockint::EINTR interrupted-error)
 320 (define-socket-condition sockint::EINVAL invalid-argument-error)
 321 (define-socket-condition sockint::ENOBUFS no-buffers-error)
 322 (define-socket-condition sockint::ENOMEM out-of-memory-error)
 323 (define-socket-condition sockint::EOPNOTSUPP operation-not-supported-error)
 324 (define-socket-condition sockint::EPERM operation-not-permitted-error)
 325 (define-socket-condition sockint::EPROTONOSUPPORT protocol-not-supported-error)
 326 (define-socket-condition sockint::ESOCKTNOSUPPORT socket-type-not-supported-error)
 327 (define-socket-condition sockint::ENETUNREACH network-unreachable-error)
 328 (define-socket-condition sockint::ENOTCONN not-connected-error)
 329
 330 (defun condition-for-errno (err)
 331   (or (cdr (assoc err *conditions-for-errno* :test #'eql)) 'socket-error))
 332
 333 #+cmu
 334 (defun socket-error (where)
 335   ;; Peter's debian/x86 cmucl packages (and sbcl, derived from them)
 336   ;; use a direct syscall interface, and have to call UNIX-GET-ERRNO
 337   ;; to update the value that unix-errno looks at.  On other CMUCL
 338   ;; ports, (UNIX-GET-ERRNO) is not needed and doesn't exist
 339   (when (fboundp 'unix::unix-get-errno) (unix::unix-get-errno))
 340   (let ((condition (condition-for-errno sb-unix:unix-errno)))
 341     (error condition :errno sb-unix:unix-errno  :syscall where)))
 342
 343 #+sbcl
 344 (defun socket-error (where)
 345   ;; FIXME: Our Texinfo documentation extracter need at least his to spit
 346   ;; out the signature. Real documentation would be better...
 347   ""
 348   (let* ((errno  (sb-unix::get-errno))
 349          (condition (condition-for-errno errno)))
 350     (error condition :errno errno  :syscall where)))
 351
 352
 353 (defgeneric bits-of-sockaddr (socket sockaddr)
 354   (:documentation "Return protocol-dependent bits of parameter
 355 SOCKADDR, e.g. the Host/Port if SOCKET is an inet socket."))
 356
 357 (defgeneric size-of-sockaddr (socket)
 358   (:documentation "Return the size of a sockaddr object for SOCKET."))