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