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